;;; -*- Mode: Scheme; scheme48-package: package-phases -*-

;;;; Compiled Code Storage for Scheme48
;;;; Package Phases -- Early-Bind/Expand, Compile, & Load

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define (early-bind-package package)
  (if (not (package-early-bound? package))
      (begin
        (for-each (lambda (struct)
                    (early-bind-package
                     (structure-package struct)))
                  (package-opens package))
        (or (maybe-fasload-package-bindings package)
            (if (package-expanded-forms package)
                (error "package expanded but not early-bound?"
                       package)
                (expand-package package)))
        (set-package-early-bound?! package #t))))

(define (expand-package package)
  (or (package-expanded-forms package)
      (let ((expanded-forms
             (expand-package-from-source package)))
        (set-package-expanded-forms! package expanded-forms)
        expanded-forms)))

(define (compile-package package)
  (early-bind-package package)
  (or (package-template package)
      (maybe-fasload-package-template package)
      (compile-package-from-source package)))

(define (compile-package-from-source package)
  (let ((template (compile-forms (or (package-expanded-forms package)
                                     (expand-package package))
                                 (package-name package)
                                 (package-uid package))))
    (link! template package #t)         ; #T -> warn about undefined
    (set-package-template! package template)
    template))

(define (load-package package)
  (cond ((not (package-loaded? package))
         (for-each (lambda (struct)
                     (load-package (structure-package struct)))
                   (package-opens package))
         ;; Ignore the return value?
         (invoke-package package compile-package)
         (set-package-loaded?! package #t))))

(define (invoke-package package package->template)
  (with-interaction-environment package
    (lambda ()
      (invoke-closure (make-closure (package->template package)
                                    (package-uid package))))))

;;;; Expansion

;;; This uses an instrumented compiler environment to cache a mapping
;;; from locations to the qualified names used to obtain them.  The
;;; fasdumper includes this mapping in the dump so that the fasloader
;;; can then know how to resolve locations dumped in the compiled code
;;; (which are just dumped using their names).
;;;
;;; The 'obvious' way to do this -- to avoid locations at all by not
;;; calling LINK! before fasdumping and then to just use the compiler's
;;; 'thingies' (unresolved global reference tokens) -- won't work for a
;;; silly reason and a significant reason.  The silly reason is that
;;; the system doesn't provide access to the THINGIES structure, and
;;; the significant reason is due to macros: the compiled code for
;;; macros must be available fully linked before the rest of the code
;;; can be compiled.  We could theoretically separate expansion all the
;;; way up the reflective tower -- and generate .sce0, .sce1, &c.,
;;; files --, but that would be absurd; this is pretty simple way.

(define (expand-package-from-source package)
  (create-package-location-map package)
  (let* ((table (package-location-map package))
         (cenv (instrument-compiler-env package table)))
    ;; I'm not entirely sure whether this is necessary or whether it is
    ;; a good idea at all.
    (set-package->environment! package cenv)
    (let ((expanded-forms
           (optimize-forms (expand-package-source package cenv)
                           package)))
      ;; This must come after the forms are expanded and the new
      ;; bindings are added.
      (for-each-definition (lambda (name binding)
                             (let ((static (binding-static binding)))
                               (if (transform? static)
                                   (probe-aux-names name static
                                                    cenv table))))
                           package)
      expanded-forms)))

(define (set-package->environment! package cenv)
  ;++ Hurk, spew, ralph.
  (record-set! package 10 cenv))

(define (instrument-compiler-env package table)
  (let ((cenv (package->environment package)))
    (make-compiler-env (lambda (name)
                         (let ((probe (lookup cenv name)))
                           (cache-binding name probe cenv table)
                           probe))
                       (lambda (name type . maybe-value)
                         (apply environment-define! cenv name type
                                maybe-value))
                       (instrument-reflective-tower table package cenv)
                       package)))

(define (optimize-forms expanded-forms package)
  ((get-optimizer (package-optimizer-names package))
   expanded-forms
   package))

(define (cache-binding name probe cenv table)
  (if (binding? probe)
      (let ((type (binding-type probe))
            (loc (binding-place probe))
            (static (binding-static probe)))
        (if loc
            (let ((old (table-ref table loc))
                  (new (cons (name->qualified name cenv)
                             type)))
              (cond ((not old)
                     (table-set! table loc new)
                     (if (transform? static)
                         (probe-aux-names name static cenv table)))
                    ((not (compatible? old new))
                     (warn "location has two incompatible bindings"
                           old
                           new
                           '(ignoring new one)))))))))

(define (compatible? a b)
  (and ;; (equal? (car a) (car b))
       (or (compatible-types? (cdr a) (cdr b)) ;++ hack, probably bogus
           (compatible-types? (cdr b) (cdr a)))))

(define (probe-aux-names name static cenv table)
  (cond ((transform-aux-names static)
         => (lambda (aux-names)
              (let ((t-cenv (package->environment
                             (transform-env static))))
                (for-each (lambda (aux-name)
                            (cache-binding
                             (generate-name aux-name cenv name)
                             (lookup t-cenv aux-name)
                             cenv
                             table))
                          aux-names))))
        (else
         (warn "transform without auxiliary name list"
               static))))

(define (instrument-reflective-tower table package cenv)
  (delay
    (let* ((tower (force (environment-macro-eval cenv)))
           (next-env (cdr tower)))
      (cons (car tower)
            (if (not (package? next-env))
                ;; Not sure why it might not be a package, but just in
                ;; case...
                next-env
                (let* ((next-cenv (package->environment next-env))
                       (replacement
                        (make-simple-package
                         (make-opens-for-tower next-env)
                         #t             ; unstable
                         (instrument-reflective-tower table next-env
                                                      next-cenv))))
                  (set-package->environment!
                   replacement
                   (instrument-compiler-env replacement table))
                  replacement))))))

(define (make-opens-for-tower package)
  (let ((names '()))
    (for-each-definition (lambda (name binding)
                           (set! names
                                 (cons (list name
                                             (binding-type binding))
                                       names)))
                         package)
    (cons (make-structure package (make-simple-interface #f names))
          (package-opens package))))

;;;;; Expanding Package Source

;;; Roughly equivalent to the code in bcomp/comp-package.scm, but that
;;; code is not exported to the public.

(define (expand-package-source package cenv)
  (receive (files+forms transforms needs-primitives?)
           (package-source package)
    (for-each (lambda (name)
                (define-usual-transform package cenv name))
              transforms)
    (let ((cenvs+scanned (scan-package-source files+forms cenv
                                              needs-primitives?)))
      (reverse
       (fold (lambda (cenv.scanned expanded)
               (fold (let ((cenv (car cenv.scanned)))
                       (lambda (form expanded)
                         (cons (delay (expand-scanned-form form cenv))
                               expanded)))
                     (cdr cenv.scanned)
                     expanded))
             cenvs+scanned
             '())))))

(define (scan-package-source files+forms cenv needs-primitives?)
  (map (lambda (file.forms)
         (let ((cenv (bind-source-file-name (car file.forms)
                                            cenv)))
           (cons cenv (scan-forms (cdr file.forms) cenv))))
       (if needs-primitives?
           (cons (cons #f (define-primitives! cenv))
                 files+forms)
           files+forms)))

(define (define-usual-transform package cenv name)
  (environment-define! cenv name syntax-type
                       (make-transform (usual-transform name)
                                       package
                                       syntax-type
                                       `(USUAL-TRANSFORM ',name)
                                       name)))

(define (define-primitives! cenv)
  (table-walk (lambda (name op)
                (let ((type (operator-type op)))
                  (if (not (eq? type 'leaf))
                      (environment-define! cenv name type
                                           op))))
              operators-table)
  (let ((defs '()))
    (walk-primops (lambda (name type primop)
                    (environment-define! cenv name type primop)
                    (set! defs
                          (cons (make-primitive-definition name cenv)
                                defs))))
    defs))

(define (make-primitive-definition name cenv)
  (make-node operator/define
             `(DEFINE ,(expand name cenv)
                      ,(make-node operator/primitive-procedure
                                  `(PRIMITIVE-PROCEDURE ,name)))))

(define operator/define (get-operator 'DEFINE syntax-type))
(define operator/primitive-procedure
        (get-operator 'PRIMITIVE-PROCEDURE syntax-type))