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

; Things used by the expression returned by REIFY-STRUCTURES.
; Cf. link/reify.scm.

(define (operator name type-exp)
  (let ((type
	 (case type-exp
	   ((internal leaf #f) type-exp)
	   (else (sexp->type type-exp #t)))))
    (get-operator name type)))

(define (primop name)
  (get-primop name))

(define (simple-interface names phases types)
  (make-simple-interface #f
			 (map (lambda (name phase type)
				(list name phase (sexp->type type #t)))
			      (vector->list names)
			      (vector->list phases)
			      (vector->list types))))

(define (package names locs opens get-location uid 
		 invoke-template-in-a-list 
		 visit-template-in-a-list 
		 usual-transforms clauses)
  (let ((end (vector-length names))
	(p (make-package (list (lambda () opens))
			 #f #f "" clauses
			 uid #f)))
    (set-package-visited?! p #t)
    (set-package-invoked?! p #t)
    (do ((i 0 (+ i 1)))
	((= i end))
      (let* ((name (vector-ref names i))
	     (probe (package-lookup p name)))
	(if (not (binding? probe))
	    (package-define! p
			     name
			     usual-variable-type
			     (get-location (vector-ref locs i))
			     #f))))
    (set-package-invoke-template! p (car invoke-template-in-a-list)) ; see comment in reify.scm
    (set-package-visit-template! p (car visit-template-in-a-list))
    (set-package-make-lookup-package! p values)
    (set-package-usual-transforms! p usual-transforms)
    (define-usual-transforms p)
    (make-table-immutable! (package-definitions p))
    (make-table-immutable! (package-generated-definitions p))
    p))

(define (package-define-static! package name static)
  (package-define! package
		   name
		   (cond ((inline-transform? static)
			  (inline-transform-type static))
			 ((primop? static)
			  (primop-type static))
			 ((operator? static)
			  (operator-type static))
			 ((structure? static)
			  structure-type)
			 ((eq? 'syntax static)
			  syntax-type)
			 (else
			  (assertion-violation 'package-define-static!
					       "unknown kind of static value" static)))
		   #f
		   static))
