#| -*-Scheme-*-

$Id: uenvir.scm,v 14.62 2007/01/05 21:19:28 cph Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Microcode Environments
;;; package: (runtime environment)

(declare (usual-integrations))

(define (environment? object)
  (or (system-global-environment? object)
      (ic-environment? object)
      (stack-ccenv? object)
      (closure-ccenv? object)))

(define (guarantee-environment object name)
  (if (not (environment? object))
      (illegal-environment object name)))

(define (illegal-environment object name)
  (error:wrong-type-argument object "environment" name))

(define (environment-has-parent? environment)
  (cond ((system-global-environment? environment)
	 #f)
	((ic-environment? environment)
	 (ic-environment/has-parent? environment))
	((stack-ccenv? environment)
	 (stack-ccenv/has-parent? environment))
	((closure-ccenv? environment)
	 (closure-ccenv/has-parent? environment))
	(else
	 (illegal-environment environment 'ENVIRONMENT-HAS-PARENT?))))

(define (environment-parent environment)
  (cond ((system-global-environment? environment)
	 (error:bad-range-argument environment 'ENVIRONMENT-PARENT))
	((ic-environment? environment)
	 (ic-environment/parent environment))
	((stack-ccenv? environment)
	 (stack-ccenv/parent environment))
	((closure-ccenv? environment)
	 (closure-ccenv/parent environment))
	(else
	 (illegal-environment environment 'ENVIRONMENT-PARENT))))

(define (environment-bound-names environment)
  (cond ((system-global-environment? environment)
	 (system-global-environment/bound-names))
	((ic-environment? environment)
	 (ic-environment/bound-names environment))
	((stack-ccenv? environment)
	 (stack-ccenv/bound-names environment))
	((closure-ccenv? environment)
	 (closure-ccenv/bound-names environment))
	(else
	 (illegal-environment environment 'ENVIRONMENT-BOUND-NAMES))))

(define (environment-macro-names environment)
  (cond ((system-global-environment? environment)
	 (system-global-environment/macro-names))
	((ic-environment? environment)
	 (ic-environment/macro-names environment))
	((or (stack-ccenv? environment)
	     (closure-ccenv? environment))
	 '())
	(else
	 (illegal-environment environment 'ENVIRONMENT-MACRO-NAMES))))

(define (environment-bindings environment)
  (let ((items (environment-bound-names environment)))
    (do ((items items (cdr items)))
	((not (pair? items)))
      (let ((name (car items)))
	(set-car! items
		  (cons name
			(let ((value
			       (environment-safe-lookup environment name)))
			  (if (unassigned-reference-trap? value)
			      '()
			      (list value)))))))
    items))

(define (environment-arguments environment)
  (cond ((ic-environment? environment)
	 (ic-environment/arguments environment))
	((stack-ccenv? environment)
	 (stack-ccenv/arguments environment))
	((or (system-global-environment? environment)
	     (closure-ccenv? environment))
	 'UNKNOWN)
	(else
	 (illegal-environment environment 'ENVIRONMENT-ARGUMENTS))))

(define (environment-procedure-name environment)
  (let ((scode-lambda (environment-lambda environment)))
    (and scode-lambda
	 (lambda-name scode-lambda))))

(define (environment-lambda environment)
  (cond ((system-global-environment? environment)
	 #f)
	((ic-environment? environment)
	 (ic-environment/lambda environment))
	((stack-ccenv? environment)
	 (stack-ccenv/lambda environment))
	((closure-ccenv? environment)
	 (closure-ccenv/lambda environment))
	(else
	 (illegal-environment environment 'ENVIRONMENT-LAMBDA))))

(define (environment-bound? environment name)
  (not (eq? 'UNBOUND (environment-reference-type environment name))))

(define (environment-reference-type environment name)
  (cond ((interpreter-environment? environment)
	 (interpreter-environment/reference-type environment name))
	((stack-ccenv? environment)
	 (stack-ccenv/reference-type environment name))
	((closure-ccenv? environment)
	 (closure-ccenv/reference-type environment name))
	(else
	 (illegal-environment environment 'ENVIRONMENT-REFERENCE-TYPE))))

(define (environment-assigned? environment name)
  (case (environment-reference-type environment name)
    ((UNBOUND) (error:unbound-variable environment name))
    ((MACRO) (error:macro-binding environment name))
    ((UNASSIGNED) #f)
    (else #t)))

(define (environment-lookup environment name)
  (let ((value (environment-safe-lookup environment name)))
    (cond ((unassigned-reference-trap? value)
	   (error:unassigned-variable environment name))
	  ((macro-reference-trap? value)
	   (error:macro-binding environment name))
	  (else value))))

(define (environment-lookup-macro environment name)
  (and (eq? 'MACRO (environment-reference-type environment name))
       (let ((value (environment-safe-lookup environment name)))
	 (and (macro-reference-trap? value)
	      (macro-reference-trap-transformer value)))))

(define (environment-safe-lookup environment name)
  (cond ((interpreter-environment? environment)
	 (interpreter-environment/safe-lookup environment name))
	((stack-ccenv? environment)
	 (stack-ccenv/safe-lookup environment name))
	((closure-ccenv? environment)
	 (closure-ccenv/safe-lookup environment name))
	(else
	 (illegal-environment environment 'ENVIRONMENT-SAFE-LOOKUP))))

(define (environment-assignable? environment name)
  (cond ((interpreter-environment? environment)
	 (interpreter-environment/assignable? environment name))
	((stack-ccenv? environment)
	 (stack-ccenv/assignable? environment name))
	((closure-ccenv? environment)
	 (closure-ccenv/assignable? environment name))
	(else
	 (illegal-environment environment 'ENVIRONMENT-ASSIGNABLE?))))

(define (environment-assign! environment name value)
  (cond ((interpreter-environment? environment)
	 (interpreter-environment/assign! environment name value))
	((stack-ccenv? environment)
	 (stack-ccenv/assign! environment name value))
	((closure-ccenv? environment)
	 (closure-ccenv/assign! environment name value))
	(else
	 (illegal-environment environment 'ENVIRONMENT-ASSIGN!))))

(define (environment-definable? environment name)
  name
  (cond ((interpreter-environment? environment) #t)
	((or (stack-ccenv? environment) (closure-ccenv? environment)) #f)
	(else (illegal-environment environment 'ENVIRONMENT-DEFINABLE?))))

(define (environment-define environment name value)
  (cond ((interpreter-environment? environment)
	 (interpreter-environment/define environment name value))
	((or (stack-ccenv? environment)
	     (closure-ccenv? environment))
	 (error:bad-range-argument environment 'ENVIRONMENT-DEFINE))
	(else
	 (illegal-environment environment 'ENVIRONMENT-DEFINE))))

(define (environment-define-macro environment name value)
  (cond ((interpreter-environment? environment)
	 (interpreter-environment/define-macro environment name value))
	((or (stack-ccenv? environment)
	     (closure-ccenv? environment))
	 (error:bad-range-argument environment 'ENVIRONMENT-DEFINE-MACRO))
	(else
	 (illegal-environment environment 'ENVIRONMENT-DEFINE-MACRO))))

;;;; Global environment

(define-integrable (system-global-environment? object)
  (eq? system-global-environment object))

(define (system-global-environment/bound-names)
  (walk-global object? map-entry/name))

(define (system-global-environment/macro-names)
  (walk-global macro-reference-trap? map-entry/name))

(define (object? v) v #t)

(define (map-entry/name name value)
  value
  name)

(define (map-entry/value name value)
  name
  value)

(define (walk-global keep? map-entry)
  (let ((obarray (fixed-objects-item 'OBARRAY)))
    (let ((n-buckets (vector-length obarray)))
      (let per-bucket ((index 0) (result '()))
	(if (fix:< index n-buckets)
	    (let per-symbol
		((bucket (vector-ref obarray index))
		 (result result))
	      (if (pair? bucket)
		  (per-symbol (cdr bucket)
			      (let ((name (car bucket)))
				(if (special-unbound-name? name)
				    result
				    (let ((value
					   (map-reference-trap-value
					    (lambda ()
					      (system-pair-cdr name)))))
				      (if (or (unbound-reference-trap? value)
					      (not (keep? value)))
					  result
					  (cons (map-entry name value)
						result))))))
		  (per-bucket (fix:+ index 1) result)))
	    result)))))

(define (special-unbound-name? name)
  (eq? name package-name-tag))

;;;; Interpreter Environments

(define (interpreter-environment? object)
  (or (system-global-environment? object)
      (ic-environment? object)))

(define-integrable (ic-environment? object)
  (object-type? (ucode-type environment) object))

(define (guarantee-interpreter-environment object)
  (if (not (interpreter-environment? object))
      (error:wrong-type-datum object "interpreter environment"))
  object)

(define (interpreter-environment/reference-type environment name)
  (let ((i ((ucode-primitive lexical-reference-type 2) environment name))
	(v '#(UNBOUND UNASSIGNED NORMAL MACRO)))
    (if (not (fix:< i (vector-length v)))
	(error "Unknown reference type:" i 'ENVIRONMENT-REFERENCE-TYPE))
    (vector-ref v i)))

(define (interpreter-environment/safe-lookup environment name)
  (let ((cell (list #f)))
    (set-car! cell
	      ((ucode-primitive safe-lexical-reference 2) environment name))
    (map-reference-trap (lambda () (car cell)))))

(define (interpreter-environment/assignable? environment name)
  (case (interpreter-environment/reference-type environment name)
    ((UNBOUND) (error:unbound-variable environment name))
    ((MACRO) (error:macro-binding environment name))
    (else #t)))

(define (interpreter-environment/assign! environment name value)
  (lexical-assignment environment name value)
  unspecific)

(define (interpreter-environment/define environment name value)
  (local-assignment environment name value))

(define (interpreter-environment/define-macro environment name transformer)
  (local-assignment environment name
		    (make-unmapped-macro-reference-trap transformer)))

(define (ic-environment/bound-names environment)
  (map-ic-environment-bindings environment object? map-entry/name))

(define (ic-environment/macro-names environment)
  (map-ic-environment-bindings environment
			       macro-reference-trap?
			       map-entry/name))

(define (ic-environment/arguments environment)
  (let ((environment (ic-external-frame environment)))
    (walk-ic-procedure-args environment
			    (ic-frame-procedure* environment)
			    object?
			    map-entry/value)))

(define (map-ic-environment-bindings environment keep? map-entry)
  (let ((external (ic-external-frame environment))
	(do-frame
	 (lambda (frame)
	   (let ((procedure (ic-frame-procedure frame)))
	     (if (vector? procedure)
		 (append! (walk-ic-frame-extension procedure keep? map-entry)
			  (walk-ic-procedure-args frame
						  (vector-ref procedure 1)
						  keep?
						  map-entry))
		 (walk-ic-procedure-args frame procedure keep? map-entry))))))
    (if (eq? external environment)
	(do-frame environment)
	(append! (do-frame environment) (do-frame external)))))

(define (walk-ic-procedure-args frame procedure keep? map-entry)
  (let ((name-vector (lambda-names-vector (procedure-lambda procedure))))
    (let loop ((index (vector-length name-vector)) (result '()))
      (if (fix:> index 1)
	  (let ((index (fix:- index 1)))
	    (loop index
		  (let ((name (vector-ref name-vector index)))
		    (if (special-unbound-name? name)
			result
			(let ((value (ic-frame-arg frame index)))
			  (if (or (unbound-reference-trap? value)
				  (not (keep? value)))
			      result
			      (cons (map-entry name value) result)))))))
	  result))))

(define (walk-ic-frame-extension extension keep? map-entry)
  (let ((limit (fix:+ 3 (object-datum (vector-ref extension 2)))))
    (let loop ((index 3) (result '()))
      (if (fix:< index limit)
	  (loop (fix:+ index 1)
		(let ((p (vector-ref extension index)))
		  (let ((name (car p)))
		    (if (special-unbound-name? name)
			result
			(let ((value
			       (map-reference-trap-value (lambda () (cdr p)))))
			  (if (keep? value)
			      (cons (map-entry name value) result)
			      result))))))
	  result))))

(define (ic-environment/has-parent? environment)
  (interpreter-environment? (ic-frame-parent environment)))

(define (ic-environment/parent environment)
  (let ((parent (ic-frame-parent environment)))
    (if (not (interpreter-environment? parent))
	(error:bad-range-argument environment 'ENVIRONMENT-PARENT))
    parent))

(define (ic-frame-parent environment)
  (procedure-environment (ic-environment/procedure environment)))

(define (ic-environment/lambda environment)
  (procedure-lambda (ic-environment/procedure environment)))

(define (ic-environment/procedure environment)
  (let ((procedure (ic-frame-procedure* environment)))
    (if (internal-lambda? (procedure-lambda procedure))
	(ic-frame-procedure* (procedure-environment procedure))
	procedure)))

(define (ic-external-frame environment)
  (let ((procedure (ic-frame-procedure* environment)))
    (if (internal-lambda? (procedure-lambda procedure))
	(procedure-environment procedure)
	environment)))

(define (ic-frame-procedure* environment)
  (let ((procedure (ic-frame-procedure environment)))
    (if (vector? procedure)
	(vector-ref procedure 1)
	procedure)))

(define-integrable (ic-frame-procedure environment)
  (system-vector-ref environment 0))

(define-integrable (ic-frame-arg environment index)
  (map-reference-trap-value
   (lambda ()
     (system-vector-ref environment index))))

(define (extend-top-level-environment environment #!optional names values)
  (if (not (interpreter-environment? environment))
      (illegal-environment environment 'EXTEND-TOP-LEVEL-ENVIRONMENT))
  (%extend-top-level-environment environment
				 (if (default-object? names) '() names)
				 (if (default-object? values) 'DEFAULT values)
				 'EXTEND-TOP-LEVEL-ENVIRONMENT))

(define (make-top-level-environment #!optional names values)
  (%extend-top-level-environment system-global-environment
				 (if (default-object? names) '() names)
				 (if (default-object? values) 'DEFAULT values)
				 'MAKE-TOP-LEVEL-ENVIRONMENT))

(define (make-root-top-level-environment #!optional names values)
  (%extend-top-level-environment (object-new-type (object-type #f)
						  (fix:xor (object-datum #f)
							   1))
				 (if (default-object? names) '() names)
				 (if (default-object? values) 'DEFAULT values)
				 'MAKE-ROOT-TOP-LEVEL-ENVIRONMENT))

(define (%extend-top-level-environment environment names values procedure)
  (if (not (list-of-type? names symbol?))
      (error:wrong-type-argument names "list of symbols" procedure))
  (system-list->vector
   (ucode-type environment)
   (cons (system-pair-cons (ucode-type procedure)
			   (make-slambda lambda-tag:unnamed names unspecific)
			   environment)
	 (if (eq? values 'DEFAULT)
	     (let ((values (make-list (length names))))
	       (do ((values values (cdr values)))
		   ((not (pair? values)))
		 (set-car! values
			   (make-unmapped-unassigned-reference-trap)))
	       values)
	     (begin
	       (if (not (list? values))
		   (error:wrong-type-argument values "list" procedure))
	       (if (not (fix:= (length values) (length names)))
		   (error:bad-range-argument values procedure))
	       values)))))

;;;; Compiled Code Environments

(define-structure (stack-ccenv (type vector)
			       (named
				((ucode-primitive string->symbol)
				 "#[(runtime environment)stack-ccenv]"))
			       (conc-name stack-ccenv/))
  (block #f read-only #t)
  (frame #f read-only #t)
  (start-index #f read-only #t))

(define (stack-frame/environment frame default)
  (let* ((ret-add (stack-frame/return-address frame))
	 (object (compiled-entry/dbg-object ret-add)))
    (cond ((not object)
	   default)
	  ((dbg-continuation? object)
	   (let ((block (dbg-continuation/block object)))
	     (let ((parent (dbg-block/parent block)))
	       (case (dbg-block/type parent)
		 ((STACK)
		  (make-stack-ccenv parent
				    frame
				    (+ (dbg-continuation/offset object)
				       (dbg-block/length block))))
		 ((IC)
		  (let ((index (dbg-block/ic-parent-index block)))
		    (if index
			(guarantee-interpreter-environment
			 (stack-frame/ref frame index))
			default)))
		 (else
		  (error "Illegal continuation parent block" parent))))))
	  ((dbg-procedure? object)
	   (let ((block (dbg-procedure/block object)))
	     (case (dbg-block/type block)
	       ((STACK)
		(make-stack-ccenv block
				  frame
				  (if (compiled-closure? ret-add) 0 1)))
	       (else
		(error "Illegal procedure block" block)))))
	  #|
	  ((dbg-expression? object)
	   ;; for now
	   default)
	  |#
	  (else
	   default))))

(define (compiled-procedure/environment entry)
  (if (not (compiled-procedure? entry))
      (error "Not a compiled procedure" entry 'COMPILED-PROCEDURE/ENVIRONMENT))
  (let ((procedure (compiled-entry/dbg-object entry)))
    (if (not procedure)
	(error "Unable to obtain closing environment" entry))
    (let ((block (dbg-procedure/block procedure)))
      (if (not block)
	  (error "Unable to obtain closing environment (missing block info)"
		 entry))
      (let ((parent (dbg-block/parent block)))
	(define (use-compile-code-block-environment)
	  (guarantee-interpreter-environment
	   (compiled-code-block/environment
	    (compiled-code-address->block entry))))
	(if parent
	    (case (dbg-block/type parent)
	      ((CLOSURE)
	       (make-closure-ccenv (dbg-block/original-parent block)
				   parent
				   entry))
	      ((IC)
	       (use-compile-code-block-environment))
	      (else
	       (error "Illegal procedure parent block" parent)))
	    ;; This happens when the procedure has no free variables:
	    (use-compile-code-block-environment))))))

(define (stack-ccenv/has-parent? environment)
  (if (dbg-block/parent (stack-ccenv/block environment))
      #t
      'SIMULATED))

(define (stack-ccenv/parent environment)
  (let ((block (stack-ccenv/block environment)))
    (let ((parent (dbg-block/parent block)))
      (if parent
	  (case (dbg-block/type parent)
	    ((STACK)
	     (let loop
		 ((block block)
		  (frame (stack-ccenv/frame environment))
		  (index
		   (+ (stack-ccenv/start-index environment)
		      (dbg-block/length block))))
	       (let ((stack-link (dbg-block/stack-link block)))
		 (cond ((not stack-link)
			(with-values
			    (lambda ()
			      (stack-frame/resolve-stack-address
			       frame
			       (stack-ccenv/static-link environment)))
			  (lambda (frame index)
			    (let ((block (dbg-block/parent block)))
			      (if (eq? block parent)
				  (make-stack-ccenv parent frame index)
				  (loop block frame index))))))
		       ((eq? stack-link parent)
			(make-stack-ccenv parent frame index))
		       (else
			(loop stack-link
			      frame
			      (+ (vector-length
				  (dbg-block/layout-vector stack-link))
				 (case (dbg-block/type stack-link)
				   ((STACK)
				    0)
				   ((CONTINUATION)
				    (dbg-continuation/offset
				     (dbg-block/procedure stack-link)))
				   (else
				    (error "illegal stack-link type"
					   stack-link)))
				 index)))))))
	    ((CLOSURE)
	     (make-closure-ccenv (dbg-block/original-parent block)
				 parent
				 (stack-ccenv/normal-closure environment)))
	    ((IC)
	     (guarantee-interpreter-environment
	      (if (dbg-block/static-link-index block)
		  (stack-ccenv/static-link environment)
		  (compiled-code-block/environment
		   (compiled-code-address->block
		    (stack-frame/return-address
		     (stack-ccenv/frame environment)))))))
	    (else
	     (error "illegal parent block" parent)))
	  (let ((environment
		 (compiled-code-block/environment
		   (compiled-code-address->block
		    (stack-frame/return-address
		     (stack-ccenv/frame environment))))))
	    (if (ic-environment? environment)
		environment
		system-global-environment))))))

(define (stack-ccenv/lambda environment)
  (dbg-block/source-code (stack-ccenv/block environment)))

(define (stack-ccenv/arguments environment)
  (let ((procedure (dbg-block/procedure (stack-ccenv/block environment))))
    (if procedure
	(letrec ((lookup
		  (lambda (variable)
		    (case (dbg-variable/type variable)
		      ((INTEGRATED)
		       (dbg-variable/value variable))
		      ((INDIRECTED)
		       (lookup (dbg-variable/value variable)))
		      (else
		       (stack-ccenv/safe-lookup
			environment
			(dbg-variable/name variable)))))))
	  (map* (map* (let ((rest (dbg-procedure/rest procedure)))
			(if rest (lookup rest) '()))
		      lookup
		      (dbg-procedure/optional procedure))
		lookup
		(dbg-procedure/required procedure)))
	'UNKNOWN)))

(define (stack-ccenv/bound-names environment)
  (map dbg-variable/name
       (list-transform-positive
	   (vector->list
	    (dbg-block/layout-vector (stack-ccenv/block environment)))
	 dbg-variable?)))

(define (stack-ccenv/reference-type environment name)
  (dbg-variable-reference-type (stack-ccenv/block environment)
			       name
			       (lambda (index)
				 (stack-ccenv/get-value environment index))
    (lambda (name)
      (environment-reference-type (stack-ccenv/parent environment) name))))

(define (stack-ccenv/safe-lookup environment name)
  (lookup-dbg-variable (stack-ccenv/block environment)
		       name
		       (lambda (index)
			 (stack-ccenv/get-value environment index))
    (lambda (name)
      (environment-safe-lookup (stack-ccenv/parent environment) name))))

(define (stack-ccenv/assignable? environment name)
  (assignable-dbg-variable? (stack-ccenv/block environment) name
    (lambda (name)
      (environment-assignable? (stack-ccenv/parent environment) name))))

(define (stack-ccenv/assign! environment name value)
  (assign-dbg-variable! (stack-ccenv/block environment)
			name
			(lambda (index)
			  (stack-ccenv/get-value environment index))
			value
    (lambda (name)
      (environment-assign! (stack-ccenv/parent environment) name value))))

(define (stack-ccenv/get-value environment index)
  (let ((cell (list #f)))
    (set-car!
     cell
     (stack-frame/ref (stack-ccenv/frame environment)
		      (+ (stack-ccenv/start-index environment) index)))
    (map-reference-trap (lambda () (car cell)))))

(define (stack-ccenv/static-link environment)
  (let ((static-link
	 (find-stack-element environment
			     dbg-block/static-link-index
			     "static link")))
    (if (not (or (stack-address? static-link)
		 (interpreter-environment? static-link)))
	(error "Illegal static link in frame" static-link environment))
    static-link))

(define (stack-ccenv/normal-closure environment)
  (let ((closure
	 (find-stack-element environment
			     dbg-block/normal-closure-index
			     "closure")))
    (if (not (or (compiled-closure? closure) (vector? closure)))
	(error "Frame missing closure" closure environment))
#|
    ;; Temporarily disable this consistency check until the compiler
    ;; is modified to provide the correct information for
    ;; multi-closed procedures.
    (if (not (eq? (compiled-entry/dbg-object closure)
		  (dbg-block/procedure (stack-ccenv/block environment))))
	(error "Wrong closure in frame" closure environment))
|#
    closure))

(define (find-stack-element environment procedure name)
  (let ((frame (stack-ccenv/frame environment)))
    (stack-frame/ref
     frame
     (let ((index
	    (find-stack-index (stack-ccenv/block environment)
			      (stack-ccenv/start-index environment)
			      (stack-frame/length frame)
			      procedure)))
       (if (not index)
	   (error (string-append "Unable to find " name) environment))
       index))))

(define (find-stack-index block start end procedure)
  (let loop ((block block) (start start))
    (let ((index (procedure block)))
      (if index
	  (+ start index)
	  (let ((start (+ start (dbg-block/length block)))
		(link (dbg-block/stack-link block)))
	    (and link
		 (< start end)
		 (loop link start)))))))

(define-integrable (dbg-block/length block)
  (vector-length (dbg-block/layout-vector block)))

(define-structure (closure-ccenv
		   (type vector)
		   (named
		    ((ucode-primitive string->symbol)
		     "#[(runtime environment)closure-ccenv]"))
		   (conc-name closure-ccenv/))
  (stack-block #f read-only #t)
  (closure-block #f read-only #t)
  (closure #f read-only #t))

(define (closure-ccenv/bound-names environment)
  (map dbg-variable/name
       (list-transform-positive
	   (vector->list
	    (dbg-block/layout-vector (closure-ccenv/stack-block environment)))
	 (lambda (variable)
	   (and (dbg-variable? variable)
		(or (eq? (dbg-variable/type variable) 'INTEGRATED)
		    (vector-find-next-element
		     (dbg-block/layout-vector
		      (closure-ccenv/closure-block environment))
		     variable)))))))

(define (closure-ccenv/reference-type environment name)
  (dbg-variable-reference-type (closure-ccenv/closure-block environment)
			       name
			       (lambda (index)
				 (closure-ccenv/get-value environment index))
    (lambda (name)
      (environment-reference-type (closure-ccenv/parent environment) name))))

(define (closure-ccenv/safe-lookup environment name)
  (lookup-dbg-variable (closure-ccenv/closure-block environment)
		       name
		       (lambda (index)
			 (closure-ccenv/get-value environment index))
    (lambda (name)
      (environment-safe-lookup (closure-ccenv/parent environment) name))))

(define (closure-ccenv/assignable? environment name)
  (assignable-dbg-variable? (closure-ccenv/closure-block environment) name
    (lambda (name)
      (environment-assignable? (closure-ccenv/parent environment) name))))

(define (closure-ccenv/assign! environment name value)
  (assign-dbg-variable! (closure-ccenv/closure-block environment)
			name
			(lambda (index)
			  (closure-ccenv/get-value environment index))
			value
    (lambda (name)
      (environment-assign! (closure-ccenv/parent environment) name value))))

(define (closure-ccenv/get-value environment index)
  (closure/get-value (closure-ccenv/closure environment)
		     (closure-ccenv/closure-block environment)
		     index))

(define (closure/get-value closure closure-block index)
  (let ((cell (list #f)))
    (set-car!
     cell
     (compiled-closure/ref closure
			   index
			   (dbg-block/layout-first-offset closure-block)))
    (map-reference-trap (lambda () (car cell)))))

(define (closure-ccenv/has-parent? environment)
  (or (let ((stack-block (closure-ccenv/stack-block environment)))
	(let ((parent (dbg-block/parent stack-block)))
	  (and parent
	       (case (dbg-block/type parent)
		 ((CLOSURE) (and (dbg-block/original-parent stack-block) #t))
		 ((STACK IC) #t)
		 (else (error "Illegal parent block" parent))))))
      'SIMULATED))

(define (closure-ccenv/parent environment)
  (let ((stack-block (closure-ccenv/stack-block environment))
	(closure-block (closure-ccenv/closure-block environment))
	(closure (closure-ccenv/closure environment)))
    (let ((parent (dbg-block/parent stack-block))
	  (use-simulation
	   (lambda ()
	     (if (compiled-closure? closure)
		 (let ((environment
			(compiled-code-block/environment
			 (compiled-entry/block closure))))
		   (if (ic-environment? environment)
		       environment
		       system-global-environment))
		 system-global-environment))))
      (if parent
	  (case (dbg-block/type parent)
	    ((STACK)
	     (make-closure-ccenv parent closure-block closure))
	    ((CLOSURE)
	     (let ((parent (dbg-block/original-parent stack-block)))
	       (if parent
		   (make-closure-ccenv parent closure-block closure)
		   (use-simulation))))
	    ((IC)
	     (guarantee-interpreter-environment
	      (let ((index (dbg-block/ic-parent-index closure-block)))
		(if index
		    (closure/get-value closure closure-block index)
		    (use-simulation)))))
	    (else
	     (error "Illegal parent block" parent)))
	  (use-simulation)))))

(define (closure-ccenv/lambda environment)
  (dbg-block/source-code (closure-ccenv/stack-block environment)))

(define (lookup-dbg-variable block name get-value not-found)
  (let loop ((name name))
    (let ((index (dbg-block/find-name block name)))
      (if index
	  (let ((variable (vector-ref (dbg-block/layout-vector block) index)))
	    (case (dbg-variable/type variable)
	      ((NORMAL)
	       (get-value index))
	      ((CELL)
	       (let ((value (get-value index)))
		 (if (not (cell? value))
		     (error "Value of variable should be in cell:"
			    variable value))
		 (cell-contents value)))
	      ((INTEGRATED)
	       (dbg-variable/value variable))
	      ((INDIRECTED)
	       (loop (dbg-variable/name (dbg-variable/value variable))))
	      (else
	       (error "Unknown variable type:" variable))))
	  (not-found name)))))

(define (dbg-variable-reference-type block name get-value not-found)
  (let ((value->reference-type
	 (lambda (value)
	   (cond ((unassigned-reference-trap? value) 'UNASSIGNED)
		 ((macro-reference-trap? value) 'MACRO)
		 (else 'NORMAL)))))
    (let loop ((name name))
      (let ((index (dbg-block/find-name block name)))
	(if index
	    (let ((variable
		   (vector-ref (dbg-block/layout-vector block) index)))
	      (case (dbg-variable/type variable)
		((NORMAL)
		 (value->reference-type (get-value index)))
		((CELL)
		 (let ((value (get-value index)))
		   (if (not (cell? value))
		       (error "Value of variable should be in cell"
			      variable value))
		   (value->reference-type (cell-contents value))))
		((INTEGRATED)
		 (value->reference-type (dbg-variable/value variable)))
		((INDIRECTED)
		 (loop (dbg-variable/name (dbg-variable/value variable))))
		(else
		 (error "Unknown variable type:" variable))))
	    (not-found name))))))

(define (assignable-dbg-variable? block name not-found)
  (let ((index (dbg-block/find-name block name)))
    (if index
	(eq? 'CELL
	     (dbg-variable/type
	      (vector-ref (dbg-block/layout-vector block)
			  index)))
	(not-found name))))

(define (assign-dbg-variable! block name get-value value not-found)
  (let ((index (dbg-block/find-name block name)))
    (if index
	(let ((variable (vector-ref (dbg-block/layout-vector block) index)))
	  (case (dbg-variable/type variable)
	    ((CELL)
	     (let ((cell (get-value index)))
	       (if (not (cell? cell))
		   (error "Value of variable should be in cell:" name cell))
	       (set-cell-contents! cell value)
	       unspecific))
	    ((NORMAL INTEGRATED INDIRECTED)
	     (error "Variable cannot be modified:" variable))
	    (else
	     (error "Unknown variable type:" variable))))
	(not-found name))))

(define (dbg-block/name block)
  (let ((procedure (dbg-block/procedure block)))
    (and procedure
	 (dbg-procedure/name procedure))))

(define (dbg-block/source-code block)
  (let ((procedure (dbg-block/procedure block)))
    (and procedure
	 (dbg-procedure/source-code procedure))))