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

; Link script.

(define (link-initial-system)

  ;; populate the packages needed for macro expansion
  (populate-structure! syntax-objects
		       `((stx-car . ,stx-car)
			 (stx-cdr . ,stx-cdr)
			 (stx-cadr . ,stx-cadr)
			 (syntax-e . ,syntax-e)
			 (identifier? . ,identifier?)
			 (datum->syntax . ,datum->syntax)
			 (syntax->datum . ,syntax->datum)))
  (populate-structure! syntax-transformers
		       `((make-transformer/free-identifier=? . ,make-transformer/free-identifier=?)
			 (transformer/free-identifier=?? . ,transformer/free-identifier=??)
			 (transformer/free-identifier=?-proc . ,transformer/free-identifier=?-proc)))
  (populate-structure! syntax-rules-apply
		       `((make-pattern-env . ,make-pattern-env)
			 (match? . ,match?)
			 (rewrite . ,rewrite)))
  (populate-structure! syntax-rules-data
		       `((make-pattern-variable . ,make-pattern-variable)))
  (populate-structure! low-exceptions
		       `((assertion-violation . ,assertion-violation)
			 (syntax-violation . ,syntax-violation)))
  (populate-structure! scheme-level-0
		       `((cons . ,cons)
			 (cdr . ,cdr)
			 (assq . ,assq)))
  (populate-structure! scheme-level-1x
		       `((list->vector . ,list->vector)
			 (list . ,list)))
  (let ((structures-to-open		;Structures to open for the initial
	 (struct-list scheme		;system's read-eval-print loop.
		      platform
		      environments
		      module-system
		      load-packages
		      packages
		      packages-internal  ; package-for-syntax
		      vanilla-reader)))
    (link-reified-system (append (desirable-structures)
				 structures-to-open)
			 '(build initial)
			 ;; The expression that evaluates to the
			 ;; procedure that maps the reified-structure alist
			 ;; to the startup procedure:
			 `(start ',(map car structures-to-open))
			 ;; replace `static-scheme' (see alt/init-defpackage.scm) by `scheme'
			 (lambda (opens-alist)
			   (map (lambda (p)
				  (case (car p)
				    ((1)
				     (cons 1 
					   (map (lambda (struct)
						  (case (structure-name struct)
						    ((static-scheme) scheme)
						    (else struct)))
						(cdr p))))
				    (else p)))
				opens-alist))
			 ;; make sure we get the syntax-rules transformer before `scheme-level-1'
			 (lambda (struct phase)
			   (eq? (structure-name struct) 'syntax-rules-transform))
			 ;; Structures to open for evaluating that
			 ;; expression and the expression that
			 ;; evaluates to the reified-structure alist:
			 initial-system
			 for-reification
			 packages-internal
			 ;; scheme-level-1
			 )))

(define (desirable-structures)
  (let ((env (interaction-environment))
	(l '()))
    (for-each (lambda (int)
		(for-each-declaration
		     (lambda (name package-name phase type)
		       (if (not (assq name l))
			   (let ((s (eval name env)))
			     (if (structure? s)
				 (set! l (cons (cons name s) l))))))
		     int))
	      (list low-structures-interface
		    run-time-structures-interface
		    features-structures-interface
		    run-time-internals-structures-interface
		    compiler-structures-interface
		    initial-structures-interface))
    (reverse l)))

(define (populate-structure! struct alist)
  (let ((package (structure-package struct)))
    (for-each (lambda (pair)
		(let ((loc (package-define! package (car pair) value-type #f #f)))
		  (set-contents! loc (cdr pair))))
	      alist)))

; Your choice of evaluators:

(define scheme (make-scheme environments evaluation))
; (define scheme (make-scheme mini-environments mini-eval))
; (define scheme (make-scheme environments run))
; etc.

; Your choice of command processors.

(define initial-system
  (make-initial-system scheme (make-mini-command scheme)))

