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

; This file has the Pre-Scheme compiler's code for dealing with the
; Scheme 48's module system.

; FILES is a list of files that contain structure definitions, including
; a definition for NAME.  The files are loaded into a config package
; containing:
;   - the procedures and macros for defining structures and interfaces
;   - a Pre-Scheme structure (called PRESCHEME)
;   - a ps-memory structure
;   - a ps-receive structure
; We then return:
;   1. a list of the packages required to implement the named structures
;   2. a list of the names exported by the named structures
;   3. a procedure that for looking up names defined in packages in the
;      config package (this is used to map user directives to their targets)

(define (package-specs->packages+exports struct-names files)
  (let ((config (make-very-simple-package 'config (list defpackage)))
	(old-config (config-package)))
    (environment-define! config 'prescheme prescheme)
    (environment-define! config 'ps-memory ps-memory)
    (environment-define! config 'ps-receive ps-receive)
    (environment-define! config 'ps-flonums ps-flonums)
    (environment-define! config 'ps-unsigned-integers ps-unsigned-integers)
    (environment-define! config 'ps-record-types ps-record-types)
    (environment-define! config ':syntax syntax-type)
    (set-reflective-tower-maker! config (get-reflective-tower-maker old-config))
    (let-fluids $get-location (make-cell get-variable)
		$note-file-package (make-cell (lambda (filename package) (values)))
      (lambda () 
	(for-each (lambda (file)
		    (load file config))
		  files)))
    (values (collect-packages (map (lambda (name)
				     (environment-ref config name))
				   struct-names)
			      (lambda (package)
				#t))
	    (let ((names '()))
	      (for-each (lambda (struct-name)
			  (let ((my-names '()))
			    (for-each-declaration
			      (lambda (name . _)
				(set! my-names (cons name my-names)))
			      (structure-interface
			        (environment-ref config struct-name)))
			    (set! names
				  (cons (cons struct-name my-names)
					names))))
			struct-names)
	      names)
	    (make-lookup config))))

; This creates new variables as needed for packages.

(define (get-variable package name)
  ;(format #t "Making variable ~S for ~S~%" name package)
  (make-global-variable name type/unknown))

; Return something that will find the binding of ID in the package belonging
; to the structure PACKAGE-ID in the CONFIG package.

(define (make-lookup config)
  (lambda (package-id id)
    (let ((binding (package-lookup config package-id)))
      (if (and (binding? binding)
	       (location? (binding-place binding))
	       (structure? (contents (binding-place binding))))
	  (let* ((package (structure-package
			   (contents (binding-place binding))))
		 (binding (package-lookup package id)))
	    (if (binding? binding)
		(binding-place binding)
		#f))
	  #f))))
	       
;----------------------------------------------------------------
; Handy packages and package making stuff.

(define (make-env-for-syntax-promise . structures)
  (make-reflective-tower eval structures 'prescheme-linking))

(define (make-very-simple-package name opens)
  (make-simple-package opens
		       #t
		       (make-env-for-syntax-promise scheme)
		       name))

(define (get-reflective-tower-maker p)
  (environment-ref p (string->symbol ".make-reflective-tower.")))

;----------------------------------------------------------------
; The following stuff is used to define the DEFINE-RECORD-TYPE macro.
; We produce a structure that exports EXPAND-DEFINE-RECORD-TYPE.  The
; base package then includes that structure in its FOR-SYNTAX package.

(define defrecord-for-syntax-package
  (make-very-simple-package 'defrecord-for-syntax-package '()))

(define defrecord-for-syntax-structure
  (make-structure defrecord-for-syntax-package
		  (lambda () (export expand-define-record-type))
		  'defrecord-for-syntax-structure))

(define (define-for-syntax-value id value)
  (let ((loc (make-new-location defrecord-for-syntax-package id)))
    (set-contents! loc value)
    (package-define! defrecord-for-syntax-package
		     id
		     usual-variable-type
		     loc
		     #f)))

(define-for-syntax-value 'expand-define-record-type expand-define-record-type)

;----------------------------------------------------------------
; BASE-PACKAGE contains all of the primitives, syntax, etc. for Pre-Scheme

(define (prescheme-unbound package name)
  (bug "~S has no binding in package ~S" name package))

(define base-package
;  (let-fluid $get-location prescheme-unbound
;    (lambda () ))
  (make-simple-package '()
		       #t
		       (make-env-for-syntax-promise
			  scheme
			  defrecord-for-syntax-structure)
		       'base-package))

; Add the operators.

(for-each (lambda (id)
	    (package-define! base-package
			     id
			     syntax-type
			     #f
			     (get-operator id syntax-type)))
	  '(if begin lambda letrec quote set!
	       define define-syntax let-syntax letrec-syntax
					; the rest are special for Prescheme
	       goto type-case real-external))

; Add the usual macros.

(for-each (lambda (name)
	    (package-define! base-package
			     name
			     syntax-type
			     #f
			     (make-transform
			      (usual-transform name)
			      base-package
			      syntax-type
			      `(usual-transform ',name)
			      name)))
	  '(and cond do let let* or quasiquote)) ; delay

; Plus whatever primitives are wanted.

(define (define-prescheme! name location static)
  (package-define! base-package
		   name
		   usual-variable-type
		   location
		   static))

; Copy over the enumeration macros and the ERRORS enumeration.

(define (import-syntax! package-id name)
  (let* ((config (config-package))
	 (binding (structure-lookup (environment-ref config package-id)
				    name
				    #t)))
    (package-define! base-package
		     name
		     syntax-type
		     (binding-place binding)
		     (binding-static binding))))

(import-syntax! 'enumerated 'define-enumeration)
(import-syntax! 'enumerated 'enum)
(import-syntax! 'enumerated 'name->enumerand)
(import-syntax! 'enumerated 'enumerand->name)
(import-syntax! 'prescheme  'errors)
(import-syntax! 'prescheme  'define-external-enumeration)
(import-syntax! 'scheme     'syntax-rules)

; define still more syntax

(load "prescheme/ps-syntax.scm" base-package)

(eval '(define-syntax define-record-type expand-define-record-type)
      base-package)

;(eval '(define-syntax define-union-type expand-define-union-type)
;      base-package)

;----------------------------------------------------------------
; Make the Pre-Scheme structure and related structures

(define (get-interface name)
  (environment-ref (config-package) name))

(define prescheme
  (make-structure base-package
		  (lambda () (get-interface 'prescheme-interface))
		  'prescheme))

(define ps-memory
  (make-structure base-package
		  (lambda () (get-interface 'ps-memory-interface)) 
		  'ps-memory))

(define ps-flonums
  (make-structure base-package
		  (lambda () (get-interface 'ps-flonums-interface)) 
		  'ps-flonums))

(define ps-unsigned-integers
  (make-structure base-package
		  (lambda () (get-interface 'ps-unsigned-integers-interface)) 
		  'ps-unsigned-integers))

(define ps-receive
  (make-structure base-package
		  (lambda () (get-interface 'ps-receive-interface)) 
		  'ps-receive))

(define ps-record-types
  (make-structure base-package
                  (lambda () (export (define-record-type :syntax)))
                  'ps-record-types))

; and a handy environment

(define prescheme-compiler-env
  (package->environment base-package))

