; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; For package re-instantiation

(define (copy-package old phase copy-values?)
  (if (not (package-visit-template old))
      (assertion-violation 'copy-package "cannot copy uncompiled package" old phase copy-values?))
  (let ((new (make-package (package-recreate-opens old)
			   (package-unstable? old)
			   (package-syntactic-tower old)
			   (package-file-name old)
			   (package-clauses old)
			   #f
			   (package-name old))))
    (set-package-phase! new phase)
    (set-package-invoke-template! new (package-invoke-template old))
    (set-package-visit-template! new (package-visit-template old))
    (set-package-usual-transforms! new (package-usual-transforms old))
    (set-package-integrate?! new (package-integrate? old))
    (set-package-optimizers! new (package-optimizers old))
    (set-package-all-operators?! new (package-all-operators? old))
    
    (for-each-definition
     (lambda (name binding)
       ;; The use of `qualified->name' is slightly problematic, as it
       ;; may involve lookup of the name, which we're only defining
       ;; below.
       (let ((new-name (qualified->name (name->qualified name) new))
	     (static (binding-static binding)))
	 (package-define! new new-name (binding-type binding) 
			  ;; this is for phase-0 visited packages,
			  ;; where we want the run-time references to
			  ;; point back to the original package
			  (if (and (not static) copy-values?)
			      (binding-place binding)
			      #f)
			  (cond
			   ((inline-transform? static)
			    (copy-inline-transform static new))
			   (else static)))))
     old)
    (define-usual-transforms new)
    new))
