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


;; *** Interface pseudocode reading ***


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


(define parse-repr-fwd '())
(define add-method-decl-fwd! '())


(define gl-var1 '())
(define gl-var2 '())


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


(define (get-env-all compiler)
  (assert (hrecord-is-instance? compiler <compiler>))
  (hfield-ref compiler 'env-all))


(define (add-binding s-name address)
  (assert (symbol? s-name))
  (let* ((x-id (ex:source->syntax1 s-name)) 
	 (x-mapping (ex:make-global-mapping2 'variable x-id #f address))
	 (alo-exports (hfield-ref gl-expander 'alo-current-exports)))
    (ex:usage-env-extend! (list x-mapping))
    (hfield-set! alo-exports 'contents
		 (cons x-mapping (hfield-ref alo-exports 'contents)))))

  
;; This procedure does not count forward declarations of methods.
(define (generic-contains-method? address-env r-gen-proc addr-method)
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (hrecord-is-instance? r-gen-proc <target-object>))
  (assert (hrecord-is-instance? addr-method <address>))
  (let ((methods (tno-field-ref r-gen-proc 'l-methods)))
    (assert (and-map? is-target-object? methods))
    (if (not (eq? (find (lambda (mt)
			  (and (not (hfield-ref mt 'incomplete?))
			       (address=? (hfield-ref mt 'address)
					  addr-method)))
			methods)
		  #f))
	#t
	#f)))


(define (parse-internal-variable compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 8)
		      (eq? (car expr) 'internal-variable)))
  (let ((p-address (list-ref expr 1))
	(p-type (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))
	(forward-decl? (list-ref expr 7)))
    (let* ((module (get-current-module-name compiler))
	   (r-address (parse-address module p-address))
	   (r-type (parse-repr-fwd compiler address-env p-type))
	   (var
	    (make-normal-variable10 r-address r-type type-dispatched?
				    exact-type? read-only? volatile?
				    forward-decl?
				    '() #f)))
      var)))


(define (interface-parse-type-var-values compiler address-env p-values)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (map (lambda (p-value) (parse-repr-fwd compiler address-env p-value))
       p-values))


(define (do-parse-param-class-instance compiler r-param-type r-params)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (is-target-object? r-param-type))
  (assert (and (list? r-params) (and-map? is-target-object? r-params)))
  (translate-param-class-instance-expr (compiler-get-binder compiler)
				       r-param-type
				       r-params
				       #f
				       #t))


(define (do-parse-param-type-instance compiler address-env decl expr-class)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? decl) (= (length decl) 3)))
  (let ((p-param-type (list-ref decl 1))
	(p-params (list-ref decl 2)))
    (let* ((module (get-current-module-name compiler))
	   (r-param-type0 (parse-repr-fwd compiler address-env p-param-type))
	   (r-param-type-address (hfield-ref r-param-type0 'address))
	   (r-params (interface-parse-type-var-values compiler address-env
						      p-params))
	   (r-param-type (address-env-get-item address-env
					       r-param-type-address)))
      (if (not (eqv? r-param-type #f))      
	  (let ((result
		 (if (eqv? expr-class t-param-class)
		     (do-parse-param-class-instance compiler r-param-type
						    r-params)
		     (raise 'unsupported-type))))
	    result)
	  (begin
	    (dvar1-set! module)
	    (dvar2-set! address-env)
	    (dvar3-set! decl)
	    (raise 'undefined-param-type))))))


(define (do-parse-var-ref compiler address-env address)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (hrecord-is-instance? address <address>))
  (let ((gv (search-global compiler address)))
    (if (not (eq? gv #f))
	(begin
	  (strong-assert (hrecord-is-instance? gv <normal-variable>))
	  (make-hrecord
	   <variable-reference>
	   (get-entity-type gv)
	   #t
	   (hfield-ref gv 'exact-type?)
	   address
	   #t
	   #f
	   #f
	   (get-entity-value gv)
	   gv))
	(let ((var (address-env-get-item address-env address)))
	  (assert (or (eq? var #f)
		      (hrecord-is-instance? var <variable>)))
	  (if (not (eqv? var #f))
	      ;; Set need-revision? = #f
	      (cond
	       ((hrecord-is-instance? var <normal-variable>)
		(make-hrecord
		 <variable-reference>
		 (get-entity-type var)
		 #t
		 (hfield-ref var 'exact-type?)
		 #t
		 #f
		 #f
		 (hfield-ref var 'value)
		 var))
	       ((is-t-type-variable? var)
		(raise 'var-ref-internal-error))
	       ;; (make-hrecord
	       ;;  <variable-reference>
	       ;;  te-type
	       ;;  #t
	       ;;  #f
	       ;;  #t
	       ;;  #f
	       ;;  #f
	       ;;  (hfield-ref var 'value)
	       ;;  var))
	       (else (raise 'internal-error)))
	      (begin
		(dvar1-set! address-env)
		(dvar2-set! address)
		(dwl4 (hfield-ref address 'module))
		(dwl4 (hfield-ref address 'number))
		(dwl4 (hfield-ref address 'source-name))
		(dwl4 (hfield-ref address 'toplevel?))
		(raise 'reference-to-undefined-variable)))))))


(define (parse-var-ref compiler address-env decl)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? decl) (= (length decl) 2)))
  (let* ((module (get-current-module-name compiler))
	 (address (parse-address module (list-ref decl 1))))
    (do-parse-var-ref compiler address-env address)))


(define (parse-object-ref compiler address-env pexpr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? pexpr) (= (length pexpr) 2)))
  (let* ((module (get-current-module-name compiler))
	 (address (parse-address module (list-ref pexpr 1)))
	 ;;	 (to (search-global compiler address)))
	 ;;	 (env-all (hfield-ref compiler 'env-all))
	 (to (address-env-get-item address-env address)))
    (if (is-target-object? to)
	to
	(begin
	  (dvar1-set! to)
	  (dvar2-set! pexpr)
	  (raise 'invalid-object-ref)))))


(define (parse-tvar compiler address-env pexpr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? pexpr) (= (length pexpr) 2)))
  (let* ((module (get-current-module-name compiler))
	 (address (parse-address module (list-ref pexpr 1)))
	 (ht (hfield-ref compiler 'ht-type-variables))
	 (tvar (address-hash-ref ht address)))
    (if tvar
	tvar
	(let ((tvar-new (make-type-variable address)))
	  (address-hash-set! ht address tvar-new)
	  tvar-new))))


(define (parse-primitive-value compiler address-env decl)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? decl) (= (length decl) 2)))
  (let* ((contents (cadr decl))
	 (type (get-primitive-type contents))
	 (prim-expr (make-primitive-object type contents)))
    prim-expr))


(define (parse-pair compiler address-env decl)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? decl) (= (length decl) 3)))
  (let* ((obj-first (parse-repr-fwd compiler address-env (cadr decl)))
	 (obj-second (parse-repr-fwd compiler 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?)))
	 (to
	  (make-target-object
	   type
	   #t exact-type? '()
	   #f #f
	   `((first . ,obj-first)
	     (second . ,obj-second))
	   '())))
    to))


(define (parse-object-field compiler address-env p-field)
  (let ((name (car p-field))
	(p-value (cdr p-field)))
    (let ((value (parse-repr-fwd compiler address-env p-value)))
      (cons name value))))


(define (parse-object-fields compiler address-env p-fields)
  (map* (lambda (p-field) (parse-object-field compiler address-env p-field))
	p-fields))


(define (parse-var-def compiler parse-variable! def address read-only?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (procedure? parse-variable!))
  (strong-assert (and (list? def) (= (length def) 5)
		      (eq? (car def) 'define-variable)))
  (assert (is-address? address))
  (let* ((p-type (cadr def))
	 (env-all (hfield-ref compiler 'env-all))
	 (r-type (parse-repr-fwd compiler env-all p-type))
	 (interface-read-expr? (list-ref def 2)))
    (if (and read-only? interface-read-expr?)
	(let* ((p-value-expr (list-ref def 3))
	       (r-value-expr
		(parse-repr-fwd compiler env-all p-value-expr))
	       (to-value
		(if (is-target-object? r-value-expr)
		    (if (null? (hfield-ref r-value-expr 'address))
			(make-object-with-address r-value-expr address)
			r-value-expr)
		    '())))
	  (parse-variable! to-value r-value-expr r-type))
	(parse-variable! '() '() r-type))))


(define (parse-field compiler address-env field)
  (assert (hrecord-is-instance? compiler <compiler>))
  (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?
	      (parse-repr-fwd compiler address-env
			      (list-ref field 5))
	      '()))
	 (type (parse-repr-fwd compiler address-env p-type)))
    (if (entity-is-none1? (compiler-get-binder compiler) type)
	(raise 'field-type-none)
	(make-field name type read-access write-access has-init-value?
		    r-init-value))))


(define (parse-field-list compiler address-env field-list)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (list? field-list))
  (map (lambda (field) (parse-field compiler address-env field))
       field-list))


(define (parse-class-decl compiler parse-variable! decl address)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (procedure? parse-variable!))
  (strong-assert (and (list? decl) (= (length decl) 8)
		      (eq? (car decl) 'define-class)))
  (let* ((name (list-ref decl 1))
	 (p-superclass (list-ref decl 2))
	 (p-fields (list-ref decl 3))
	 (inheritable? (list-ref decl 4))
	 (immutable? (list-ref decl 5))
	 (eq-by-value? (list-ref decl 6))
	 (ctr-access (list-ref decl 7)))
    (let* ((env-all (hfield-ref compiler 'env-all))
	   (t-superclass (parse-repr-fwd compiler env-all p-superclass)))
      (if (entity-is-none1? (compiler-get-binder compiler) t-superclass)
	  (raise 'none-as-superclass)
	  (let* ((t-fields (parse-field-list compiler env-all p-fields))
		 (module (get-current-module-name compiler))
		 (to
		  (make-target-class
		   address module
		   t-superclass t-fields
		   inheritable? immutable? eq-by-value?
		   ctr-access))
		 (to-decl (parse-variable! to '() tc-class))
		 (binder (compiler-get-binder compiler)))
	    (make-constructor! binder to-decl)
	    to)))))


(define (parse-param-class-decl compiler parse-variable! decl address)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (procedure? parse-variable!))
  (strong-assert (and (list? decl) (= (length decl) 3)
		      (eq? (car decl) 'define-param-class)))
  (let* ((module (get-current-module-name compiler))
	 (r-type-variables
	  (parse-type-variables module (list-ref decl 1)))
	 (class-decl (list-ref decl 2))
	 (env-all (hfield-ref compiler 'env-all))
	 (local-env (construct-local-address-env
		     env-all r-type-variables)))
    (if (= (length class-decl) 8)
	(let ((name (list-ref class-decl 1))
	      (r-superclass (parse-repr-fwd compiler local-env
					    (list-ref class-decl 2)))
	      (r-inst-fields (parse-field-list compiler local-env
					       (list-ref class-decl 3)))
	      (inh? (list-ref class-decl 4))
	      (imm? (list-ref class-decl 5))
	      (ebv? (list-ref class-decl 6))
	      (ctr-access (list-ref class-decl 7)))
	  (dvar1-set! decl)
	  ;; Maybe r-inst-fields should be checked, too.
	  (strong-assert (string? name))
	  (strong-assert (is-entity? r-superclass))
	  (strong-assert (boolean? inh?))
	  (strong-assert (boolean? imm?))
	  (strong-assert (boolean? ebv?))
	  (strong-assert (memq ctr-access gl-access-specifiers))
	  (let ((to
		 (make-object-with-address
		  (make-parametrized-class-object
		   (compiler-get-binder compiler)
		   module
		   name
		   address
		   r-type-variables
		   r-superclass
		   r-inst-fields
		   inh?
		   imm?
		   ebv?
		   ctr-access)
		  address)))
	    (parse-variable! to '() t-param-class)
	    to))
	(raise 'internal-syntax-error-in-param-class))))


(define (parse-param-class-instance compiler address-env decl)
  (do-parse-param-type-instance compiler address-env decl
				t-param-class))


(define (parse-param-ltype-decl compiler parse-variable! decl address)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (procedure? parse-variable!))
  (strong-assert (and (list? decl) (= (length decl) 4)
		      (eq? (car decl) 'define-param-logical-type)))
  (let ((name (list-ref decl 1))
	(p-type-vars (list-ref decl 2))
	(p-value-expr (list-ref decl 3))
	(module (get-current-module-name compiler)))
    (let* ((r-type-vars
	    (parse-type-variables module p-type-vars))
	   (env-all (hfield-ref compiler 'env-all))
	   (local-env (construct-local-address-env env-all r-type-vars))
	   (r-value-expr (parse-repr-fwd compiler local-env p-value-expr))
	   (to (make-param-logical-type-object name address
					       r-type-vars r-value-expr)))
      (parse-variable! to '() t-param-logical-type)
      to)))



(define (parse-param-proc-class compiler address-env decl)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? decl)
		      (= (length decl) 3)
		      (eq? (car decl) 'param-proc-class)))
  (let ((p-type-vars (list-ref decl 1))
	(p-inst-type (list-ref decl 2)))
    (let* ((module (get-current-module-name compiler))
	   (r-type-vars (parse-type-variables module p-type-vars))
	   (local-env (construct-local-address-env address-env r-type-vars))
	   (r-inst-type (parse-repr-fwd compiler local-env p-inst-type))
	   (to-ppc (make-param-proc-class-object "instance of :param-proc"
						 r-type-vars r-inst-type)))
      to-ppc)))


(define (parse-general-proc-type compiler address-env expr simple?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 7)))
  (assert (boolean? simple?))
  (let ((arg-list-type
	 (parse-repr-fwd compiler address-env (list-ref expr 1)))
	(result-type
	 (parse-repr-fwd compiler address-env (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 ((result
	   (translate-general-proc-type-expression0
	    simple?
	    arg-list-type
	    result-type
	    pure-proc?
	    appl-always-returns?
	    appl-never-returns?
	    static-method?)))
      result)))


(define (parse-proc-type compiler address-env expr)
  (parse-general-proc-type compiler address-env expr #f))


(define (parse-simple-proc-class compiler address-env expr)
  (parse-general-proc-type compiler address-env expr #t))


(define (parse-gen-proc-class compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (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)
		  (parse-repr-fwd compiler address-env pexpr))
		p-method-classes)))
    (make-gen-proc-class-object r-method-classes)))


(define (parse-pair-class compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (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)
			 (parse-repr-fwd compiler address-env pexpr))
		       p-args))
	 (binder (compiler-get-binder compiler)))
    (translate-pair-class-expression binder r-args)))


;; All fields in the pseudocode are not used.
(define (parse-union compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (list? expr))
  (if (not (= (length expr) 2))
      (raise 'pcode-corrupted-union))
  (let* ((p-args (list-ref expr 1))
	 (r-args (map* (lambda (pexpr)
			 (parse-repr-fwd compiler address-env pexpr))
		       p-args))
	 (binder (compiler-get-binder compiler)))
    (get-union-of-types binder r-args)))


(define (parse-vector compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (list? expr))
  (if (not (= (length expr) 2))
      (raise 'internal-invalid-vector))
  (let* ((member-type-expr (list-ref expr 1)) 
	 (member-type-repr
	  (parse-repr-fwd compiler address-env member-type-expr)))
    (let ((result
	   (translate-vector-expression0 member-type-repr)))
      result)))


(define (parse-mutable-vector compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (list? expr))
  (if (not (= (length expr) 2))
      (raise 'internal-invalid-mutable-uniform-vector))
  (let* ((member-type-expr (list-ref expr 1)) 
	 (member-type-repr
	  (parse-repr-fwd compiler address-env member-type-expr)))
    (translate-mutable-vector-expression0 member-type-repr)))


(define (parse-value-vector compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (list? expr))
  (if (not (= (length expr) 2))
      (raise 'internal-invalid-value-vector))
  (let* ((member-type-expr (list-ref expr 1))
	 (member-type-repr
	  (parse-repr-fwd compiler address-env member-type-expr)))
    (translate-value-vector-expression0 member-type-repr)))


(define (parse-mutable-value-vector compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (strong-assert (list? expr))
  (if (not (= (length expr) 2))
      (raise 'internal-invalid-mutable-value-vector))
  (let* ((member-type-expr (list-ref expr 1))
	 (member-type-repr
	  (parse-repr-fwd compiler address-env member-type-expr)))
    (translate-mutable-value-vector-expression0 member-type-repr)))


(define (parse-abstract-param-type-inst compiler address-env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (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 (parse-repr-fwd compiler address-env p-param-type))
	 (r-args (map* (lambda (p1) (parse-repr-fwd compiler address-env p1))
		       p-args)))
    (make-apti r-param-type r-args)))


(define (parse-zero-setting compiler env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 4)
		      (eq? (car expr) 'set-zero)))
  (let* ((param? (list-ref expr 3))
	 (p-addr-cl (cadr expr))
	 (module (get-current-module-name compiler))
	 (r-addr-cl (parse-address module p-addr-cl))
	 (cl (address-env-get-item env r-addr-cl)))
    (strong-assert (boolean? param?))
    (if (eq? cl #f)
	(raise 'interface-invalid-zero-setting)
	(if param?
	    (tno-field-set! cl 'instance-has-zero? #t)
	    (tno-field-set! cl 'has-zero? #t)))
    empty-expression))


(define (intf-parse-signature-members compiler env p-members)
  (map* (lambda (p-member)
	  (cons (parse-repr-fwd compiler
				env
				(car p-member))
		(parse-repr-fwd compiler
				env
				(cadr p-member))))
	p-members))


(define (parse-signature compiler address-env pexpr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (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 (intf-parse-signature-members compiler address-env
						  p-members))
	 (to (make-signature-object '() r-members)))
    to))


(define (parse-param-signature compiler address-env pexpr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (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))
	 (module (get-current-module-name compiler))
	 (r-type-vars (parse-type-variables module p-type-vars))
	 (local-env (construct-local-address-env address-env r-type-vars))
	 (p-members (caddr pexpr))
	 (r-members (intf-parse-signature-members compiler local-env
						  p-members))
	 (to (make-param-sgn-object '() r-type-vars r-members)))
    to))


(define (parse-force-pure-expr compiler env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <address-environment>))
  (strong-assert (and (list? expr) (= (length expr) 2)
		      (eq? (car expr) 'force-pure-expr)))
  (translate-force-pure-expr
   (parse-repr-fwd compiler env (cadr expr))))


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


(define (parse-cycle compiler env pexpr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (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 (parse-repr-fwd compiler env p-type))
	 (module (get-current-module-name compiler))
	 (address (parse-address module p-address))
	 (obj (make-incomplete-object
	       r-type
	       (is-final-class? (hfield-ref compiler 'binder) r-type)))
	 (local-env (construct-local-address-env2 env
						  (list (cons address obj))))
	 (r-contents (parse-repr-fwd compiler local-env p-contents)))
    (assert (is-target-object? r-contents))
    (set-object1! obj r-contents)
    obj))


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


(define (parse-type-list compiler env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? 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)
		 (parse-repr-fwd compiler env component))
	       p-component-types)))
    (make-type-list-object r-component-types)))


(define (parse-type-loop compiler env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? 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 (get-current-module-name compiler))
	   (r-iter-var-address
	    (parse-address module p-iter-var-address))
	   (iter-var (make-type-variable r-iter-var-address))
	   (r-subtype-list (parse-repr-fwd compiler env p-subtype-list))
	   (env-all (hfield-ref compiler 'env-all))
	   (local-env (construct-local-address-env env-all (list iter-var)))
	   (r-iter-expr (parse-repr-fwd compiler local-env p-iter-expr)))
      (make-type-loop-object iter-var r-subtype-list r-iter-expr))))


(define (parse-type-join compiler env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? 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 (p-type)
		  (parse-repr-fwd compiler env p-type))
		p-subtypes)))
    (make-type-join-object r-subtypes)))


(define (parse-repr compiler address-env decl)
  (assert (hrecord-is-instance? address-env <address-environment>))
  (let ((result
	 (case (car decl)
	   ((var-ref)
	    (parse-var-ref compiler address-env decl))
	   ((object-ref)
	    (parse-object-ref compiler address-env decl))
	   ((tvar)
	    (parse-tvar compiler address-env decl))
	   ((primitive-value)
	    (parse-primitive-value compiler address-env decl))
	   ((pair)
	    (parse-pair compiler address-env decl))
	   ((param-class-instance)
	    (parse-param-class-instance compiler address-env decl))
	   ;;	   ((param-logical-type-instance)
	   ;;	    (parse-param-ltype-instance compiler address-env decl))
	   ((apti)
	    (parse-abstract-param-type-inst compiler address-env decl))
	   ((param-proc-class)
	    (parse-param-proc-class compiler address-env decl))
	   ((proc-type)
	    (parse-proc-type compiler address-env decl))
	   ((simple-proc-class)
	    (parse-simple-proc-class compiler address-env decl))
	   ((gen-proc-class)
	    (parse-gen-proc-class compiler address-env decl))
	   ((:pair)
	    (parse-pair-class compiler address-env decl))
	   ;;	   ((uniform-list)
	   ;;	    (parse-uniform-list compiler address-env decl))
	   ((:union)
	    (parse-union compiler address-env decl))
	   ((vector-class)
	    (parse-vector compiler address-env decl))
	   ((mutable-vector-class)
	    (parse-mutable-vector compiler address-env decl))
	   ((value-vector-class)
	    (parse-value-vector compiler address-env decl))
	   ((mutable-value-vector-class)
	    (parse-mutable-value-vector compiler address-env decl))
	   ((set-zero)
	    (parse-zero-setting compiler address-env decl))
	   ((signature)
	    (parse-signature compiler address-env decl))
	   ((param-signature)
	    (parse-param-signature compiler address-env decl))
	   ((cycle)
	    (parse-cycle compiler address-env decl))
	   ((force-pure-expr)
	    (parse-force-pure-expr compiler address-env decl))
	   ((rest)
	    (parse-rest compiler address-env decl))
	   ((splice)
	    (parse-splice compiler address-env decl))
	   ((type-list)
	    (parse-type-list compiler address-env decl))
	   ((type-loop)
	    (parse-type-loop compiler address-env decl))
	   ((type-join)
	    (parse-type-join compiler address-env decl))
	   (else
	    (raise 'unknown-interface-element-2)))))
    (assert (is-entity? result))
    result))


(set! parse-repr-fwd parse-repr)


(define (interface-bind-variable! compiler toplevel? reimport? name
				  forward-decl?
				  declared? address type
				  exact-type? read-only? volatile?
				  toplevel-bindings?
				  value value-expr)
  (cond
   ((null? name)
    (let* ((ent
	    (if (and read-only? (not-null? value))
		value
		(make-normal-variable7
		 address
		 type
		 exact-type?
		 read-only?
		 volatile?
		 forward-decl?
		 value
		 value-expr
		 #f)))
	   (env-all (hfield-ref compiler 'env-all)))
      (if (and (not reimport?) (not declared?))
	  (address-env-add-binding2! env-all address ent))
      ent))
   (reimport?
    (let* ((env-all (hfield-ref compiler 'env-all))
	   (env (hfield-ref compiler 'env))
	   (new-ent (address-env-get-item env-all address))
	   (old-ent (get-symbol env name))
	   (old-address (if (not (eq? old-ent #f))
			    (hfield-ref old-ent 'address)
			    #f)))
      (cond
       ((eq? new-ent #f)
	(raise 'reimported-variable-not-found))
       ((eq? old-ent #f)
	(if (and toplevel? toplevel-bindings?)
	    (add-symbol! env name new-ent))
	new-ent)
       (else new-ent))))
   (declared?
    (let* ((env-all (hfield-ref compiler 'env-all))
	   (env (hfield-ref compiler 'env))
	   (old-ent (address-env-get-item env-all address))
	   (old-ent2 (if toplevel? (get-symbol env name) #f)))
      (if (eq? old-ent #f)
	  (raise 'internal-error-with-forward-declaration1))
      (if (and (not (eq? old-ent2 #f)) (not (eqv? old-ent2 old-ent)))
	  (raise 'internal-error-with-forward-declaration2))
      (cond
       ((is-normal-variable? old-ent)
	(let ((var
	       (make-normal-variable7
		address
		type
		exact-type?
		read-only?
		volatile?
		forward-decl?
		value
		value-expr
		#f)))
	  (rebind-variable! old-ent var)
	  (if (and toplevel? toplevel-bindings? (eq? old-ent2 #f))
	      (begin
		(add-symbol! env name var)))
	  old-ent))
       ((is-target-object? old-ent)
	(assert (is-target-object? value))
	(set-object1! old-ent value)
	(if (and toplevel? toplevel-bindings? (eq? old-ent2 #f))
	    (begin
	      ;; Should we use old-ent instead of value?
	      (add-symbol! env name value)))
	old-ent)
       (else (raise 'internal-error)))))
   (else
    (let* ((ent
	    (if (and read-only? (not-null? value))
		(begin
		  value)
		(begin
		  (make-normal-variable7
		   address
		   type
		   exact-type?
		   read-only?
		   volatile?
		   forward-decl?
		   value
		   value-expr
		   #f))))
	   (env (hfield-ref compiler 'env))
	   (env-all (hfield-ref compiler 'env-all)))
      (address-env-add-binding2! env-all address ent)
      (if (and toplevel? toplevel-bindings?)
	  (begin
	    (if (symbol-exists? env name)
		(raise 'duplicate-definition-1)
		(add-symbol! env name ent))))
      ent))))


(define (interface-parse-variable! compiler toplevel? reimport?
				   value value-expr
				   type sym
				   forward-decl?
				   declared?
				   parsed-address exact-type?
				   read-only? volatile?
				   toplevel-bindings?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (boolean? toplevel?))
  (assert (boolean? reimport?))
  (assert (or (null? value) (is-target-object? value)))
  (assert (or (null? value-expr) (is-entity? value-expr)))
  (assert (is-target-object? type))
  (assert (or (symbol? sym) (null? sym)))
  (assert (boolean? forward-decl?))
  (assert (boolean? declared?))
  (assert (hrecord-is-instance? parsed-address <address>))
  (assert (boolean? exact-type?))
  (assert (boolean? read-only?))
  (interface-bind-variable! compiler toplevel? reimport?
			    sym forward-decl?
			    declared? parsed-address type
			    exact-type? read-only? volatile?
			    toplevel-bindings?
			    value value-expr))


(define (import-general-variable compiler def toplevel? reimport? export?
				 toplevel-bindings?)
  (let* ((sym (list-ref def 1))
	 (forward-decl? (list-ref def 2))
	 (declared? (list-ref def 3))
	 (p-address (list-ref def 4))
	 (exact-type? (list-ref def 5))
	 (read-only? (list-ref def 6))
	 (volatile? (list-ref def 7))
	 (contents (list-ref def 8))
	 (content-type (car contents)))
    (hfield-set! compiler 'variable-to-import sym)
    (strong-assert (or (symbol? sym) (null? sym)))
    (strong-assert (boolean? forward-decl?))
    (strong-assert (boolean? declared?))
    (strong-assert (list? p-address))
    (strong-assert (boolean? exact-type?))
    (strong-assert (boolean? read-only?))
    (strong-assert (boolean? volatile?))
    (strong-assert (list? contents))
    (strong-assert (symbol? content-type))
    (let* ((module-name (hfield-ref compiler 'module-name))
	   (env-all (hfield-ref compiler 'env-all))
	   (address (parse-address module-name p-address))
	   (var (address-env-get-item env-all address)))
      (cond
       ((and (not reimport?)
	     (not (eq? var #f))
	     (not (is-forward-decl-entity? var)))
	(hfield-set! compiler 'variable-to-import '())
	'())
       ;; The following check is probably unnecessary.
       ((not (pair? contents))
	(raise 'compiled-module-empty-declaration))
       (else
	(let ((parse-variable!
	       (lambda (value value-expr type)
		 (interface-parse-variable! compiler
					    export?
					    reimport?
					    value
					    value-expr
					    type
					    sym
					    forward-decl?
					    declared?
					    address
					    exact-type?
					    read-only?
					    volatile?
					    toplevel-bindings?))))
	  (let ((result
		 (case content-type
;;		   ((obj-ref)
;;		    (parse-obj-ref compiler parse-variable! contents))
		   ((define-variable)
		    (parse-var-def compiler parse-variable! contents address
				   read-only?))
		   ((define-class)
		    (parse-class-decl compiler parse-variable! contents
				      address))
		   ((define-param-class)
		    (parse-param-class-decl compiler parse-variable! contents
					    address))
		   ;; The following check is probably unnecessary.
		   ((define-logical-type)
		    (raise 'syntax-error))
		   ((define-param-logical-type)
		    (parse-param-ltype-decl compiler parse-variable! contents
					    address))
		   (else
		    (raise 'invalid-declaration)))))
	    (hfield-set! compiler 'variable-to-import '())
	    (if (and toplevel-bindings? (not reimport?) (symbol? sym))
		(add-binding sym address))
	    result)))))))


(define (import-gen-proc-def compiler def toplevel? reimport? export?
			     toplevel-bindings?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (strong-assert (and (list? def) (= (length def) 2)))
  (let* ((p-address (cadr def))
	 (module-name (hfield-ref compiler 'module-name))
	 (address (parse-address module-name p-address))
	 (name (hfield-ref address 'source-name))
	 (a (symbol-hash-ref (hfield-ref compiler 'ht-globals-by-name) name)))
    (cond
     (reimport?
      (let ((old-var (get-symbol (hfield-ref compiler 'env) name)))
	(if (eq? old-var #f)
	    (let ((global-var (search-global compiler address)))
	      (if (eq? global-var #f)
		  (raise 'internal-error-with-gen-proc)
		  (if toplevel-bindings?
		      (add-symbol! (hfield-ref compiler 'env) name
				   global-var)))))))
     ((not (eq? a #f))
      (if (eq? (search-global compiler address) #f)
	  (let ((ht (compiler-get-globals-by-address compiler)))
	    (address-hash-set! ht address a))))
     (else
      (assert (eq? (search-global compiler address) #f))
      (let* ((to-clas (make-gen-proc-class-object '()))
	     (str-name (symbol->string name))
	     (to (make-gen-proc-object to-clas str-name '() address))
	     (binder (compiler-get-binder compiler))
	     (env-all (hfield-ref compiler 'env-all)))
	(if toplevel-bindings?
	    (add-symbol! (hfield-ref compiler 'env) name to))
	(address-env-bind-object! binder env-all #f to)
	(symbol-hash-set! (hfield-ref compiler 'ht-globals-by-name)
			  name to)
	(address-hash-set! (compiler-get-globals-by-address compiler)
			   address to)
	(if toplevel-bindings?
	    (add-binding name address)))))))


;; We may have to test if the method with given address
;; is already defined. Checking reimport? should take care of that.

(define (import-method compiler def reimport?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (strong-assert (and (list? def) (= (length def) 6)
		      (eq? (car def) 'method)))
  ;; Methods are not bound to variables
  ;; even though their internal representations are.
  ;; So we do nothing if reimporting.
  (if (not reimport?)
      (let* ((p-gen-proc (list-ref def 1))
	     (p-type (list-ref def 2))
	     (p-procexpr (list-ref def 3))
	     (static? (list-ref def 4))
	     (module-name (hfield-ref compiler 'module-name))
	     (address-env (hfield-ref compiler 'env-all)))
	(strong-assert (boolean? static?))
	(let* ((addr-gen-proc (parse-address module-name p-gen-proc))
	       (to-gen-proc (address-hash-ref
			     (hfield-ref (hfield-ref compiler 'binder)
					 'ht-globals-by-address)
			     addr-gen-proc)))
	  (let ((r-procexpr
		 (parse-repr-fwd compiler address-env p-procexpr)))
	    (strong-assert (not-null? (hfield-ref r-procexpr 'address)))
	    (let ((addr-method (hfield-ref r-procexpr 'address))
		  (r-type (parse-repr-fwd compiler address-env p-type)))
	      (if (generic-contains-method? address-env to-gen-proc addr-method)
		  (raise 'internal-duplicate-method)
		  ;; Mieti exact-type?
		  (let* ((to0
			  (make-target-object
			   r-type
			   #t #f addr-method
			   #f #f
			   #f '()))
			 (binder (compiler-get-binder compiler))
			 (to (add-method-to-generic! binder to-gen-proc to0
						     static?)))
		    to))))))))


(define (import-method-declaration compiler decl level reimport?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (strong-assert (and (list? decl) (= (length decl) 5)
		      (eq? (car decl) 'declare-method)))
  ;; Methods are not bound to variables
  ;; even though their internal representations are.
  ;; So we do nothing if reimporting.
  (if (not reimport?)
      (let ((p-gen-proc (list-ref decl 1))
	    (p-address (list-ref decl 2))
	    (p-method-type (list-ref decl 3))
	    (static? (list-ref decl 4)))
	(strong-assert (boolean? static?))
	(let* ((address-env (hfield-ref compiler 'env-all))
	       (binder (compiler-get-binder compiler))
	       (module-name (get-current-module-name compiler))
	       (addr-gen (parse-address module-name p-gen-proc))
	       ;;	       (gen-proc (address-env-get-item address-env addr-gen))
	       (gen-proc (search-global compiler addr-gen))
	       (r-method-type (parse-repr-fwd compiler address-env
					      p-method-type))
	       (address (parse-address module-name p-address))
	       (t-method (get-method-declaration address r-method-type)))
	  (strong-assert (is-target-object? gen-proc))
	  (address-env-add-binding! address-env t-method)
	  (if (eq? level 'toplevel-interface)
	      (add-method-decl-fwd! compiler gen-proc t-method))
	  (if (not (check-covariant-typing-for-method-type?
		    binder gen-proc r-method-type))
	      (begin
		(hfield-set! compiler 'error-info
			     (hfield-ref addr-gen 'source-name))
		(raise (list 'noncovariant-method-declaration
			     gen-proc r-method-type)))
	      (add-new-method-to-generic! binder
					  gen-proc
					  t-method
					  static?))))))


(define (reexport-syntax s-name)
  (assert (symbol? s-name))
  (let* ((mn (hfield-ref gl-expander 'tup-default-module))
	 (module (get-module0 mn)))
    (assert (and (not (eq? module #f)) (not (eq? module '()))))
    (let* ((al (caar module))
	   (p (assoc (cons s-name '()) al))
	   (alo (hfield-ref gl-expander 'alo-current-exports)))
      (assert (pair? p))
      (hfield-set! alo 'contents
		   (cons p (hfield-ref alo 'contents))))))

    
(define (do-reexport compiler def toplevel? reimport? export?
		     toplevel-bindings?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (strong-assert (and (list? def) (= (length def) 2)
		      (eq? (car def) 'reexport)))
  (assert (boolean? toplevel?))
  (assert (boolean? reimport?))
  (if export?
      (let* ((p-address (cadr def))
	     (current-module-name (get-current-module-name compiler))
	     (address (parse-address current-module-name p-address))
	     (name (hfield-ref address 'source-name))
	     (env (hfield-ref compiler 'env))
	     (env-all (hfield-ref compiler 'env-all)))
	;; It might be possible to be more strict
	;; in case we are not doing a reimport.
	;; We allow an extra reexport in case
	;; a globally declared variable is defined.
	(let ((old-var (get-symbol env name))
	      (var (address-env-get-item env-all address)))
	  (if (eq? old-var #f)
	      (begin
		(if toplevel-bindings?
		    (add-symbol! env name var))
		(if (and (not reimport?) (is-t-macro? var))
		    (reexport-syntax name)))
	      (if (not (address=? address (hfield-ref old-var 'address)))
		  (raise 'reexport-duplicate-variable)))))))


(define (add-public-decl! compiler ent)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (is-entity? ent))
  (hfield-set! compiler 'public-decls
	       (cons ent (hfield-ref compiler 'public-decls))))


(define (import-decl compiler decl level reimport? export?
		     toplevel-bindings?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (strong-assert (and (list? decl) (= (length decl) 3)))
  (assert (memq level '(toplevel toplevel-interface normal)))
  (let* ((toplevel? (if (memq level '(toplevel toplevel-interface)) #t #f))
	 (p-var (cadr decl))
	 (p-type (caddr decl))
	 (env-all (hfield-ref compiler 'env-all))
	 (env (hfield-ref compiler 'env))
	 (r-type (parse-repr compiler env-all p-type))
	 (var (parse-internal-variable compiler env-all p-var))
	 (read-only? (hfield-ref var 'read-only?))
	 (module-name (hfield-ref compiler 'module-name))
	 (address (hfield-ref var 'address))
	 (name (hfield-ref address 'source-name))
	 (old-ent (address-env-get-item env-all address))
	 (binder (compiler-get-binder compiler)))
    (strong-assert (boolean? read-only?)) 
    (strong-assert (boolean? export?))
    (strong-assert read-only?)
    (assert (or (eq? old-ent #f) (is-target-object? old-ent)))
    (cond
     (reimport?
      (if (eq? old-ent #f)
	  (raise 'reimported-variable-not-found)
	  (if export?
	      (begin
		(let ((old-ent2 (get-symbol env name)))
		  (if (eq? old-ent2 #f)
		      (begin
			(if toplevel-bindings?
			    (add-symbol! env name old-ent)))
		      (if (not (address=? address
					  (hfield-ref old-ent2 'address)))
			  (raise 'reimport-conflict))))
		(if (eq? level 'toplevel-interface)
		    (add-public-decl! compiler old-ent))))))
     ((not (eq? old-ent #f))
      (let ((old-type (get-entity-type old-ent)))
	(cond
	 ((not (hfield-ref old-ent 'incomplete?))
	  (raise (list 'cannot-declare-existing-variable-2
		       (cons 's-name name))))
	 ((or (not (is-t-instance? binder old-type tc-class))
	      (not (is-t-instance? binder r-type tc-class)))
	  (raise 'decl-type-not-a-class))
	 ((not (is-t-subtype? binder r-type old-type))
	  (raise 'redecl-type-mismatch-3))
	 ((not (= (length (tno-field-ref r-type 'l-all-fields))
		  (length (tno-field-ref old-type 'l-all-fields))))
	  (raise 'decl-invalid-subtype))
	 (else
	  (let ((to (make-target-object
		     r-type
		     #t
		     (and
		      (is-t-instance? binder r-type tc-class)
		      (not (tno-field-ref r-type 'inheritable?)))
		     address
		     #f
		     #t
		     #f
		     '())))
	    (set-object1! old-ent to)
	    (if export?
		(begin
		  (let ((old-ent2 (get-symbol env name)))
		    (if (eq? old-ent2 #f)
			;; We have updated the contents of old-var
			;; and we must use that (instead of new-var)
			;; here.
			(if toplevel-bindings?
			    (add-symbol! env name old-ent))
			(if (not (address=? address
					    (hfield-ref old-ent2 'address)))
			    (raise 'import-decl-duplicate-variable)))))))))))
     ;;		  (add-public-decl! compiler old-var))))))))
     (else
      (let ((to (make-target-object
		 r-type
		 #t
		 (and
		  (is-t-instance? binder r-type tc-class)
		  (not (tno-field-ref r-type 'inheritable?)))
		 address
		 #f
		 #t
		 #f
		 '())))
	(address-env-add-binding! env-all to)
	(if (eq? level 'toplevel-interface)
	    (add-public-decl! compiler to))
	(if toplevel-bindings? (add-binding name address))
	(if export?
	    (begin
	      (if (symbol-exists? env name)
		  (begin
		    (dvar1-set! env)
		    (raise (list 'duplicate-imported-declaration name)))
		  ;; The new binding in env-all uses new-var
		  ;; and we must use that here, too.
		  (if toplevel-bindings?
		      (add-symbol! env name to))))))))))


(define (import-mutable-decl compiler decl level reimport? export?
			     toplevel-bindings?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (strong-assert (and (list? decl) (= (length decl) 3)))
  (assert (memq level '(toplevel toplevel-interface normal)))
  (let* ((toplevel? (if (memq level '(toplevel toplevel-interface)) #t #f))
	 (p-var (cadr decl))
	 (p-type (caddr decl))
	 (env-all (hfield-ref compiler 'env-all))
	 (env (hfield-ref compiler 'env))
	 (r-type (parse-repr compiler env-all p-type))
	 (var (parse-internal-variable compiler env-all p-var))
	 (read-only? (hfield-ref var 'read-only?))
	 (volatile? (hfield-ref var 'volatile?))
	 (module-name (hfield-ref compiler 'module-name))
	 (address (hfield-ref var 'address))
	 (name (hfield-ref address 'source-name))
	 (old-var (address-env-get-item env-all address))
	 (binder (compiler-get-binder compiler)))
    (strong-assert (boolean? export?))
    (strong-assert (not (and read-only? volatile?)))
    (cond
     (reimport?
      (if (eq? old-var #f)
	  (raise 'reimported-variable-not-found)
	  (if export?
	      (begin
		(let ((old-var2 (get-symbol env name)))
		  (if (eq? old-var2 #f)
		      (if toplevel-bindings?
			  (add-symbol! env name old-var))
		      (if (not (address=? address
					  (hfield-ref old-var2 'address)))
			  (raise 'reimport-conflict))))
		(if (eq? level 'toplevel-interface)
		    (add-public-decl! compiler old-var))))))
     ((not (eq? old-var #f))
      (let ((old-type (get-entity-type old-var)))
	(cond
	 ((not (is-forward-decl? old-var))
	  (raise (list 'cannot-declare-existing-variable-2
		       (cons 's-name name))))
	 ((or (not (is-t-instance? binder old-type tt-type))
	      (not (is-t-instance? binder r-type tt-type)))
	  (raise 'decl-type-not-a-type))
	 ((not (equal-types? binder r-type old-type))
	  (raise 'redecl-type-mismatch-4))
	 (else
	  (let* ((to (make-target-object
		      r-type
		      #t
		      (and
		       (is-t-instance? binder r-type tc-class)
		       (not (tno-field-ref r-type 'inheritable?)))
		      '()
		      #f
		      #t
		      #f
		      '()))
		 (new-var (make-normal-variable4
			   address r-type #f read-only? volatile?
			   #t to export?)))
	    (rebind-variable! old-var new-var)
	    (if export?
		(begin
		  (let ((old-var2 (get-symbol env name)))
		    (if (eq? old-var2 #f)
			;; We have updated the contents of old-var
			;; and we must use that (instead of new-var)
			;; here.
			(if toplevel-bindings?
			    (add-symbol! env name old-var))
			(if (not (address=? address
					    (hfield-ref old-var2 'address)))
			    (raise 'import-mutable-decl-duplicate-variable)))))))))))
     ;;		  (add-public-decl! compiler old-var))))))))
     (else
      (let* ((to (make-target-object
		  r-type
		  #t
		  (and
		   (is-t-instance? binder r-type tc-class)
		   (not (tno-field-ref r-type 'inheritable?)))
		  '()
		  #f
		  #t
		  #f
		  '()))
	     (new-var (make-normal-variable4
		       address r-type #f read-only? volatile?
		       #t to export?)))
	(address-env-add-binding! env-all new-var)
	(if (eq? level 'toplevel-interface)
	    (add-public-decl! compiler new-var))
	(if toplevel-bindings? (add-binding name address))
	(if export?
	    (begin
	      (if (symbol-exists? env name)
		  (raise (list 'duplicate-imported-mutable-declaration name))
		  ;; The new binding in env-all uses new-var
		  ;; and we must use that here, too.
		  (if toplevel-bindings?
		      (add-symbol! env name new-var))))))))))


(define (import-prim-class-def compiler expr level reimport? export?
			       toplevel-bindings?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (strong-assert (and (list? expr) (= (length expr) 15)
		      (eq? (car expr) 'prim-class-def)))
  (assert (memq level '(toplevel toplevel-interface normal)))
  (assert (boolean? reimport?))
  (assert (boolean? export?))
  (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?))
    (if reimport?
	(if export?
	    (let* ((env-all (hfield-ref compiler 'env-all))
		   (env (hfield-ref compiler 'env))
		   (module (get-current-module-name compiler))
		   (address (parse-address module p-address))
		   (sym-name (hfield-ref address 'source-name))
		   (new-var (address-env-get-item env-all address))
		   (old-var (get-symbol env sym-name))
		   (old-address (if (not (eq? old-var #f))
				    (hfield-ref old-var 'address)
				    #f)))
	      (cond
	       ((eq? new-var #f)
		(raise 'reimported-variable-not-found))
	       ((eq? old-var #f)
		(if toplevel-bindings?
		    (add-symbol! env sym-name new-var))
		empty-expression)
	       ((not (address=? address old-address))
		(raise 'reimport-duplicate-variables))))
	    empty-expression)
	(let* ((ht (if goops?
		       (hfield-ref compiler 'ht-goops-classes)
		       (hfield-ref compiler 'ht-prim-classes)))
	       (s-search (if goops?
			     target-name
			     member-target-name))
	       (x-old (hashq-ref ht s-search)))
	  (if (eq? x-old #f)
	      (let* ((env-all (hfield-ref compiler 'env-all))
		     (r-superclass (parse-repr-fwd compiler env-all
						   p-superclass)))
		(strong-assert (is-target-object? r-superclass))
		(let* ((module (get-current-module-name compiler))
		       (r-address (parse-address module p-address))
		       (r-zero-address
			(if (not-null? p-zero-address)
			    (parse-address module p-zero-address)
			    '()))
		       (to (create-custom-prim-class
			    r-address name module goops? r-superclass
			    inh? imm? ebv? r-zero-address))
		       (toplevel?
			(if (memq level '(toplevel toplevel-interface))
			    #t #f))
		       (binder (compiler-get-binder compiler))
		       (env (hfield-ref compiler 'env)))
		  ;; Custom primitive classes are always declared forward.
		  (address-env-bind-object! binder env-all #t to)
		  (if toplevel-bindings?
		      (add-binding (hfield-ref r-address 'source-name)
				   r-address))
		  (hashq-set! ht s-search to)
		  (if (and export? toplevel-bindings?)
		      (let* ((sym-name2 (hfield-ref r-address 'source-name))
			     (to-old (get-symbol env sym-name2)))
			(if (eq? to-old #f)
			    (raise 'internal-error-with-variables)
			    (begin
			      (strong-assert (is-target-object? to-old))
			      (if (hfield-ref to-old 'incomplete?)
				  ;; The binding above may have changed to-old,
				  ;; too.
				  (set-object1! to-old to))))))))
	      (if goops?
		  (raise (list 'multiple-goops-class-definitions target-name))
		  (raise (list 'multiple-prim-class-definitions
			       member-target-name))))))))


(define (import-syntax compiler def reimport? export?
		       toplevel-bindings?)
  (strong-assert (= (length def) 3))
  (cond
   ((not reimport?)
    (let* ((p-address (cadr def))
	   (p-handler (caddr def))
	   (module (get-current-module-name compiler))
	   (address (parse-address module p-address))
	   (s-name (hfield-ref address 'source-name))
	   (to (make-t-macro address '())))
      (ex:expand-toplevel-sequence1
       (list (list 'define-syntax s-name p-handler)))
      (address-env-add-binding2! (hfield-ref compiler 'env-all)
				 address to)
      (if export?
	  (let ((env1 (hfield-ref compiler 'env)))
	    (if (symbol-exists? env1 s-name)
		(raise (list 'duplicate-macro-definition s-name))
		(add-symbol! env1 s-name to))))))
   (export?
    (hfield-set! gl-expander 'exporting-names? #t)
    (let* ((p-address (cadr def))
	   (module (get-current-module-name compiler))
	   (address (parse-address module p-address))
	   (s-name (hfield-ref address 'source-name))
	   (to (address-env-get-item (hfield-ref compiler 'env-all)
				     address)))
      (let ((env (hfield-ref compiler 'env)))
	;; Not sure how macros work if they are not bound toplevel.
	(if (and toplevel-bindings? (not (symbol-exists? env s-name)))
	    (add-symbol! env s-name to)))))
   (else '())))

	    
(define (import-binding compiler def level reimport? export?
			toplevel-bindings?)
  (assert (memq level '(toplevel toplevel-interface normal)))
  (if (not (pair? def))
      (raise 'compiled-module-syntax-error)
      (let ((def-type (car def))
	    (toplevel? (if (memq level '(toplevel toplevel-interface)) #t #f)))
	(case def-type
	  ((general-variable)
	   (import-general-variable compiler def toplevel? reimport? export?
				    toplevel-bindings?))
	  ((gen-proc)
	   (import-gen-proc-def compiler def toplevel? reimport? export?
				toplevel-bindings?))
	  ((method)
	   (import-method compiler def reimport?))
	  ((declare-method)
	   (import-method-declaration compiler def level reimport?))
	  ((reexport)
	   (do-reexport compiler def toplevel? reimport? export?
			toplevel-bindings?))
	  ((declare)
	   (import-decl compiler def level reimport? export?
			toplevel-bindings?))
	  ((declare-mutable)
	   (import-mutable-decl compiler def level reimport? export?
				toplevel-bindings?))
	  ;; import-mutable-decl works for volatile declarations, too.
	  ((declare-volatile)
	   (import-mutable-decl compiler def level reimport? export?
				toplevel-bindings?))
	  ((prim-class-def)
	   (import-prim-class-def compiler def level reimport? export?
				  toplevel-bindings?))
	  ((define-syntax)
	   (import-syntax compiler def reimport? export?
			  toplevel-bindings?))
	  (else '())))))


(define (import-all-bindings compiler decls level reimport? export?
			     toplevel-bindings?)
  (for-each
   (lambda (binding)
     (import-binding compiler binding level reimport? export?
		     toplevel-bindings?))
   decls))


(define (load-module-interface compiler module-name)
  (dwi "Loading interface: ")
  (dwc module-name)
  (dwli-newline)
  (let ((filename (search-file
		   (hfield-ref compiler 'module-search-path)
		   (get-actual-module-name module-name)
		   pcode-interface-ext)))
    (if (eq? filename #f)
	(begin
	  ;; TBD: Move the output to the error module.
	  (display "filename: ")
	  (display filename)
	  (newline)
	  (display "module search path: ")
	  (display (hfield-ref compiler 'module-search-path))
	  (newline)
	  (raise 'cannot-open-interface-file))
	(let* ((module-file
		(theme-open-input-file filename))
	       (name0
		(theme-read module-file))
	       (name1 (get-actual-module-name name0)))
	  (cond ((eof-object? name0)
		 (raise 'unexpected-end-of-module))
		((not (module-name=? name1 module-name))
		 (raise 'module-name-mismatch))
		(else
		 ;; First read the script flag.
		 (theme-read module-file)
		 (let* ((first-free-loc (theme-read module-file))
			(imports (theme-read module-file))
			(imports-with-reexports (theme-read module-file))
			(l-used-modules (theme-read module-file))
			(l-prelinked-bodies (theme-read module-file))
			(defs (theme-read module-file)))
		   (theme-close-input-port module-file)
		   (strong-assert (and (integer? first-free-loc)
				       (>= first-free-loc 0)))
		   (if (eof-object? defs)
		       (raise 'unexpected-end-of-module)
		       (list first-free-loc
			     imports imports-with-reexports l-used-modules
			     l-prelinked-bodies
			     defs)))))))))


(define (update-reexported compiler tup-module l-imports-with-reexport)
  (let* ((ht-all-exports (hfield-ref gl-expander 'ht-all-exports))
	 (alo-target-exports (hash-ref ht-all-exports tup-module)))
    (hfield-set! alo-target-exports 'contents
		 (append
		  (hfield-ref alo-target-exports 'contents)
		  (apply append
			 (map
			  (lambda (tup-imported)
			    (let ((alo-cur-exports
				   (hash-ref ht-all-exports tup-imported)))
			      (assert (not (eq? alo-cur-exports #f)))
			      (hfield-ref alo-cur-exports 'contents)))
			  l-imports-with-reexport))))))


(define (filter-equal-values l)
  (let ((l-result '()))
    (do ((l-cur l (cdr l-cur))) ((null? l-cur))
      (let ((x-cur (car l-cur)))
	(if (not (member x-cur l-result))
	    (set! l-result (cons x-cur l-result)))))
    ;; Reversing the list may not be necessary.
    (reverse l-result)))


(define (update-current-env module-name modules)
  (let* ((modules2 (filter-equal-values modules))
	 (ht-all-exports (hfield-ref gl-expander 'ht-all-exports))
	 (al-new-env '())
	 (l-cur-visited '()))
    (do ((l-cur modules2 (cdr l-cur))) ((null? l-cur))
      (let ((module (car l-cur)))
	(if (not (member module l-cur-visited))
	    (let ((alo-exports
		   (hash-ref ht-all-exports module)))
	      (assert (is-alo? alo-exports))
	      (set! al-new-env
		    (append al-new-env (hfield-ref alo-exports 'contents)))
	      (set! l-cur-visited (cons module l-cur-visited))))))
    (let ((x-mod (get-module module-name)))
      (set-car! (car x-mod)
		(append al-new-env (caar x-mod)))
      (ex:set-usage-env x-mod))))


(define (import-module compiler module-name hierarchy level export?
		       toplevel-bindings?)
  (dwi "Importing interface: ")
  (dwc module-name)
  (dwli-newline)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (or (symbol? module-name)
	      (and (list? module-name)
		   (and-map? symbol? module-name))))
  (assert (list? hierarchy))
  (assert (memq level '(toplevel toplevel-interface normal)))
  (assert (boolean? export?))
  (hfield-set! compiler 'module-to-import module-name)
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (dwi "level: ")
    (dwc level)
    (dwli-newline)
    (dwi "export?: ")
    (dwc export?)
    (dwli-newline)
    (let ((actual-module-name (get-actual-module-name module-name))
	  (toplevel? (if (memq level '(toplevel toplevel-interface)) #t #f))
	  (next-level (if (eq? level 'toplevel-interface) 'toplevel 'normal)))
      (if (member actual-module-name hierarchy)
	  (raise 'cyclic-module-dependency)
	  (let ((reimport?
		 (if (member actual-module-name
			     (hfield-ref compiler 'imported-modules))
		     #t #f)))
	    (dwi "reimport?: ")
	    (dwc reimport?)
	    (dwli-newline)
	    (let ((new-hierarchy (cons actual-module-name hierarchy)))
	      (hfield-set! compiler 'module-name actual-module-name)
	      (let* ((intf (load-module-interface compiler actual-module-name))
		     (first-free-loc (list-ref intf 0))
		     (imports (list-ref intf 1))
		     (imports-with-reexports (list-ref intf 2))
		     (l-used-modules (list-ref intf 3))
		     (l-prelinked-bodies (list-ref intf 4))
		     (defs (list-ref intf 5))
		     (l-interface-imports
		      (if (eq? level 'toplevel-interface)
			  (append imports imports-with-reexports)
			  '())))
		(if (eq? level 'toplevel-interface)
		    (hfield-set! compiler 'l-interface-imports
				 l-interface-imports))
		(if (or toplevel? (not reimport?))
		    (begin
		      (dwli "Importing submodules")
		      (for-each
		       (lambda (submodule)
			 (import-module
			  compiler submodule
			  new-hierarchy next-level
			  (if (memq next-level
				    '(toplevel toplevel-interface))
			      #t #f)
			  #t))
		       imports)
		      (dwli "Using submodules")
		      (for-each
		       (lambda (submodule)
			 (import-module
			  compiler submodule
			  new-hierarchy next-level
			  (if (memq next-level
				    '(toplevel toplevel-interface))
			      #t #f)
			  #f))
		       l-used-modules)))
		(if (or export? (not reimport?))
		    (begin
		      (dwli "Importing reexported submodules")
		      (dwli imports-with-reexports)
		      (for-each
		       (lambda (submodule)
			 (import-module compiler submodule
					new-hierarchy next-level
					export?
					#t))
		       imports-with-reexports)))
		;; We have to reset module-to-import here because
		;; submodules (may) have changed it.
		(hfield-set! compiler 'module-to-import module-name)
		(hfield-set! compiler 'module-name actual-module-name)
		(dwi "Processing module: ")
		(dwc actual-module-name)
		(dwli-newline)
		(if (not reimport?)
		    (if (eq? level 'toplevel-interface)
			(begin
			  (update-current-env
			   actual-module-name
			   (append imports imports-with-reexports
				   l-interface-imports)))
			(update-current-env
			 actual-module-name
			 (append imports imports-with-reexports))))
		(let ((alo-old-exports
		       (hfield-ref gl-expander 'alo-current-exports))
		      (alo-new-exports
		       (if (not reimport?)
			   (make-alo '() eq?)
			   '())))
		  (assert (or (null? alo-new-exports)
			      (is-alo? alo-new-exports)))
		  (hfield-set! gl-expander 'alo-current-exports
			       alo-new-exports)
		  (if (not reimport?)
		      (begin
			(hash-set! (hfield-ref gl-expander 'ht-all-exports)
				   actual-module-name alo-new-exports)))
		  (hfield-set! gl-expander 'tup-default-module
			       actual-module-name)
		  (import-all-bindings compiler defs level
				       reimport? export? toplevel-bindings?)
		  (hfield-set! gl-expander 'alo-current-exports
				   alo-old-exports))
		(hfield-set! compiler 'imported-modules
			     (cons actual-module-name
				   (hfield-ref compiler 'imported-modules)))
		(update-reexported compiler module-name imports-with-reexports)
		(if (eq? level 'toplevel-interface)
		    (hfield-set! compiler 'next-free-loc first-free-loc))
		(hfield-set! compiler 'module-name '())
		(hfield-set! compiler 'module-to-import '()))))))
      (set! gl-indent old-indent)))


(define (import-toplevel-modules compiler module-names toplevel-bindings?)
  (for-each (lambda (mod) (import-module compiler mod '() 'toplevel #t
					 toplevel-bindings?))
	    module-names))
