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


; This file should be loaded into the bootstrap linker before any use
; of DEFINE-STRUCTURE.  Compare with env/init-defpackage.scm.

(define (compile-transformer name node env)
  (values #f
	  (lambda ()
	    (evaluate-node node
			   global-ref global-set!
			   (lambda (closure)
			     (lambda args (apply-eval-closure closure args)))
			   (lambda (proc args) (apply proc args))))))

(define (global-ref name)
  (contents (name-location name)))

(define (name-location name)  
  (let ((binding (node-ref name 'binding)))
    (if (binding? binding)
	(let ((value (binding-place binding)))
	  (cond
	   ((location? value) 
	    (if (not (location-defined? value))
		(assertion-violation 'name-location "undefined location" name binding value))
	    value)
	   (else
	    (assertion-violation 'name-location "binding place is not a location" name binding value))))
	(assertion-violation 'name-location "binding property is not a binding" name binding))))

(define (global-set! name value)
  (set-contents! (name-location name) value))

; Create a package with all the right stuff in it

(define for-expansion-primitives
  `((* . ,*)
    (+ . ,+)
    (- . ,-)
    (/ . ,/)
    (< . ,<)
    (<= . ,<=)
    (= . ,=)
    (> . ,>)
    (>= . ,>=)
    (abs . ,abs)
    (acos . ,acos)
    (angle . ,angle)
    (append . ,append)
    (apply . ,apply)
    (asin . ,asin)
    (assoc . ,assoc)
    (assq . ,assq)
    (assv . ,assv)
    (atan . ,atan)
    (boolean? . ,boolean?)
    (caaaar . ,caaaar)
    (caaadr . ,caaadr)
    (caaar . ,caaar)
    (caadar . ,caadar)
    (caaddr . ,caaddr)
    (caadr . ,caadr)
    (caar . ,caar)
    (cadaar . ,cadaar)
    (cadadr . ,cadadr)
    (cadar . ,cadar)
    (caddar . ,caddar)
    (cadddr . ,cadddr)
    (caddr . ,caddr)
    (cadr . ,cadr)
    (call-with-current-continuation . ,call-with-current-continuation)
    (call-with-values . ,call-with-values)
    (car . ,car)
    (cdaaar . ,cdaaar)
    (cdaadr . ,cdaadr)
    (cdaar . ,cdaar)
    (cdadar . ,cdadar)
    (cdaddr . ,cdaddr)
    (cdadr . ,cdadr)
    (cdar . ,cdar)
    (cddaar . ,cddaar)
    (cddadr . ,cddadr)
    (cddar . ,cddar)
    (cdddar . ,cdddar)
    (cddddr . ,cddddr)
    (cdddr . ,cdddr)
    (cddr . ,cddr)
    (cdr . ,cdr)
    (ceiling . ,ceiling)
    (char->integer . ,char->integer)
    (char-alphabetic? . ,char-alphabetic?)
    (char-ci<=? . ,char-ci<=?)
    (char-ci<? . ,char-ci<?)
    (char-ci=? . ,char-ci=?)
    (char-ci>=? . ,char-ci>=?)
    (char-ci>? . ,char-ci>?)
    (char-downcase . ,char-downcase)
    (char-lower-case? . ,char-lower-case?)
    (char-numeric? . ,char-numeric?)
    (char-upcase . ,char-upcase)
    (char-upper-case? . ,char-upper-case?)
    (char-whitespace? . ,char-whitespace?)
    (char<=? . ,char<=?)
    (char<? . ,char<?)
    (char=? . ,char=?)
    (char>=? . ,char>=?)
    (char>? . ,char>?)
    (char? . ,char?)
    (complex? . ,complex?)
    (cons . ,cons)
    (cos . ,cos)
    (denominator . ,denominator)
    (dynamic-wind . ,dynamic-wind)
    (eq? . ,eq?)
    (equal? . ,equal?)
    (eqv? . ,eqv?)
    (even? . ,even?)
    (exact->inexact . ,exact->inexact)
    (exact? . ,exact?)
    (exp . ,exp)
    (expt . ,expt)
    (floor . ,floor)
    (for-each . ,for-each)
    (gcd . ,gcd)
    (imag-part . ,imag-part)
    (inexact->exact . ,inexact->exact)
    (inexact? . ,inexact?)
    (integer->char . ,integer->char)
    (integer? . ,integer?)
    (lcm . ,lcm)
    (length . ,length)
    (list . ,list)
    (list->string . ,list->string)
    (list->vector . ,list->vector)
    (list-ref . ,list-ref)
    (list-tail . ,list-tail)
    (list? . ,list?)
    (log . ,log)
    (magnitude . ,magnitude)
    (make-polar . ,make-polar)
    (make-rectangular . ,make-rectangular)
    (make-string . ,make-string)
    (make-vector . ,make-vector)
    (map . ,map)
    (max . ,max)
    (member . ,member)
    (memq . ,memq)
    (memv . ,memv)
    (min . ,min)
    (modulo . ,modulo)
    (negative? . ,negative?)
    (not . ,not)
    (null? . ,null?)
    (number->string . ,number->string)
    (number? . ,number?)
    (numerator . ,numerator)
    (odd? . ,odd?)
    (pair? . ,pair?)
    (positive? . ,positive?)
    (procedure? . ,procedure?)
    (quotient . ,quotient)
    (rational? . ,rational?)
    (rationalize . ,rationalize)
    (read-char . ,read-char)
    (real-part . ,real-part)
    (real? . ,real?)
    (remainder . ,remainder)
    (reverse . ,reverse)
    (round . ,round)
    (set-car! . ,set-car!)
    (set-cdr! . ,set-cdr!)
    (sin . ,sin)
    (sqrt . ,sqrt)
    (string . ,string)
    (string->list . ,string->list)
    (string->number . ,string->number)
    (string->symbol . ,string->symbol)
    (string-append . ,string-append)
    (string-ci<=? . ,string-ci<=?)
    (string-ci<? . ,string-ci<?)
    (string-ci=? . ,string-ci=?)
    (string-ci>=? . ,string-ci>=?)
    (string-ci>? . ,string-ci>?)
    (string-copy . ,string-copy)
    (string-fill! . ,string-fill!)
    (string-length . ,string-length)
    (string-ref . ,string-ref)
    (string-set! . ,string-set!)
    (string<=? . ,string<=?)
    (string<? . ,string<?)
    (string=? . ,string=?)
    (string>=? . ,string>=?)
    (string>? . ,string>?)
    (string? . ,string?)
    (substring . ,substring)
    (symbol->string . ,symbol->string)
    (symbol? . ,symbol?)
    (tan . ,tan)
    (truncate . ,truncate)
    (values . ,values)
    (vector . ,vector)
    (vector->list . ,vector->list)
    (vector-fill! . ,vector-fill!)
    (vector-length . ,vector-length)
    (vector-ref . ,vector-ref)
    (vector-set! . ,vector-set!)
    (vector? . ,vector?)
    (zero? . ,zero?)

    ;; kludge; needed by defpackage structure
    (display . ,display)
    (write . ,write)
    (newline . ,newline)
    ))

(define for-expansion-package
  (let ((p (make-simple-package '() #t #f 'for-expansion)))
    (initialize-package! p)
    (let ((env (package->environment p)))
      (define-operators env)
      (for-each (lambda (name)
		  (define-usual-transform p name))
		'(and or cond do let let* letrec case quasiquote define lambda body))
      ;; most of `scheme'
      (for-each (lambda (pair)
		  (let ((loc (package-define! p (car pair) value-type #f #f)))
		    (set-contents! loc (cdr pair))))
		for-expansion-primitives))
    p))

(define static-scheme
  (make-structure
   for-expansion-package
   (make-simple-interface #f
			  (append '(quote
				    define
				    lambda 
				    set!
				    begin
				    if
				    letrec
				    letrec*
				    and or cond do let let* case quasiquote)
				  (map car for-expansion-primitives)))
   'static-scheme))

(define-syntactic-tower-maker
  (lambda (for-syntax-alist names)
    (if (and (pair? for-syntax-alist)
	     (not (equal? for-syntax-alist '((1 scheme)))))
	(warn "a FOR-SYNTAX clause appears in a package being linked by the cross-linker"
	      for-syntax-alist))
    (vector compile-transformer 
	    (lambda (_)
	      (lambda (package-0 phase)
		;; our for-expansion structure doesn't need loading
		package-0))
	    (if (null? for-syntax-alist)
		'()
		(list (cons 1 (lambda () (list static-scheme))))))))

(define-reader vanilla-read-forms)

