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



;;; *** Implementation pseudocode reading ***


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


(define theme-read-body-expr-fwd '())


(define gl-debug '())
(define gl-var1 '())
(define gl-var2 '())
(define gl-stop2? #f)
(define gl-flag9? #f)


;; (define addr1 (make-hrecord <address> '(tests test14) 1 '<a>))

;; (define (my-check address-env)
;;   (if gl-flag9?
;;       (let ((var (address-env-get-item address-env addr1)))
;; 	(if (eq? var #f)
;; 	    (dwl4 "my-check: not found")
;; 	    (let ((value (hfield-ref var 'value)))
;; 	      (cond
;; 	       ((null? value)
;; 		(dwl4 "my-check: no value"))
;; 	       ((hfield-ref value 'incomplete?)
;; 		(dwl4 "my-check: incomplete"))
;; 	       (else
;; 		(let ((all-fields (tno-field-ref value 'all-fields)))
;; 		  (dw1 "my-check: ")
;; 		  (dwl4 (length (car all-fields)))))))))))


(define (get-binder-for-parsing linker)
  (hfield-ref linker 'binder-parsing))


(define (linker-search-global linker address)
  (let ((ht (hfield-ref linker 'ht-globals-by-address)))
    (address-hash-ref ht address)))


;; The following procedure is not used.
(define (get-method-decl-var-for-linker linker t-method-type)
  (make-normal-variable
   (linker-alloc-loc linker '() #t)
   t-method-type
   #t
   #t
   #t
   '()
   #f))


(define (pr-parse-address linker expr)
  (parse-address (hfield-ref linker 'current-module) expr))


(define (pr-parse-primitive-value linker address-env decl)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? decl) (= (length decl) 2)))
  (let* ((module (hfield-ref linker 'current-module))
	 (contents (list-ref decl 1))
	 (type (get-primitive-type contents))
	 (prim-expr (make-primitive-object type contents)))
    prim-expr))


(define (pr-parse-pair linker address-env decl)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? decl) (= (length decl) 3)))
  (let* ((obj-first (theme-read-body-expr-fwd linker address-env (cadr decl)))
	 (obj-second (theme-read-body-expr-fwd linker address-env (caddr decl)))
	 (first-type (get-entity-type obj-first))
	 (second-type (get-entity-type obj-second))
	 (type
	  (make-tpci-pair first-type second-type))
	 (exact-type?
	  (and (hfield-ref obj-first 'exact-type?)
	       (hfield-ref obj-second 'exact-type?)))
	 (primitive?
	  (and (is-t-primitive-object? obj-first)
	       (is-t-primitive-object? obj-second)))
	 (to
	  (make-target-object
	   type
	   #t exact-type? '()
	   primitive?
	   #f
	   `((first . ,obj-first)
	     (second . ,obj-second))
	   '())))
    to))


(define (pr-parse-normal-variable linker address-env expr)
  ;; jos tarvitsee, niin lisää exported?-kentän luku
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 8)))
  (let ((address (pr-parse-address linker (list-ref expr 1)))
	(type (theme-read-body-expr-fwd linker address-env (list-ref expr 2)))
	(type-dispatched? (list-ref expr 3))
	(exact-type? (list-ref expr 4))
	(read-only? (list-ref expr 5))
	(volatile? (list-ref expr 6))
	(local-forward-decl? (list-ref expr 7)))
    (let ((result
	   (make-normal-variable10
	    address
	    type
	    type-dispatched?
	    exact-type?
	    read-only?
	    volatile?
	    local-forward-decl?
	    '()
	    #f)))
      result)))


(define (pr-parse-maybe-variable linker address-env expr)
  (if (null? expr)
      '()
      (pr-parse-normal-variable linker address-env expr)))


(define (pr-parse-object-ref linker address-env pexpr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? pexpr) (= (length pexpr) 2)))
  (let* ((module (hfield-ref linker 'current-module))
	 (address (parse-address module (list-ref pexpr 1)))
	 (gv (linker-search-global linker address))
	 (to (address-env-get-item address-env address)))
    (cond
     ((not (eq? gv #f)) gv)
     ((is-target-object? to) to)
     (else
      (raise (list 'invalid-object-ref (cons 'address address)))))))


(define (make-variable-fields to addr-raw)
  (let* ((al0 (hfield-ref to 'al-field-values))
	 (al (if al0 al0 '())))
    (if (not-null? addr-raw)
	(append al
		(list
		 (cons 'addr-raw-proc
		       addr-raw)))
	al0)))
      

(define (parse-variable-contents linker address-env make-var contents address
				 declared? read-only? volatile?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (procedure? make-var))
  (strong-assert (and (list? contents) (= (length contents) 5)))
  (strong-assert (is-address? address))
  (strong-assert (boolean? declared?))
  (strong-assert (boolean? read-only?))
  (strong-assert (boolean? volatile?))
  (strong-assert (eq? (car contents) 'define-variable))
  (let* ((p-type (list-ref contents 1))
	 ;; interface-read-expr? is not needed in the linker.
	 (p-value-expr (list-ref contents 3))
	 (prevent-stripping? (list-ref contents 4))
	 (t-type (theme-read-body-expr-fwd linker address-env p-type)))
    (let* ((t-value-expr (theme-read-body-expr-fwd linker address-env
						   p-value-expr))
	   (t-value (get-entity-value t-value-expr))
	   (binder (get-binder-for-parsing linker)))
      (let ((var
	     (if read-only?
		 (begin
		   (let* ((to-value (get-entity-value t-value-expr))
			  (to
			   (cond
			    ((and (is-tc-param-proc? t-type)
				  (or (hrecord-is-instance? t-value-expr
							    <prim-proc-ref>)
				      (hrecord-is-instance? t-value-expr
							    <checked-prim-proc>)))
			     (make-param-proc-object
			      (hfield-ref address 'source-name)
			      t-type
			      t-value-expr
			      address))
			    ((and (not-null? to-value)
				  (hrecord-is-instance? t-value-expr
							<prim-proc-ref>))
			     (make-target-object
			      (hfield-ref to-value 'type)
			      (hfield-ref to-value 'type-dispatched?)
			      (hfield-ref to-value 'exact-type?)
			      address
			      (hfield-ref to-value 'primitive?)
			      (hfield-ref to-value 'incomplete?)
			      (make-variable-fields
			       to-value
			       (hfield-ref t-value-expr 'address))
			      (hfield-ref to-value 'obj-prim-contents)))
			    ((and (not-null? to-value)
				  (hrecord-is-instance? t-value-expr
							<param-proc-expr>)
				  (hrecord-is-instance?
				   (hfield-ref t-value-expr 'body)
				   <prim-proc-ref>))
			     (let* ((ent-body (hfield-ref t-value-expr 'body))
				    (addr-raw (hfield-ref ent-body 'address)))
			       (make-target-object
				(hfield-ref to-value 'type)
				(hfield-ref to-value 'type-dispatched?)
				(hfield-ref to-value 'exact-type?)
				address
				(hfield-ref to-value 'primitive?)
				(hfield-ref to-value 'incomplete?)
				(make-variable-fields to-value addr-raw)
				(hfield-ref to-value 'obj-prim-contents))))
			    ((not-null? to-value)
			     (make-object-with-address
			      (get-entity-value t-value-expr) address))
			    (else
			     (make-unknown-object-with-address
			      t-type 
			      (is-final-class? binder t-type)
			      address))))
			  (to-new
			   (address-env-bind-object! binder address-env declared?
						     to))
			  (var0 (make-normal-variable7
				 address
				 t-type
				 (is-final-class? binder t-type)
				 read-only?
				 volatile?
				 #f
				 (get-entity-value t-value-expr)
				 t-value-expr
				 #f)))
		     var0))
		 (begin
		   (let ((var0 (make-normal-variable7
				address
				t-type
				(is-final-class? binder t-type)
				read-only?
				volatile?
				#f
				'()
				t-value-expr
				#f)))
		     (address-env-bind-variable!
		      binder address-env declared? var0))))))
	(assert (is-normal-variable? var))
	(make-hrecord <variable-definition>
		      tt-none
		      #t
		      #t
		      '()
		      #f
		      #f
		      #f
		      '()
		      var
		      t-type
		      t-value-expr
		      declared?
		      prevent-stripping?
		      prevent-stripping?)))))


;; (define (parse-obj-ref-contents linker address-env make-var contents declared?)
;;   (dwl4 "parse-obj-ref-contents")
;;   (assert (hrecord-is-instance? linker <linker>))
;;   (assert (hrecord-is-instance? address-env <address-environment>))
;;   (assert (procedure? make-var))
;;   (strong-assert (and (list? contents) (= (length contents) 2)))
;;   (strong-assert (boolean? declared?))
;;   (strong-assert (eqv? (car contents) 'obj-ref))
;;   (dwl4 "parse-obj-ref-contents/0")
;;   (let* ((p-address (list-ref contents 1))
;; 	 (r-address (pr-parse-address linker p-address))
;; 	 (old-var (address-env-get-item address-env r-address)))
;;     (dwl4 "parse-obj-ref-contents/1")
;;     (if old-var
;; 	(begin
;; 	  (dwl4 "parse-obj-ref-contents/2")
;; 	  (assert (hrecord-is-instance? old-var <normal-variable>))
;; 	  (let* ((r-type (get-entity-type old-var))
;; 		 (r-value-expr (hfield-ref old-var 'value-expr))
;; 		 (r-value (get-entity-value old-var))
;; 		 (var (make-var r-value-expr r-value r-type))
;; 		 (value-expr2
;; 		  ;; Is it correct to set need-revision? := #f here?
;; 		  (make-hrecord <variable-reference>
;; 				r-type
;; 				#t #f #t
;; 				(and (not-null? r-value-expr)
;; 				     (is-static-entity? r-value-expr))
;; 				#f
;; 				r-value
;; 				old-var))
;; 		 (binder (get-binder-for-parsing linker)))
;; 	    (address-env-bind-variable! binder address-env declared? var)
;; 	    (make-hrecord
;; 	     <variable-definition>
;; 	     tt-none
;; 	     #t
;; 	     #t
;; 	     '()
;; 	     #f
;; 	     #f
;; 	     #f
;; 	     '()
;; 	     var
;; 	     r-type
;; 	     value-expr2
;; 	     declared?
;; 	     #f
;; 	     #f)))
;; 	(raise 'invalid-obj-ref))))


(define (pr-parse-type-variable linker address-env expr)
  ;; jos tarvitsee, niin lisää exported?-kentän luku
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (parse-type-variable (hfield-ref linker 'current-module) expr))


(define (pr-parse-tvar linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (parse-type-variable (hfield-ref linker 'current-module) (cadr expr)))


(define (pr-parse-type-vars linker address-env p-type-vars)
  (parse-type-variables (hfield-ref linker 'current-module) p-type-vars))


(define (pr-parse-class-field linker address-env field)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? field) (= (length field) 6)))
  (let* ((name (list-ref field 0))
	 (p-type (list-ref field 1))
	 (read-access (list-ref field 2))
	 (write-access (list-ref field 3))
	 (has-init-value? (list-ref field 4))
	 (r-init-value
	  (if has-init-value?
	      (theme-read-body-expr-fwd linker address-env
					(list-ref field 5))
	      '()))
	 (type (theme-read-body-expr-fwd linker address-env p-type)))
    (if (entity-is-none1? (get-binder-for-parsing linker) type)
	(raise 'field-type-none)
	(make-field name type read-access write-access has-init-value?
		    r-init-value))))


(define (pr-parse-class-fields linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (list? expr))
  (map (lambda (field) (pr-parse-class-field linker address-env field)) expr))



(define (parse-class-contents linker address-env make-var contents address
			      declared?)
  ;;  (my-check address-env)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (procedure? make-var))
  (strong-assert (and (list? contents) (= (length contents) 8)))
  (strong-assert (is-address? address))
  (strong-assert (boolean? declared?))
  (strong-assert (eq? (car contents) 'define-class))
  (strong-assert (is-address? address))
  (let ((module (hfield-ref linker 'current-module))
	(name (list-ref contents 1))
	(superclass (theme-read-body-expr-fwd linker address-env
					      (list-ref contents 2)))
	(fields (pr-parse-class-fields linker address-env
				       (list-ref contents 3)))
	(inh? (list-ref contents 4))
	(imm? (list-ref contents 5))
	(ebv? (list-ref contents 6))
	(ctr-access (list-ref contents 7)))
    (strong-assert (boolean? inh?))
    (strong-assert (boolean? imm?))
    (strong-assert (boolean? ebv?))
    (strong-assert (memq ctr-access gl-access-specifiers))
    (let* ((to-class
	    (make-target-class
	     address
	     module
	     superclass
	     fields
	     inh?
	     imm?
	     ebv?
	     ctr-access))
	   (binder (get-binder-for-parsing linker))
	   (to-new (address-env-bind-object! binder address-env declared?
					     to-class))
	   (var (make-var '() to-new tc-class)))
      (make-constructor! binder to-new)
      (make-hrecord
       <class-definition>
       tt-none
       #t
       #t
       '()
       #f
       #f
       #f
       '()
       var
       tc-class
       empty-expression
       declared?
       #f
       #f))))


(define (parse-param-class-contents linker address-env make-var contents
				    address declared?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (procedure? make-var))
  (strong-assert (and (list? contents) (= (length contents) 3)))
  (strong-assert (is-address? address))
  (strong-assert (boolean? declared?))
  (strong-assert (eq? (car contents) 'define-param-class))
  (strong-assert (is-address? address))
  (let ((type-vars-expr (list-ref contents 1))
	(class-expr (list-ref contents 2)))
    (if (= (length class-expr) 8)
	(let* ((r-type-vars (pr-parse-type-vars
			     linker address-env type-vars-expr))
	       (local-env (construct-local-address-env
			   address-env r-type-vars)))
	  (let ((module (hfield-ref linker 'current-module))
		(name (list-ref class-expr 1))
		(r-inst-super (theme-read-body-expr-fwd
			       linker local-env
			       (list-ref class-expr 2)))
		(r-inst-fields
		 (pr-parse-class-fields linker local-env
					(list-ref class-expr 3)))
		(inh? (list-ref class-expr 4))
		(imm? (list-ref class-expr 5))
		(ebv? (list-ref class-expr 6))
		(ctr-access (list-ref class-expr 7)))
	    (strong-assert (boolean? inh?))
	    (strong-assert (boolean? imm?))
	    (strong-assert (boolean? ebv?))
	    (strong-assert (memq ctr-access gl-access-specifiers))
	    (let* ((to
		    (make-parametrized-class-object
		     (get-binder-for-parsing linker)
		     module
		     name
		     address
		     r-type-vars
		     r-inst-super
		     r-inst-fields
		     inh?
		     imm?
		     ebv?
		     ctr-access))
		   (binder (get-binder-for-parsing linker))
		   (to-new (address-env-bind-object!
			    binder address-env declared? to))
		   (var (make-var '() to-new t-param-class)))
	      (make-hrecord <param-class-definition>
			    tt-none
			    #t
			    #t
			    '()
			    #f
			    #f
			    #f
			    '()
			    var
			    t-param-class
			    empty-expression
			    declared?
			    #f #f
			    r-type-vars))))
	(raise 'internal-syntax-error-in-param-class))))


(define (parse-param-ltype-contents linker address-env make-var
				    contents address declared?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (procedure? make-var))
  (strong-assert (and (list? contents) (= (length contents) 4)))
  (strong-assert (boolean? declared?))
  (strong-assert (eq? (car contents) 'define-param-logical-type))
  (strong-assert (is-address? address))
  (let ((name (list-ref contents 1))
	(p-type-vars (list-ref contents 2))
	(p-value-expr (list-ref contents 3)))
    (let* ((r-type-vars (pr-parse-type-vars linker address-env p-type-vars))
	   (local-env (construct-local-address-env address-env r-type-vars))
	   (r-value-expr (theme-read-body-expr-fwd linker local-env p-value-expr))
	   (to (make-param-logical-type-object name address r-type-vars
					       r-value-expr))
	   ;; The value-expr argument was '() earlier.
	   (binder (get-binder-for-parsing linker))
	   (to-new (address-env-bind-object! binder address-env declared? to))
	   (var (make-var r-value-expr to-new t-param-logical-type)))
      (let ((result
	     (make-hrecord <param-logical-type-def>
			   tt-none
			   #t
			   #t
			   '()
			   #f
			   #f
			   #f
			   '()
			   var
			   tc-logical-type
			   r-value-expr
			   declared?
			   #f #f
			   r-type-vars)))
	result))))


(define (impl-parse-signature-members linker address-env p-members)
  (map* (lambda (p-member)
	  (cons (theme-read-body-expr-fwd linker
					  address-env
					  (car p-member))
		(theme-read-body-expr-fwd linker
					  address-env
					  (cadr p-member))))
	p-members))


(define (parse-general-var-def-contents linker address-env contents make-var
					declared? address read-only? volatile?)
  (case (car contents)
    ((define-variable) (parse-variable-contents linker address-env make-var
						contents address declared?
						read-only? volatile?))
;;    ((obj-ref) (parse-obj-ref-contents linker address-env make-var
;;				       contents declared?))
    ((define-class) (parse-class-contents linker address-env make-var
					  contents address declared?))
    ((define-param-class) (parse-param-class-contents linker address-env
						      make-var
						      contents 
						      address
						      declared?))
    ((define-param-logical-type) (parse-param-ltype-contents
				  linker address-env make-var contents
				  address declared?))
    (else (raise 'unknown-definition-type))))


(define (pr-parse-general-variable linker address-env expr)
  (strong-assert (eq? (car expr) 'general-variable))
  (if (= (length expr) 9)
      (let ((name (list-ref expr 1))
	    (local-forward-decl? (list-ref expr 2))
	    (declared? (list-ref expr 3))
	    (p-address (list-ref expr 4))
	    (exact-type? (list-ref expr 5))
	    (read-only? (list-ref expr 6))
	    (volatile? (list-ref expr 7))
	    (p-contents (list-ref expr 8)))
	(let* ((t-address (pr-parse-address linker p-address))
	       (make-var
		(lambda (value-expr value type)
		  (make-normal-variable7
		   t-address
		   type
		   exact-type?
		   read-only?
		   volatile?
		   local-forward-decl?
		   value
		   value-expr
		   #f)))
	       (def-expr (parse-general-var-def-contents
			  linker address-env p-contents make-var declared?
			  t-address read-only? volatile?)))
	  def-expr))
      (raise 'invalid-variable-definition-in-body)))


(define (pr-read-signature linker address-env pexpr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? pexpr) (= (length pexpr) 2)))
  (strong-assert (eq? (car pexpr) 'signature))
  (let* ((p-members (cadr pexpr))
	 (r-members (impl-parse-signature-members linker address-env
						  p-members))
	 (to (make-signature-object '() r-members)))
    to))


(define (pr-read-param-signature linker address-env pexpr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? pexpr) (= (length pexpr) 3)))
  (strong-assert (eq? (car pexpr) 'param-signature))
  (let* ((p-type-vars (cadr pexpr))
	 (r-type-vars (pr-parse-type-vars linker address-env p-type-vars))
	 (local-env (construct-local-address-env address-env r-type-vars))
	 (p-members (caddr pexpr))
	 (r-members (impl-parse-signature-members linker local-env
						  p-members))
	 (to (make-param-sgn-object '() r-type-vars r-members)))
    to))


(define (pr-read-gen-proc linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (strong-assert (eq? (car expr) 'gen-proc))
  (let* ((p-address (list-ref expr 1))
	 (address (pr-parse-address linker p-address))
	 (to-clas (make-gen-proc-class-object '()))
	 (name (hfield-ref address 'source-name))
	 (str-name (symbol->string name)))
    (let* ((name (hfield-ref address 'source-name))
	   (a (symbol-hash-ref (hfield-ref linker 'ht-globals-by-name) name)))
      (if (not (eq? a #f))
	  (begin
	    (strong-assert (eq?
			    (get-entity-type
			     (get-entity-type a))
			    tmc-gen-proc))
	    (if (eq? (linker-search-global linker address) #f)
		(address-hash-set!
		 (hfield-ref linker 'ht-globals-by-address)
		 address a))
	    empty-expression)
	  (let* ((to (make-gen-proc-object to-clas str-name '() address))
		 (var
		  (make-normal-variable2
		   address
		   to-clas
		   #t
		   #t
		   #f
		   to
		   '()
		   #f)))
	    (assert (eq? (linker-search-global linker address) #f))	
	    (address-env-add-binding! address-env to)
	    (symbol-hash-set! (hfield-ref linker 'ht-globals-by-name)
			      name to)
	    (address-hash-set! (hfield-ref linker 'ht-globals-by-address)
			       address to)
	    (make-hrecord
	     <generic-procedure-definition>
	     tt-none
	     #t
	     #t
	     '()
	     #f
	     #f
	     #f
	     '()
	     var
	     to-clas
	     '()
	     ;; declared? should have no effect here
	     #f #f #f))))))


(define (get-class-instance-object linker to param-type args)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (or (null? to) (hrecord-is-instance? to <target-object>)))
  (assert (is-target-object? param-type))
  (strong-assert (list? args))
  (assert (and-map? is-target-object? args))
  (translate-param-class-instance-expr (get-binder-for-parsing linker)
				       param-type
				       args
				       (hfield-ref linker 'inside-param-def?)
				       ;; Should we have inside-param-def?
				       ;; here.
				       #t))


(define (pr-parse-type-var-values linker address-env p-values)
  (map (lambda (p-value) (theme-read-body-expr-fwd linker address-env p-value))
       p-values))


(define (do-read-param-class-instance linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 3)))
  (let ((p-param-type (list-ref expr 1))
	(p-params (list-ref expr 2)))
    (let* ((r-param-type0 (theme-read-body-expr-fwd linker address-env
						   p-param-type))
	   (r-param-type-address (hfield-ref r-param-type0 'address))
	   (r-params (pr-parse-type-var-values linker address-env p-params)))
      (strong-assert (is-address? r-param-type-address))
      (let ((r-param-type
	     (address-env-get-item address-env r-param-type-address)))
	(assert (or (eq? r-param-type #f)
		    (is-target-object? r-param-type)))
	(let ((result
	       (cond
		((eq? r-param-type #f)
		 (raise 'undefined-param-class))
		((hfield-ref r-param-type 'incomplete?)
		 (get-class-instance-object
		  linker
		  '()
		  r-param-type
		  r-params))
		(else
		 (translate-param-class-instance-expr
		  (get-binder-for-parsing linker)
		  r-param-type
		  r-params
		  #f #t)))))
	  result)))))


(define (pr-general-read-var-ref linker address-env expr forward?) 
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (strong-assert (boolean? forward?))
  (let* ((address (pr-parse-address linker (list-ref expr 1)))
	 (gv (linker-search-global linker address)))
    (cond
     ((not (eq? gv #f))
      (strong-assert (hrecord-is-instance? gv <normal-variable>))
      (make-hrecord
       <variable-reference>
       (get-entity-type gv)
       (hfield-ref gv 'type-dispatched?)
       (hfield-ref gv 'exact-type?)
       address
       #t
       #f
       #f
       (get-entity-value gv)
       gv))
     ((not (= (hfield-ref address 'number) address-number-target))
      (let ((var (address-env-get-item address-env address)))
	(if var
	    (cond
	     ((hrecord-is-instance? var <normal-variable>)
	      (begin
		(make-var-ref-to-var var)))
	     ((is-t-type-variable? var)
	      (begin
		(raise 'type-variable-error)))
	     (else
	      (write-error-info expr)
	      (raise 'internal-invalid-variable)))
	    (begin
	      (write-error-info expr)
	      (dvar1-set! address)
	      (raise 'reference-to-undefined-variable)))))
     (else
      ;; Set need-revision? = #f
      ;; Should we set type-dispatched? to #f?
      (make-hrecord <variable-reference>
		    tc-object
		    #t
		    #f
		    address
		    #t
		    #f
		    #f
		    '()
		    (make-normal-variable1
		     address
		     tc-object
		     #f
		     #f
		     '()))))))


(define (pr-read-var-ref linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (let ((result
	 (pr-general-read-var-ref linker address-env expr #f)))
    result))


(define (pr-read-var-forward-ref linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (pr-general-read-var-ref linker address-env expr #t))


(define (pr-read-prim-proc-ref linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 4)
		      (eq? (car expr) 'prim-proc-ref)))
  (let* ((need-revision? (cadr expr))
	 (p-address (caddr expr))
	 (p-type (list-ref expr 3))
	 (address (pr-parse-address linker p-address))
	 (type (theme-read-body-expr-fwd linker address-env p-type))
	 (to (make-target-object
	      type #t #f address
	      #f #f #f '())))
    (make-hrecord <prim-proc-ref>
		  type
		  #t
		  #f
		  address
		  #t
		  #t
		  need-revision?
		  to)))


(define (pr-read-checked-prim-proc linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 4)
		      (eq? (car expr) 'checked-prim-proc)))
  (let* ((need-revision? (cadr expr))
	 (p-address (caddr expr))
	 (p-type (list-ref expr 3))
	 (address (pr-parse-address linker p-address))
	 (type (theme-read-body-expr-fwd linker address-env p-type))
	 (to (make-target-object
			   type
			   #t #f address
			   #f #f
			   #f '())))
    ;; Formerly we had object-repr? = #f.
    (make-hrecord <checked-prim-proc>
		  type
		  #t
		  #f
		  address
		  #t
		  #t
		  need-revision?
		  to)))


(define (pr-read-prim-class-def linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 15)
		      (eq? (car expr) 'prim-class-def)))
  (let ((p-address (list-ref expr 1))
	(name (list-ref expr 2))
	(target-name (list-ref expr 3))
	(goops? (list-ref expr 4))
	(p-superclass (list-ref expr 5))
	(inh? (list-ref expr 6))
	(imm? (list-ref expr 7))
	(ebv? (list-ref expr 8))
	(checked? (list-ref expr 9))
	(member-target-name (list-ref expr 10))
	(equal-target-name (list-ref expr 11))
	(equal-objects-target-name (list-ref expr 12))
	(equal-contents-target-name (list-ref expr 13))
	(p-zero-address (list-ref expr 14)))
    (strong-assert (string? name))
    (strong-assert (or (symbol? target-name) (null? target-name)))
    (strong-assert (boolean? goops?))
    (strong-assert (boolean? inh?))
    (strong-assert (boolean? imm?))
    (strong-assert (boolean? ebv?))
    (strong-assert (boolean? checked?))
    (strong-assert (or (and goops? (null? member-target-name))
		       (and (not goops?) (symbol? member-target-name))))
    (strong-assert (symbol? equal-target-name))
    (strong-assert (symbol? equal-objects-target-name))
    (strong-assert (symbol? equal-contents-target-name))
    (let* ((r-address (pr-parse-address linker p-address))
	   (ht (if goops?
		   (hfield-ref linker 'ht-goops-classes)
		   (hfield-ref linker 'ht-prim-classes)))
	   (a (if goops?
		  (symbol-hash-ref ht target-name)
		  (symbol-hash-ref ht member-target-name))))
      (if (not (eq? a #f))
	  (begin
	    (if goops?
		(display-goops-warning target-name)
		(display-prim-warning member-target-name))
	    (if (eq? (linker-search-global linker r-address) #f)
		(address-hash-set!
		 (hfield-ref linker 'ht-globals-by-address) r-address a))
	    empty-expression)
	  (let* ((r-superclass (theme-read-body-expr-fwd linker address-env
							 p-superclass))
		 (module (hfield-ref linker 'current-module))
		 (r-zero-address
		  (if (not-null? p-zero-address)
		      (parse-address module p-zero-address)
		      '()))
		 (new-obj (create-custom-prim-class r-address name module
						    goops? r-superclass
						    inh? imm? ebv?
						    r-zero-address))
		 (binder (get-binder-for-parsing linker))
		 (declared? (if (address-env-get-item address-env r-address) #t #f))
		 (obj (address-env-bind-object! binder address-env declared?
						new-obj))
		 (var (make-var-with-address obj r-address)))
	    (symbol-hash-set! ht
			      (if goops? target-name member-target-name)
			      obj)
	    (address-hash-set! (hfield-ref linker 'ht-globals-by-address)
			       r-address obj)
	    (hashq-set! (hfield-ref linker 'ht-equal)
	    		obj equal-target-name)
	    (hashq-set! (hfield-ref linker 'ht-equal-objects)
	    		obj equal-objects-target-name)
	    (hashq-set! (hfield-ref linker 'ht-equal-contents)
	    		obj equal-contents-target-name)
	    (make-hrecord
	     <prim-class-def>
	     tt-none
	     #t
	     #t
	     '()
	     #f
	     #f
	     #f
	     '()
	     var
	     tc-class
	     '()
	     ;; A primitive class should always be declared.
	     #t
	     #f
	     #f
	     name
	     target-name
	     goops?
	     r-superclass
	     inh?
	     imm?
	     ebv?
	     checked?
	     member-target-name
	     equal-target-name
	     equal-objects-target-name
	     equal-contents-target-name
	     r-zero-address))))))


(define (pr-read-set-expr linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 6)))
  (let ((need-revision? (cadr expr))
	(always-returns? (caddr expr))
	(never-returns? (list-ref expr 3))
	(address (pr-parse-address linker (list-ref expr 4)))
	(value-expr (theme-read-body-expr-fwd linker address-env
					      (list-ref expr 5))))
    (if (entity-type-is-none1? (get-binder-for-parsing linker) value-expr)
	(raise 'set-expression-with-type-none)
	(let ((var (address-env-get-item address-env address)))
	  (make-hrecord
	   <set-expression>
	   tt-none
	   #t
	   #t
	   '()
	   #t
	   #f
	   need-revision?
	   '()
	   always-returns?
	   never-returns?
	   var
	   value-expr)))))


(define (pr-read-param-class-instance linker address-env expr)
  (do-read-param-class-instance linker address-env expr))


(define (pr-read-param-proc-instance linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 4)))
  (let ((need-revision? (cadr expr))
	(p-param-proc (list-ref expr 2))
	(p-param-values (list-ref expr 3)))
    (let ((r-param-proc
	   (theme-read-body-expr-fwd linker address-env p-param-proc))
	  (r-param-values
	   (map (lambda (p-param)
		  (theme-read-body-expr-fwd linker address-env p-param))
		p-param-values)))
      ;; Maybe we should/could construct an <expr-param-proc-instance>
      ;; directly without calling translate-param-proc-instance.
      ;; Should we set type-check? := #f when need-revision? = #t?
      (translate-param-proc-instance
       (get-binder-for-parsing linker)
       r-param-proc r-param-values
       #t))))


(define (pr-read-param-proc-dispatch linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 4)))
  (let ((need-revision? (cadr expr))
	(p-param-proc (list-ref expr 2))
	(p-argument-types (list-ref expr 3)))
    (let ((r-param-proc
	   (theme-read-body-expr-fwd linker address-env p-param-proc))
	  (r-argument-types
	   (map (lambda (p-arg)
		  (theme-read-body-expr-fwd linker address-env p-arg))
		p-argument-types)))
      ;; Maybe we should/could construct an <expr-param-proc-instance>
      ;; directly without calling translate-param-proc-instance.
      ;; Should we set type-check? := #f when need-revision? = #t?
      (translate-param-proc-dispatch
       (get-binder-for-parsing linker)
       r-param-proc r-argument-types
       (not (hfield-ref linker 'inside-param-def?))))))


(define (pr-read-generic-proc-dispatch linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 11)
		      (eq? (car expr) 'generic-proc-dispatch)))
  (let ((need-revision? (list-ref expr 1))
	(p-type (list-ref expr 2))
	(exact-type? (list-ref expr 3))
	(pure? (list-ref expr 4))
	(with-result? (list-ref expr 5))
	(appl-pure? (list-ref expr 6))
	(appl-always-returns? (list-ref expr 7))
	(appl-never-returns? (list-ref expr 8))
	(p-generic-proc (list-ref expr 9))
	(p-arg-types (list-ref expr 10)))
    (let* ((r-type (theme-read-body-expr-fwd linker address-env
					     p-type))
	   (r-generic-proc (theme-read-body-expr-fwd linker address-env
						     p-generic-proc))
	   (r-arg-types (map* (lambda (p-arg-type)
				(theme-read-body-expr-fwd
				 linker address-env p-arg-type))
			      p-arg-types))
	   (binder (get-binder-for-parsing linker))
	   (r-arg-type-list (construct-toplevel-type-repr binder r-arg-types))
	   (regular? (is-tuple-type? binder r-arg-type-list))
	   (r-actual-args
	    (if regular?
		(tuple-type->list-reject-cycles r-arg-type-list)
		r-arg-types)))
      (make-hrecord
       <generic-proc-dispatch>
       r-type
       #t
       exact-type?
       '()
       pure?
       #f
       need-revision?
       '()
       r-generic-proc
       r-actual-args
       with-result?
       appl-pure?
       appl-always-returns?
       appl-never-returns?
       regular?))))


(define (do-read-constructor linker address-env to-class)
  ;; Should we check if to-class is nil?
  (let* ((binder (get-binder-for-parsing linker))
	 (result
	  (cond
	   ((is-t-apti? to-class)
	    (let* ((type-args (tno-field-ref to-class 'l-type-args))
		   (type-arg-list
		    (construct-toplevel-type-repr binder type-args)))
	      (if (is-tuple-type? binder type-arg-list)
		  (let ((type-params (tuple-type->list-reject-cycles
				      type-arg-list)))
		    (if (and-map?
			 (lambda (param)
			   (and (not (is-t-type-variable? param))))
			 type-params)
			(let ((type (begin
				      (get-constructor-type binder
							    to-class))))
			  (make-hrecord <expr-constructor>
					type
					#t
					#t
					'()
					#t
					;; MIETI seuraava
					#t
					;; MIETI seuraava
					#f
					'()
					to-class))
			(get-empty-constructor to-class)))
		  (get-empty-constructor to-class))))
	   ((is-t-instance? binder to-class tpc-pair)
	    (let ((type (translate-simple-proc-class-expression
			 binder
			 (tno-field-ref to-class 'l-tvar-values)
			 to-class #t #t #f #f)))
	      (make-hrecord <expr-constructor>
			    type
			    #t
			    #t
			    '()
			    #t
			    ;; MIETI seuraava
			    #t
			    #f
			    '()
			    to-class)))
	   ((is-t-param-class-instance? to-class)
	    (let* ((args (tno-field-ref to-class 'l-tvar-values))
		   (type-arg-list
		    (construct-toplevel-type-repr binder args)))
	      (if (is-tuple-type? binder type-arg-list)
		  (let ((type-params (tuple-type->list-reject-cycles
				       type-arg-list)))
		    (if (and-map?
			 (lambda (param)
			   (not (is-t-type-variable? param)))
			 type-params)
			(let ((tt-constructor
			       (begin
				 (dwl4 "do-read-constructor/1")
				 (tno-field-ref to-class 'type-constructor))))
			  ;; Maybe assert would be enough.
			  (strong-assert (not-null? tt-constructor))
			  (get-constructor-expr to-class tt-constructor))
			(get-empty-constructor to-class)))
		  (get-empty-constructor to-class))))
	   ((is-t-type-variable? to-class)
	    (get-empty-constructor to-class))
	   (else
	    (let ((tt-constructor (tno-field-ref to-class 'type-constructor)))
	      (if (not-null? tt-constructor)
		  (get-constructor-expr to-class tt-constructor)
		  (raise 'internal-constructor-not-defined)))))))
    result))


(define (pr-read-constructor linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (let ((class-expr
	 (theme-read-body-expr-fwd linker address-env (cadr expr))))
    (let ((result
	   (do-read-constructor linker address-env class-expr)))
      result)))


(define (pr-read-zero linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (strong-assert (eq? (car expr) 'zero))
  (let* ((p-clas (cadr expr))
	 (r-clas (theme-read-body-expr-fwd linker address-env p-clas))
	 (zero-expr
	  (make-hrecord <zero-expr>
			r-clas
			#t
			#t
			'()
			#t
			#t
			#f
			'()
			r-clas)))
    zero-expr))


(define (pr-read-zero-setting linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 4)))
  (strong-assert (eq? (car expr) 'set-zero))
  (let* ((p-addr-cl (cadr expr))
	 (p-zero-proc (caddr expr))
	 (param? (list-ref expr 3))
	 (addr-cl (pr-parse-address linker p-addr-cl))
	 (cl (address-env-get-item address-env addr-cl))
	 (r-zero-proc
	  (theme-read-body-expr-fwd linker address-env p-zero-proc)))
    (strong-assert (boolean? param?))
    (cond
     ((eq? cl #f)
      (raise 'set-zero:class-not-found))
     (else
      (cond
       ((is-t-param-class? cl)
	(assert param?)
	(tno-field-set! cl 'instance-has-zero? #t))
       ((is-t-class? cl)
	(assert (not param?))
	(tno-field-set! cl 'has-zero? #t))
       (else (raise 'zero-setting:invalid-class))) 
      (make-hrecord <zero-setting-expr>
		    tt-none
		    #t
		    #t
		    '()
		    #f
		    #f
		    #f
		    '()
		    cl
		    r-zero-proc
		    param?)))))


(define (read-normal-field-ref linker r-object r-field-name need-revision?
			       type-dispatched? always-returns? never-returns?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-entity? r-object))
  ;; Case r-field-name not a symbol constant is not handled here.
  (strong-assert (symbol? r-field-name))
  (strong-assert (boolean? need-revision?))
  (strong-assert (boolean? type-dispatched?))
  (strong-assert (boolean? always-returns?))
  (strong-assert (boolean? never-returns?))
  (let* ((clas (get-entity-type r-object))
	 (field (get-field-spec clas r-field-name)))
    (if (not (eq? field #f))
	(let* ((field-type (tno-field-ref field 'type))
	       (exact-type?
		(and (is-t-instance?
		      (get-binder-for-parsing linker)
		      field-type tc-class)
		     (not (tno-field-ref field-type 'inheritable?)))))
	  (make-hrecord <field-ref-expr>
			field-type
			type-dispatched?
			#f
			'()
			#t
			#f
			need-revision?
			'()
			always-returns?
			never-returns?
			#t
			r-object
			r-field-name))
	(raise 'field-ref:undefined-field))))


(define (pr-read-field-ref linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 8)))
  (let ((need-revision? (list-ref expr 1))
	(type-dispatched? (list-ref expr 2))
	(always-returns? (list-ref expr 3))
	(never-returns? (list-ref expr 4))
	(const-field-name? (list-ref expr 5))
	(p-object (list-ref expr 6))
	(p-field-name (list-ref expr 7)))
    (strong-assert const-field-name?)
    (strong-assert (boolean? need-revision?))
    (let* ((r-object (theme-read-body-expr-fwd linker address-env p-object))
	   (r-field-name
	    (if const-field-name?
		p-field-name
		(theme-read-body-expr-fwd linker address-env p-field-name))))
      (let ((result
	     ;; (if (hfield-ref linker 'inside-param-def?)
	     ;; 	 (read-field-ref-inside-param-def r-object r-field-name
	     ;; 					  need-revision?
	     ;; 					  never-returns?)
	     ;; 	 (read-normal-field-ref linker r-object r-field-name
	     ;; 				need-revision?
	     ;; 				never-returns?))))
	     (read-normal-field-ref linker r-object r-field-name
				    need-revision?
				    type-dispatched?
				    always-returns?
				    never-returns?)))
	result))))


(define (read-normal-field-set binder r-object
			       r-field-name r-field-value
			       need-revision?
			       always-returns?
			       never-returns?
			       inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? r-object))
  ;; Case r-field-name not a symbol constant is not handled here.
  (assert (symbol? r-field-name))
  (assert (is-entity? r-field-value))
  (strong-assert (boolean? need-revision?))
  (strong-assert (boolean? always-returns?))
  (strong-assert (boolean? never-returns?))
  (let* ((field-value-type (get-entity-type r-field-value))
	 (clas (get-entity-type r-object))
	 (field (get-field-spec clas r-field-name)))
    (if (not (eq? field #f))
	(let ((field-type (tno-field-ref field 'type)))
	  (strong-assert
	   (or (not (entity-type-dispatched? r-field-value))
	       (and inside-param-def?
		    (or (contains-free-tvars? field-value-type)
			(contains-free-tvars? field-type)))
	       (is-t-subtype? binder
			      field-value-type field-type)))
	  (make-hrecord <field-set-expr>
			tt-none
			#t
			#f
			'()
			#t
			#f
			need-revision?
			'()
			always-returns?
			never-returns?
			#t
			r-object
			r-field-name
			r-field-value))
	(raise 'field-set:undefined-field))))


(define (pr-read-field-set linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 8)))
  (let ((need-revision? (list-ref expr 1))
	(always-returns? (list-ref expr 2))
	(never-returns? (list-ref expr 3))
	(const-field-name? (list-ref expr 4))
	(p-object (list-ref expr 5))
	(p-field-name (list-ref expr 6))
	(p-field-value (list-ref expr 7)))
    (strong-assert const-field-name?)
    (strong-assert (boolean? need-revision?))
    (strong-assert (boolean? never-returns?))
    (let* ((r-object (theme-read-body-expr-fwd linker address-env p-object))
	   (r-field-name
	    (if const-field-name?
		p-field-name
		(theme-read-body-expr-fwd linker address-env p-field-name)))
	   (r-field-value (theme-read-body-expr-fwd
			   linker address-env p-field-value)))
      (let ((binder
	     (get-binder-for-parsing linker)))
	(read-normal-field-set binder r-object
			       r-field-name r-field-value
			       need-revision?
			       always-returns?
			       never-returns?
			       (hfield-ref linker 'inside-param-def?))))))


(define (pr-read-proc-appl linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 15)))
  (let* ((need-revision? (list-ref expr 1))
	 (type-dispatched? (list-ref expr 2))
	 (always-returns? (list-ref expr 3))
	 (never-returns? (list-ref expr 4))
	 (type
	  (theme-read-body-expr-fwd linker address-env (list-ref expr 5)))
	 (exact-type? (list-ref expr 6))
	 (pure? (list-ref expr 7))
	 ;; The following is probably unnecessary.
	 (val
	  (let ((val-expr (list-ref expr 8)))
	    (if (not-null? val-expr)
		(theme-read-body-expr-fwd linker address-env val-expr)
		'())))
	 (proc (theme-read-body-expr-fwd linker address-env (list-ref expr 9)))
	 (arglist
	  (map (lambda (subexpr)
		 (theme-read-body-expr-fwd linker address-env subexpr))
	       (list-ref expr 10)))
	 (params
	  (map (lambda (p-param)
		 (theme-read-body-expr-fwd linker address-env p-param))
	       (list-ref expr 11)))
	 (static-arg-types
	  (map (lambda (p-param)
		 (theme-read-body-expr-fwd linker address-env p-param))
	       (list-ref expr 12)))
	 (runtime-arglist-typecheck? (list-ref expr 13))
	 (l-default-params
	  (map (lambda (p-param)
		 (theme-read-body-expr-fwd linker address-env p-param))
	       (list-ref expr 14))))
    (assert (boolean? exact-type?))
    (assert (boolean? pure?))
    (assert (or (null? val) (is-entity? val)))
    (assert (and (list? arglist)
		 (and-map? is-entity? arglist)))
    (assert (boolean? need-revision?))
    (assert (is-entity? proc))
    (assert (and (list? l-default-params)
		 (and-map? is-entity? l-default-params)))
    (let ((result
	   (make-hrecord
	    <proc-appl>
	    type
	    type-dispatched?
	    exact-type?
	    '()
	    pure?
	    #f
	    need-revision?
	    val
	    always-returns?
	    never-returns?
	    proc
	    arglist
	    params
	    static-arg-types
	    runtime-arglist-typecheck?
	    l-default-params)))
      result)))


;; HUOM. Kentällä local-env on eri tyyppi kääntäjässä
;; ja linkkerissä.


(define (pr-read-proc-expr linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 16)))
  (let ((need-revision? (list-ref expr 1))
	(p-type-expr (list-ref expr 2))
	(pure? (list-ref expr 3))
	(arg-names (list-ref expr 4))
	(p-arg-descs (list-ref expr 5))
	(p-arg-variables (list-ref expr 6))
	(p-result-type (list-ref expr 7))
	(p-body-expr (list-ref expr 8))
	(s-kind (list-ref expr 9))
	(s-name (list-ref expr 10))
	(pure-proc? (list-ref expr 11))
	(force-pure-proc? (list-ref expr 12))
	(appl-always-returns? (list-ref expr 13))
	(appl-never-returns? (list-ref expr 14))
	(static-method? (list-ref expr 15)))
    (let* ((comp (lambda (p-repr) (theme-read-body-expr-fwd linker address-env
							    p-repr)))
	   (type (comp p-type-expr))
	   (exact-type? #t)
	   (arg-descs (map comp p-arg-descs))
	   (arg-variables (map
			   (lambda (arg) (pr-parse-normal-variable linker
								   address-env
								   arg))
			   p-arg-variables))
	   (result-type (comp p-result-type)))
      (let ((local-env (construct-local-address-env address-env arg-variables)))
	(let ((body (theme-read-body-expr-fwd linker local-env p-body-expr))
	      (to (make-target-object
		   type
		   #t #f '()
		   #f #f #f '())))
	  (make-hrecord
	   <procedure-expression>
	   type
	   #t
	   exact-type?
	   '()
	   pure?
	   #f
	   need-revision?
	   to
	   arg-names
	   arg-descs
	   arg-variables
	   result-type
	   body
	   s-kind
	   s-name
	   (hfield-ref linker 'current-module)
	   pure-proc?
	   force-pure-proc?
	   appl-always-returns?
	   appl-never-returns?
	   static-method?))))))


(define (pr-read-method-def linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 6)))
  (let ((gen-proc-address (list-ref expr 1))
	(method-type (list-ref expr 2))
	(proc-expr (list-ref expr 3))
	(static? (list-ref expr 4))
	(declared? (list-ref expr 5)))
    (strong-assert (boolean? static?))
    (strong-assert (boolean? declared?))
    (let* ((r-gen-proc-address
	    (pr-parse-address linker gen-proc-address))
	   (r-gen-proc (address-hash-ref
			(hfield-ref linker 'ht-globals-by-address)
			r-gen-proc-address))
	   (proc-repr (theme-read-body-expr-fwd linker address-env proc-expr))
	   (binder (get-binder-for-parsing linker))
	   (r-method-type (theme-read-body-expr-fwd linker address-env
						    method-type)))
      (let* ((decl (generic-find-decl binder r-gen-proc r-method-type))
	     (declared2? (not-null? decl)))
	(strong-assert (eq? declared? declared2?))
	(if (and (null? decl)
		 (not (check-covariant-typing-for-method-type?
		       binder r-gen-proc r-method-type)))
	    (raise (list 'noncovariant-method-definition
			 r-gen-proc r-method-type)))
	(let* ((old-address (if (not-null? decl)
				(hfield-ref (car decl) 'address)
				'()))
	       (to-new
		(add-method-to-generic2! binder
					 r-gen-proc
					 decl
					 proc-repr
					 static?))
	       (result
		(make-hrecord
		 <method-definition>
		 tt-none
		 #t
		 #t
		 '()
		 ;; MIETI pure?
		 #f
		 #f
		 #f
		 '()
		 r-gen-proc
		 proc-repr
		 static?
		 declared?
		 old-address
		 #f)))
	  (if (not-null? decl)
	      (address-hash-set! (hfield-ref binder 'ht-method-decls)
				 old-address result))
	  result)))))


(define (pr-read-method-decl linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 5)))
  (let ((p-gen-proc-address (list-ref expr 1))
	(p-address (list-ref expr 2))
	(p-method-type (list-ref expr 3))
	(static? (list-ref expr 4)))
    (strong-assert (boolean? static?))
    (let* ((r-gen-proc-address
	    (pr-parse-address linker p-gen-proc-address))
	   (r-gen-proc (address-hash-ref
			(hfield-ref linker 'ht-globals-by-address)
			r-gen-proc-address))
	   (r-address (pr-parse-address linker p-address))
	   (r-method-type (theme-read-body-expr-fwd linker address-env
						    p-method-type))
	   (binder (get-binder-for-parsing linker)))
      (strong-assert (is-t-gen-proc? r-gen-proc))
      (strong-assert (is-target-object? r-method-type))
      (let* ((r-method (get-method-declaration r-address r-method-type))
	     (decl (generic-find-decl binder r-gen-proc r-method-type)))
	(if (and (null? decl)
		 (not (check-covariant-typing-for-method-type?
		       binder r-gen-proc r-method-type)))
	    (raise (list 'noncovariant-method-declaration
			 r-gen-proc r-method-type)))
	(add-new-method-to-generic! binder
				    r-gen-proc
				    r-method
				    static?)
	;; Covariance checking detects method redeclarations.
	(address-env-bind-object! binder address-env #f r-method)
	(dwl4 "pr-read-method-decl EXIT")
	(make-hrecord
	 <method-declaration>
	 tt-none
	 #t
	 #t
	 '()
	 ;; MIETI pure?
	 #f
	 #f
	 #f
	 '()
	 r-gen-proc
	 r-method
	 static?
	 #f)))))


(define (pr-read-general-proc-type linker address-env expr simple?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 7)))
  (let ((p-arg-list-desc (list-ref expr 1))
	(p-result-type (list-ref expr 2))
	(pure-proc? (list-ref expr 3))
	(appl-always-returns? (list-ref expr 4))
	(appl-never-returns? (list-ref expr 5))
	(static-method? (list-ref expr 6)))
    (strong-assert (boolean? pure-proc?))
    (strong-assert (boolean? appl-always-returns?))
    (strong-assert (boolean? appl-never-returns?))
    (let ((arg-list-desc
	   (theme-read-body-expr-fwd linker address-env p-arg-list-desc))
	  (result-type
	   (theme-read-body-expr-fwd linker address-env p-result-type)))
      (let ((result
	     (translate-general-proc-type-expression0
	      simple?
	      arg-list-desc
	      result-type
	      pure-proc?
	      appl-always-returns?
	      appl-never-returns?
	      static-method?)))
	result))))


(define (pr-read-proc-type linker address-env expr)
  (pr-read-general-proc-type linker address-env expr #f))


(define (pr-read-simple-proc-class linker address-env expr)
  (pr-read-general-proc-type linker address-env expr #t))


(define (pr-read-param-proc-class linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 3)
		      (eq? (car expr) 'param-proc-class)))
  (let* ((p-type-vars (list-ref expr 1))
	 (p-type (list-ref expr 2))
	 (r-type-vars (pr-parse-type-vars linker address-env p-type-vars))
	 (local-env1 (construct-local-address-env address-env
						  r-type-vars))
	 (r-type (theme-read-body-expr-fwd linker local-env1 p-type))
	 (ppc (make-param-proc-class-object
	       "instance of :param-proc"
	       r-type-vars
	       r-type)))
    ppc))


(define (pr-read-gen-proc-class linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (>= (length expr) 1)
		      (eq? (car expr) 'gen-proc-class)))
  (let* ((p-method-classes (cdr expr))
	 (r-method-classes
	  (map* (lambda (pexpr)
		  (theme-read-body-expr-fwd linker address-env pexpr))
		p-method-classes)))
    (make-gen-proc-class-object r-method-classes)))


(define (pr-read-param-proc linker address-env p-expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? p-expr) (= (length p-expr) 6)
		      (eq? (car p-expr) 'param-proc)))
  (let ((inside-param-def-old? (hfield-ref linker 'inside-param-def?)))
    (hfield-set! linker 'inside-param-def? #t)
    (let* ((s-kind (list-ref p-expr 1))
	   (s-name (list-ref p-expr 2))
	   (p-type-vars (list-ref p-expr 3))
	   (p-type (list-ref p-expr 4))
	   (p-body (list-ref p-expr 5))
	   (r-type (theme-read-body-expr-fwd linker address-env p-type))
	   (r-type-vars (tno-field-ref r-type 'l-tvars))
	   (local-env (construct-local-address-env address-env
						   r-type-vars))
	   (r-body (theme-read-body-expr-fwd linker local-env p-body))
	   (to (make-param-proc-object s-name
				       r-type
				       r-body
				       '()))
	   (result
	    (make-param-proc2 r-type-vars r-type r-body s-kind
			      (hfield-ref linker 'current-module)
			      to)))
      (hfield-set! linker 'inside-param-def? inside-param-def-old?)
      result)))


(define (pr-parse-cycle linker env pexpr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? env <address-environment>))
  (strong-assert (and (list? pexpr) (= (length pexpr) 4)
		      (eq? (car pexpr) 'cycle)))
  (let* ((p-type (list-ref pexpr 1))
	 (p-address (list-ref pexpr 2))
	 (p-contents (list-ref pexpr 3))
	 (r-type (theme-read-body-expr-fwd linker env p-type))
	 (module (hfield-ref linker 'current-module))
	 (address (parse-address module p-address))
	 (obj (make-incomplete-object-with-address
	       address
	       r-type
	       (is-final-class? (get-binder-for-parsing linker) r-type)))
	 (local-env (construct-local-address-env env (list obj)))
	 (r-contents (theme-read-body-expr-fwd linker local-env p-contents)))
    (assert (is-target-object? r-contents))
    (set-object! obj r-contents)
    obj))


(define (pr-read-rest linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)
		      (eq? (car expr) 'rest)))
  (let* ((p-component-type (cadr expr))
	 (r-component-type (theme-read-body-expr-fwd linker address-env
						     p-component-type)))
    (make-rest-object r-component-type)))


(define (pr-read-splice linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)
		      (eq? (car expr) 'splice)))
  (let* ((p-component-type (cadr expr))
	 (r-component-type (theme-read-body-expr-fwd linker address-env
						     p-component-type)))
    (make-splice-object r-component-type)))


(define (pr-read-type-list linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)
		      (eq? (car expr) 'type-list)))
  (let* ((p-component-types (cadr expr))
	 (r-component-types
	  (map (lambda (component)
		 (theme-read-body-expr-fwd linker address-env component))
	       p-component-types))
	 (binder (get-binder-for-parsing linker)))
    (make-type-list-object r-component-types)))


(define (pr-read-type-loop linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 4)
		      (eq? (car expr) 'type-loop)))
  (let ((p-iter-var-address (list-ref expr 1))
	(p-subtype-list (list-ref expr 2))
	(p-iter-expr (list-ref expr 3)))
    (let* ((module (hfield-ref linker 'current-module))
	   (r-iter-var-address
	    (parse-address module p-iter-var-address))
	   (iter-var (make-type-variable r-iter-var-address))
	   (r-subtype-list (theme-read-body-expr-fwd linker address-env
						     p-subtype-list))
	   (local-env (construct-local-address-env address-env (list iter-var)))
	   (r-iter-expr (theme-read-body-expr-fwd linker local-env
						  p-iter-expr))
	   (binder (get-binder-for-parsing linker)))
      (make-type-loop-object
       iter-var r-subtype-list r-iter-expr))))


(define (pr-read-type-join linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)
		      (eq? (car expr) 'type-join)))
  (let* ((p-subtypes (cadr expr))
	 (r-subtypes
	  ;; Not sure if the evaluation order has any significance here.
	  (map* (lambda (component)
		  (theme-read-body-expr-fwd linker address-env component))
		p-subtypes)))
    (make-type-join-object r-subtypes)))


(define (pr-read-union linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (let* ((p-args (list-ref expr 1))
	 (r-args
	  (map* (lambda (pexpr)
		  (theme-read-body-expr-fwd linker address-env
					    pexpr))
		p-args))
	 (binder (get-binder-for-parsing linker))
	 (result
	  (get-union-of-types binder r-args)))
    result))


(define (pr-read-pair linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 3)))
  (let* ((p-args (cdr expr))
	 (r-args
	  (map* (lambda (pexpr)
		  (theme-read-body-expr-fwd linker address-env
					    pexpr))
		p-args))
	 ;; It is essential to use param-cache-parsing here.
	 (binder (get-binder-for-parsing linker))
	 (result
	  (translate-pair-class-expression binder r-args)))
    result))


;; (define (pr-read-uniform-list linker address-env expr)
;;   (assert (hrecord-is-instance? linker <linker>))
;;   (assert (hrecord-is-instance? address-env <address-environment>))
;;   (strong-assert (and (list? expr) (= (length expr) 5)))
;;   (let* ((p-arg (list-ref expr 4))
;; 	 (r-arg (theme-read-body-expr-fwd
;; 		 linker address-env p-arg))
;; 	 (binder (get-binder-for-parsing linker)))
;;     (translate-uniform-list-type-expression binder r-arg)))


;; Maybe we should use procedures translate-vector-expression0 etc. for the
;; vector classes.
(define (pr-read-uniform-vector linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (let ((member-type-expr (list-ref expr 1)))
    (let ((member-type-repr (theme-read-body-expr-fwd
			     linker address-env member-type-expr)))
      (let* ((binder (get-binder-for-parsing linker))
	     (result
	      (translate-vector-expression binder (list member-type-repr))))
	result))))


(define (pr-read-mutable-uniform-vector linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (let ((member-type-expr (list-ref expr 1)))
    (let ((member-type-repr (theme-read-body-expr-fwd
			     linker address-env member-type-expr))
	  (binder (get-binder-for-parsing linker)))
      (translate-mutable-vector-expression binder (list member-type-repr)))))


(define (pr-read-value-vector linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (let ((member-type-expr (list-ref expr 1)))
    (let ((member-type-repr (theme-read-body-expr-fwd
			     linker address-env member-type-expr))
	  (binder (get-binder-for-parsing linker)))
      (translate-value-vector-expression binder (list member-type-repr)))))


(define (pr-read-mutable-value-vector linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (let ((member-type-expr (list-ref expr 1)))
    (let ((member-type-repr (theme-read-body-expr-fwd
			     linker address-env member-type-expr))
	  (binder (get-binder-for-parsing linker)))
      (translate-mutable-value-vector-expression binder
						 (list member-type-repr)))))


(define (pr-read-apti linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 3)))
  (let* ((p-param-type (cadr expr))
	 (p-args (caddr expr))
	 (r-param-type (theme-read-body-expr-fwd linker address-env
						 p-param-type))
	 (r-args (map* (lambda (p1) (theme-read-body-expr-fwd linker
							      address-env p1))
		       p-args)))
    (make-apti r-param-type r-args)))


(define (pr-parse-let-var linker address-env varspec read-only?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? varspec) (= (length varspec) 7)))
  (let ((s-name (list-ref varspec 1))
	(p-address (list-ref varspec 2))
	(sexpr-location (list-ref varspec 3))
	(sexpr-type (list-ref varspec 4))
	(sexpr-init-expr (list-ref varspec 5))
	(known-init? (list-ref varspec 6)))
    (let* ((to-name (make-primitive-object tc-symbol s-name))
	   (address (pr-parse-address linker p-address))
	   (loc
	    (if (not-null? sexpr-location)
		(pr-parse-normal-variable linker address-env sexpr-location)
		'()))
	   (type-decl
	    (if (not-null? sexpr-type)
		(theme-read-body-expr-fwd linker address-env
					  sexpr-type)
		'()))
	   (init-expr (theme-read-body-expr-fwd linker address-env
						sexpr-init-expr))
	   (obj-known (if known-init? gl-true gl-false))
	   (binding0 (if known-init? init-expr loc))
	   (binding
	    (if known-init?
		(make-object-with-address binding0 address)
		binding0))
	   (type (if (not-null? type-decl)
		     type-decl
		     (get-entity-type init-expr)))
	   (variable (if known-init?
			 (make-normal-variable3
			  address
			  type-decl
			  #f
			  #f
			  #t
			  #f
			  (get-entity-value init-expr)
			  '())
			 loc)))
      ;; Not sure if incomplete objects work here.
      (if (and (not-null? loc) (is-target-object? init-expr))
	  (begin
	    (hfield-set! loc 'value-expr init-expr)
	    (hfield-set! loc 'value (get-entity-value init-expr))))
      (let ((result
	     (list to-name variable binding type-decl init-expr obj-known)))
	result))))


(define (pr-parse-let-vars linker address-env variables read-only?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (list? variables))
  (map (lambda (varspec) (pr-parse-let-var linker address-env varspec
					   read-only?))
       variables))


(define (pr-make-letrec-vars linker address-env vars)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (and (list? vars)
	       (and-map? (lambda (vardesc)
			   (and (list? vardesc)
				(= (length vardesc) 7)
				(eq? (car vardesc) 'let-var)))
			 vars)))
  (let ((result '()))
    (do ((cur-lst vars (cdr cur-lst)))
	((null? cur-lst) result)
      (let* ((current (car cur-lst))
	     (loc (pr-parse-normal-variable linker address-env
					    (list-ref current 3))))
	(if (list-ref current 6)
	    (let ((to (make-unknown-object-with-address
		       (get-entity-type loc)
		       (hfield-ref loc 'exact-type?)
		       (hfield-ref loc 'address))))
	      (set! result (append result (list (list loc to)))))
	    (set! result (append result (list (list loc loc)))))))))


(define (pr-parse-letrec-vars linker address-env names
			      vars decl-types init-exprs
			      bind-object)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (let ((i-count (length names)))
    (assert (and (list? names) (and-map? symbol? names)))
    (assert (and (list? vars)
		 (= (length vars) i-count)
		 (and-map? is-normal-variable? vars)))
    (assert (and (list? decl-types) (= (length decl-types) i-count)))
    (assert (and (list? init-exprs) (= (length init-exprs) i-count)))
    (assert (and (list? bind-object)
		 (= (length bind-object) i-count)
		 (and-map? boolean? bind-object))))
  (let* ((t-names (map (lambda (s-name)
			       (make-primitive-object tc-symbol s-name))
		       names))
	 (t-decl-types
	  (map (lambda (s-expr)
		 (theme-read-body-expr-fwd linker address-env s-expr))
	       decl-types))
	 (t-init-exprs
	  (map (lambda (s-expr)
		 (theme-read-body-expr-fwd linker address-env s-expr))
	       init-exprs))
	 (t-bindings
	  (map (lambda (bind-object? var init-expr)
		 (if bind-object? init-expr var))
	       bind-object vars t-init-exprs))
	 (t-bind-object
	  (map (lambda (b?)
		 (if b? gl-true gl-false))
	       bind-object)))
    (map list t-names vars t-bindings
	 t-decl-types t-init-exprs t-bind-object)))


(define (pr-read-let linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 13)))
  (let ((need-revision? (list-ref expr 1))
	(type-dispatched? (list-ref expr 2))
	(always-returns? (list-ref expr 3))
	(never-returns? (list-ref expr 4))
	(type-expr (list-ref expr 5))
	(exact-type? (list-ref expr 6))
	(pure? (list-ref expr 7))
	(readonly-bindings? (list-ref expr 8))
	(var-exprs (list-ref expr 11))
	(body-expr (list-ref expr 12)))
    (let ((type (theme-read-body-expr-fwd linker address-env type-expr))
	  (variables (pr-parse-let-vars linker address-env var-exprs
					readonly-bindings?)))
      (let ((local-env (construct-local-address-env
			address-env
			(map caddr variables))))
	(let* ((body
		(theme-read-body-expr-fwd linker local-env body-expr))
	       (value (get-entity-value body))
	       (result
		(make-hrecord
		 <let-expression>
		 type
		 type-dispatched?
		 exact-type?
		 '()
		 pure?
		 #f
		 need-revision?
		 value
		 always-returns?
		 never-returns?
		 readonly-bindings?
		 #f
		 #f
		 variables
		 body)))
	  result)))))


(define (pr-read-letrec linker address-env expr order?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 13)))
  (let ((need-revision? (list-ref expr 1))
	(type-dispatched? (list-ref expr 2))
	(always-returns? (list-ref expr 3))
	(never-returns? (list-ref expr 4))
	(type-expr (list-ref expr 5))
	(exact-type? (list-ref expr 6))
	(pure? (list-ref expr 7))
	(readonly-bindings? (list-ref expr 8))
	(var-exprs (list-ref expr 11))
	(body-expr (list-ref expr 12)))
    (let* ((read-pexpr (lambda (pexpr) (theme-read-body-expr-fwd
					linker
					address-env
					pexpr)))
	   (type (read-pexpr type-expr))
	   (vardescs (pr-make-letrec-vars linker address-env var-exprs))
	   (vars (map car vardescs))
	   (bindings (map cadr vardescs)))
      (let* ((local-env (construct-local-address-env
			 address-env
			 bindings))
	     (variables (pr-parse-letrec-vars
			 linker local-env
			 (map cadr var-exprs)
			 vars
			 (map (lambda (x) (list-ref x 4)) var-exprs)
			 (map (lambda (x) (list-ref x 5)) var-exprs)
			 (map (lambda (x) (list-ref x 6)) var-exprs)))
	     (body
	      (theme-read-body-expr-fwd linker local-env body-expr))
	     (value (get-entity-value body)))
	  (make-hrecord
	   <let-expression>
	   type
	   type-dispatched?
	   exact-type?
	   '()
	   pure?
	   #f
	   need-revision?
	   value
	   always-returns?
	   never-returns?
	   readonly-bindings?
	   #t
	   order?
	   variables
	   body)))))


(define (pr-read-general-let linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 13)))
  (let ((recursive? (list-ref expr 9))
	(order? (list-ref expr 10)))
    (strong-assert (boolean? recursive?))
    (strong-assert (boolean? order?))
    (cond
     (recursive? (pr-read-letrec linker address-env expr order?))
     (order? (raise 'let*-no-longer-builtin))
     (else (pr-read-let linker address-env expr)))))


(define (pr-read-cast linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 8)))
  (let ((need-revision? (list-ref expr 1))
	(always-returns? (list-ref expr 2))
	(never-returns? (list-ref expr 3))
	(type-expr (list-ref expr 4))
	(pure? (list-ref expr 5))
	(value-expr (list-ref expr 6))
	(default-expr (list-ref expr 7)))
    (let ((type-repr
	   (theme-read-body-expr-fwd linker address-env type-expr))
	  (value-repr
	   (theme-read-body-expr-fwd linker address-env value-expr))
	  (default-repr
	    (theme-read-body-expr-fwd linker address-env default-expr))
	  (binder (get-binder-for-parsing linker)))
;;      (strong-assert (not (entity-is-none1? binder type-repr)))
      (strong-assert (not (entity-type-is-none1? binder value-repr)))
      (make-hrecord
       <cast-expression>
       type-repr
       #t
       (and
	(is-known-object? type-repr)
	(is-final-class? (get-binder-for-parsing linker) type-repr))
       '()
       pure?
       #f
       need-revision?
       '()
       always-returns?
       never-returns?
       value-repr
       default-repr))))


(define (pr-read-static-cast linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 7)))
  (let ((need-revision? (list-ref expr 1))
	(always-returns? (list-ref expr 2))
	(never-returns? (list-ref expr 3))
	(pexpr-type (list-ref expr 4))
	(pure? (list-ref expr 5))
	(pexpr-value (list-ref expr 6)))
    (let ((ent-type
	   (theme-read-body-expr-fwd linker address-env pexpr-type))
	  (ent-value
	   (theme-read-body-expr-fwd linker address-env pexpr-value))
	  (binder (get-binder-for-parsing linker)))
      ;; (strong-assert (not (entity-is-none1? binder ent-type)))
      ;; (strong-assert (not (entity-type-is-none1? binder ent-value)))
      (make-hrecord
       <static-cast-expression>
       ent-type
       #t
       (and (is-known-object? ent-type)
	    (is-final-class? (get-binder-for-parsing linker) ent-type))
       '()
       pure?
       #f
       need-revision?
       '()
       always-returns?
       never-returns?
       ent-value))))


(define (pr-read-match-type-clause linker address-env lst-repr-clause)
  (strong-assert (and (list? lst-repr-clause) (= (length lst-repr-clause) 4)))
  (let* ((var
	  (if (not-null? (car lst-repr-clause))
	      (pr-parse-normal-variable linker address-env
					(car lst-repr-clause))
	      '()))
	 (expr-type (theme-read-body-expr-fwd linker address-env
					      (cadr lst-repr-clause)))
	 (local-env
	  (if (not-null? var)
	      (construct-local-address-env address-env (list var))
	      address-env))
	 (expr-to-eval (theme-read-body-expr-fwd linker local-env
						 (caddr lst-repr-clause)))
	 (opt? (list-ref lst-repr-clause 3)))
    (list var expr-type expr-to-eval opt?)))


(define (pr-read-match-type linker address-env pexpr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? pexpr) (= (length pexpr) 13)))
  (let ((need-revision? (list-ref pexpr 1))
	(type-dispatched? (list-ref pexpr 2))
	(strong? (list-ref pexpr 3))
	(always-returns? (list-ref pexpr 4))
	(never-returns? (list-ref pexpr 5))
	(p-type (list-ref pexpr 6))
	(exact-type? (list-ref pexpr 7))
	(pure? (list-ref pexpr 8))
	(pexpr-to-match (list-ref pexpr 9))
	(p-clauses (list-ref pexpr 10))
	(p-else-part (list-ref pexpr 11))
	(opt? (list-ref pexpr 12)))
    (strong-assert (boolean? need-revision?))
    (strong-assert (boolean? type-dispatched?))
    (strong-assert (boolean? strong?))
    (strong-assert (boolean? always-returns?))
    (strong-assert (boolean? never-returns?))
    (strong-assert (boolean? exact-type?))
    (strong-assert (boolean? pure?))
    (strong-assert (boolean? opt?))
    (let ((expr-type (theme-read-body-expr-fwd linker address-env
					       p-type))
	  (expr-to-match (theme-read-body-expr-fwd linker address-env
						   pexpr-to-match))
	  (lst-repr-clauses (map (lambda (lst-repr-clause)
				   (pr-read-match-type-clause
				    linker address-env lst-repr-clause))
				 p-clauses))
	  (expr-else (theme-read-body-expr-fwd linker address-env
					       p-else-part)))
      (make-hrecord <match-type-expression>
		    expr-type
		    type-dispatched?
		    exact-type?
		    '()
		    pure?
		    #f
		    need-revision?
		    '()
		    always-returns?
		    never-returns?
		    strong?
		    expr-to-match
		    lst-repr-clauses
		    expr-else
		    opt?))))


(define (pr-read-if linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr)))
  (let ((len (length expr)))
    (strong-assert (= len 12))
    (let ((need-revision? (list-ref expr 1))
	  (type-dispatched? (list-ref expr 2))
	  (always-returns? (list-ref expr 3))
	  (never-returns? (list-ref expr 4))
	  (type-expr (list-ref expr 5))
	  (exact-type? (list-ref expr 6))
	  (pure? (list-ref expr 7))
	  (condition-expr (list-ref expr 8))
	  (then-expr (list-ref expr 9))
	  (else-expr (list-ref expr 10))
	  (boolean-cond? (list-ref expr 11)))
      (let ((type (theme-read-body-expr-fwd linker address-env type-expr))
	    (t-condition (theme-read-body-expr-fwd linker address-env
						   condition-expr))
	    (t-then (theme-read-body-expr-fwd linker address-env then-expr))
	    (t-else (theme-read-body-expr-fwd linker address-env else-expr)))
	(make-hrecord
	 <if-form>
	 type
	 type-dispatched?
	 (is-final-class? (get-binder-for-parsing linker) type)
	 '()
	 pure?
	 #f
	 need-revision?
	 '()
	 always-returns?
	 never-returns?
	 t-condition
	 t-then
	 t-else
	 boolean-cond?)))))


(define (pr-read-compound linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 9)))
  (let ((need-revision? (list-ref expr 1))
	(type-dispatched? (list-ref expr 2))
	(always-returns? (list-ref expr 3))
	(never-returns? (list-ref expr 4))
	(type-expr (list-ref expr 5))
	(exact-type? (list-ref expr 6))
	(pure? (list-ref expr 7))
	(subexprs (list-ref expr 8)))
    (let ((type (theme-read-body-expr-fwd linker address-env type-expr))
	  (t-subexprs
	   (map (lambda (subexpr)
		  (theme-read-body-expr-fwd linker address-env subexpr))
		subexprs)))
      (make-hrecord
       <compound-expression>
       type
       type-dispatched?
       #t
       '()
       pure?
       #f
       need-revision?
       '()
       always-returns?
       never-returns?
       t-subexprs))))


(define (pr-read-until linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 11)))
  (let ((need-revision? (list-ref expr 1))
	(type-dispatched? (list-ref expr 2))
	(always-returns? (list-ref expr 3))
	(never-returns? (list-ref expr 4))
	(type-expr (list-ref expr 5))
	(exact-type? (list-ref expr 6))
	(pure? (list-ref expr 7))
	(condition-expr (list-ref expr 8))
	(result-expr (list-ref expr 9))
	(body-expr (list-ref expr 10)))
    (let ((type (theme-read-body-expr-fwd linker address-env type-expr))
	  (t-condition (theme-read-body-expr-fwd linker address-env
						 condition-expr))
	  (t-result
	   (theme-read-body-expr-fwd linker address-env result-expr))
	  (t-body
	   (theme-read-body-expr-fwd linker address-env body-expr)))
      (make-hrecord
       <until-form>
       type
       type-dispatched?
       exact-type?
       '()
       pure?
       #f
       need-revision?
       '()
       always-returns?
       never-returns?
       t-condition
       t-result
       t-body))))


(define (pr-read-fw-constant-decl linker address-env var to-type)
  (let* ((address (hfield-ref var 'address))
	 (to-old (address-env-get-item address-env address))
	 (binder (get-binder-for-parsing linker)))
    (strong-assert (is-t-instance? binder to-type tc-class))
    (strong-assert (or (boolean? to-old) (is-target-object? to-old)))
    (if (eq? to-old #f)
	(let ((to (make-target-object
		   to-type
		   #t
		   (not (tno-field-ref to-type 'inheritable?))
		   address
		   #f
		   #t
		   #f
		   '())))
	  (address-env-add-binding! address-env to)
	  (address-hash-set! (hfield-ref linker 'ht-decl-types) address to-type)
	  (make-hrecord
	   <forward-declaration>
	   tt-none
	   #t
	   #t
	   '()
	   #f
	   #f
	   #f
	   '()
	   var
	   to-type
	   #f
	   #f))
	(let ((to-old-type (address-hash-ref (hfield-ref linker 'ht-decl-types)
					     address))
	      (binder (get-binder-for-parsing linker)))
	  (cond
	   ((null? to-old-type)
	    (raise 'internal-error-with-decl-types))
	   ((not (is-t-instance? binder to-old-type tc-class))
	    (raise 'decl-type-not-a-class))
	   ((not (hfield-ref to-old 'incomplete?))
	    (raise 'cannot-declare-existing-variable-3))
	   ((not (is-t-subtype? binder to-type to-old-type))
	    (raise 'redecl-type-mismatch-1))
	   ((not (= (length (tno-field-ref to-type 'l-all-fields))
		    (length (tno-field-ref to-old-type 'l-all-fields))))
	    (raise 'decl-invalid-subtype))
	   (else
	    (let ((to (make-target-object
		       to-type
		       #t
		       (not (tno-field-ref to-type 'inheritable?))
		       address
		       #f
		       #t
		       #f
		       '())))
	      (set-object1! to-old to)
	      (make-hrecord
	       <forward-declaration>
	       tt-none
	       #t
	       #t
	       '()
	       #f
	       #f
	       #f
	       '()
	       var
	       to-type
	       #t
	       #f))))))))


;; This procedure works for volatile declarations, too.
(define (pr-read-fw-mutable-decl linker address-env var to-type)
  (dwl4 "pr-read-fw-mutable-decl")
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (let* ((address (hfield-ref var 'address))
	 (name (hfield-ref address 'source-name))
	 (old-var (address-env-get-item address-env address))
	 (binder (get-binder-for-parsing linker)))
    (if (not (is-t-instance? binder to-type tt-type))
	(raise 'decl-type-not-a-type))
    (if (eq? old-var #f)
	(begin
	  (address-env-add-binding! address-env var)
	  (address-hash-set! (hfield-ref linker 'ht-decl-types) address to-type)
	  (make-hrecord
	   <forward-declaration>
	   tt-none
	   #t
	   #t
	   '()
	   #f
	   #f
	   #f
	   '()
	   var
	   to-type
	   #f
	   #f))
	(let ((to-old-type (address-hash-ref (hfield-ref linker 'ht-decl-types)
					     address)))
	  (cond
	   ((null? to-old-type)
	    (raise 'internal-error-with-decl-types))
;;	   ((not (is-t-instance? binder to-old-type tc-class))
;;	    (raise 'decl-type-not-a-class))
	   ((not (is-forward-decl? old-var))
	    (raise 'cannot-declare-existing-variable-3))
	   ((not (equal-types? binder to-type to-old-type))
	    (raise 'redecl-type-mismatch-2))
	   ;; ((not (= (length (tno-field-ref to-type 'l-all-fields))
	   ;; 	    (length (tno-field-ref to-old-type 'l-all-fields))))
	   ;;  (raise 'decl-invalid-subtype))
	   (else
	    (hfield-set! old-var 'type to-type)
	    (make-hrecord
	     <forward-declaration>
	     tt-none
	     #t
	     #t
	     '()
	     #f
	     #f
	     #f
	     '()
	     var
	     to-type
	     #t
	     #f)))))))


(define (pr-read-fw-decl linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 3)))
  (let* ((var (pr-parse-normal-variable linker address-env (cadr expr)))
	 (r-type (theme-read-body-expr-fwd linker address-env
					   (caddr expr))))
    (if (hfield-ref var 'read-only?)
	(pr-read-fw-constant-decl linker address-env var r-type)
	(pr-read-fw-mutable-decl linker address-env var r-type))))

	 
(define (pr-read-force-pure-expr linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)
		      (eq? (car expr) 'force-pure-expr)))
  (translate-force-pure-expr
   (theme-read-body-expr-fwd linker address-env (cadr expr))))


(define (pr-read-prevent-stripping linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)))
  (let* ((p-address (cadr expr))
	 (address (pr-parse-address linker p-address)))
    (make-prevent-stripping-expr address)))


(define (pr-read-assertion linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 4)))
  (let ((strong? (list-ref expr 1))
	(s-condition (list-ref expr 2))
	(condition-source (list-ref expr 3)))
    (let ((r-condition
	   (theme-read-body-expr-fwd linker address-env
				     s-condition)))
      ;; An assertion is a pure expression even though it may not return.
      (make-hrecord <assertion-expr>
		    tt-none
		    #t
		    #t
		    '()
		    #t
		    #f
		    #f
		    '()
		    #f
		    #f
		    r-condition
		    condition-source
		    strong?))))


(define (pr-read-empty expr)
  (strong-assert (= (length expr) 1))
  empty-expression)


(define (theme-read-body-expr linker address-env expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (list? expr))
  (let ((prev-expr (hfield-ref linker 'current-expr))
	(old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (hfield-set! linker 'current-expr expr)
    (let ((result
	   (case (car expr)
	     ((general-variable)
	      (pr-parse-general-variable linker address-env expr))
	     ((object-ref)
	      (pr-parse-object-ref linker address-env expr))
	     ((tvar)
	      (pr-parse-tvar linker address-env expr))
	     ((cycle)
	      (pr-parse-cycle linker address-env expr))
	     ((gen-proc) (pr-read-gen-proc linker address-env expr))
	     ((method) (pr-read-method-def linker address-env expr))
	     ((declare-method) (pr-read-method-decl linker address-env expr))
	     ;; Reexports have no effect in the linker.
	     ((reexport) empty-expression)
	     ;; Macros have no effect in the linker.
	     ((define-syntax) empty-expression)
	     ((set!) (pr-read-set-expr linker address-env expr))
	     ((var-ref) (pr-read-var-ref linker address-env expr))
	     ;; Do we need the following?
	     ((var-forward-ref)
	      (pr-read-var-forward-ref linker address-env expr))
	     ((prim-proc-ref) (pr-read-prim-proc-ref linker address-env expr))
	     ((checked-prim-proc)
	      (pr-read-checked-prim-proc linker address-env expr))
	     ((prim-class-def)
	      (pr-read-prim-class-def linker address-env expr))
	     ((param-class-instance)
	      (pr-read-param-class-instance linker address-env expr))
;;	     ((param-logical-type-instance)
;;	      (pr-read-param-logical-type-instance linker address-env expr))
	     ((param-proc-instance)
	      (pr-read-param-proc-instance linker address-env expr))
	     ((param-proc-dispatch)
	      (pr-read-param-proc-dispatch linker address-env expr))
	     ((generic-proc-dispatch)
	      (pr-read-generic-proc-dispatch linker address-env expr))
	     ((constructor) (pr-read-constructor linker address-env expr))
	     ((zero) (pr-read-zero linker address-env expr))
	     ((set-zero) (pr-read-zero-setting linker address-env expr))
	     ((field-ref) (pr-read-field-ref linker address-env expr))
	     ((field-set!) (pr-read-field-set linker address-env expr))
	     ((primitive-value) (pr-parse-primitive-value linker
							  address-env expr))
	     ((pair) (pr-parse-pair linker address-env expr))
	     ((proc-appl)
	      (pr-read-proc-appl linker address-env expr))
	     ((procedure) (pr-read-proc-expr linker address-env expr))
	     ((param-proc) (pr-read-param-proc linker address-env expr))
	     ((proc-type)
	      (pr-read-proc-type linker address-env expr))
	     ((simple-proc-class)
	      (pr-read-simple-proc-class linker address-env expr))
	     ((param-proc-class)
	      (pr-read-param-proc-class linker address-env expr))
	     ((gen-proc-class)
	      (pr-read-gen-proc-class linker address-env expr))
	     ((apti)
	      (pr-read-apti linker address-env expr))
	     ((rest) (pr-read-rest linker address-env expr))
	     ((splice) (pr-read-splice linker address-env expr))
	     ((type-list) (pr-read-type-list linker address-env expr))
	     ((type-loop) (pr-read-type-loop linker address-env expr))
	     ((type-join) (pr-read-type-join linker address-env expr))
	     ((:union) (pr-read-union linker address-env expr))
	     ((:pair) (pr-read-pair linker address-env expr))
	     ((vector-class)
	      (pr-read-uniform-vector linker address-env expr))
	     ((mutable-vector-class)
	      (pr-read-mutable-uniform-vector linker address-env expr))
	     ((value-vector-class)
	      (pr-read-value-vector linker address-env expr))
	     ((mutable-value-vector-class)
	      (pr-read-mutable-value-vector linker address-env expr))
	     ((let) (pr-read-general-let linker address-env expr))
	     ((cast) (pr-read-cast linker address-env expr))
	     ((static-cast) (pr-read-static-cast linker address-env expr))
	     ((match-type) (pr-read-match-type linker address-env expr))
	     ((if) (pr-read-if linker address-env expr))
	     ((begin) (pr-read-compound linker address-env expr))
	     ((until) (pr-read-until linker address-env expr))
	     ((declare) (pr-read-fw-decl linker address-env expr))
	     ((declare-mutable)
	      (pr-read-fw-decl linker address-env expr))
	     ((declare-volatile)
	      (pr-read-fw-decl linker address-env expr))
	     ((signature)
	      (pr-read-signature linker address-env expr))
	     ((param-signature)
	      (pr-read-param-signature linker address-env expr))
	     ((force-pure-expr)
	      (pr-read-force-pure-expr linker address-env expr))
	     ((prevent-stripping) (pr-read-prevent-stripping
				   linker address-env expr))
	     ((assert) (pr-read-assertion linker address-env expr))
	     ((empty) (pr-read-empty expr))
	     (else
	      (write-error-info expr)
	      (raise 'error-in-pseudocode-elem-type)))))
      (hfield-set! linker 'current-expr prev-expr)
      (set! gl-indent old-indent)
      result)))


(set! theme-read-body-expr-fwd theme-read-body-expr)


(define (theme-read-module-body linker address-env expr-list)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (list? expr-list))
  (map* (lambda (expr)
	  (hfield-set! linker 'current-toplevel-expr expr)
	  (let ((result (theme-read-body-expr linker address-env expr)))
	    (hfield-set! linker 'current-toplevel-expr '())
	    result))
	expr-list))
