;;; -*- Mode: Scheme; scheme48-package: bundle-fasloader -*-

;;;; Compiled Code Storage for Scheme48
;;;; Bundle Fasloader

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

(define (load-bundle filespec)
  (call-with-input-file (bundle-file-name filespec)
    (lambda (input-port)
      (fasload-bundle (open-block-fasload-port input-port
                                               usual-fasl-decoder)))))

(define (fasload-bundle port)
  (with-fasload-port-decoder-selector port bundle-fasl-decoder
    (lambda ()
      (let ((structures (fasload-bundle-definitions port)))
        (fasload-bundle-packages port)
        (for-each check-structure structures)))))

(define (fasload-bundle-definitions port)
  (let loop ((structures '()))
    (let ((name (fasload port)))
      (if (not name)
          structures
          (let ((value (fasload port)))
            (environment-define! (config-package) name value)
            (cond ((structure? value)
                   (note-structure-name! value name)
                   (loop (cons value structures)))
                  ((interface? value)
                   (note-interface-name! value name)
                   (loop structures))
                  (else
                   (loop structures))))))))

(define (fasload-bundle-packages port)
  (let loop ()
    (cond ((fasload port)
           => (lambda (package)
                (for-each (lambda (struct)
                            (load-package (structure-package struct)))
                          (package-opens package))
                (fasload-package package port)
                (load-package package)
                (loop))))))

(define (fasload-package package port)
  (fasload-package-bindings package port)
  (fasload-package-template package port)
  (fasload-package-debug-data package port))

(define (bundle-fasl-decoder key)
  (case key
    ((STRUCTURE) structure-fasl-decoder)
    ((INTERFACE) interface-fasl-decoder)
    ((PACKAGE)     package-fasl-decoder)
    (else (usual-fasl-decoder key))))

(define structure-fasl-decoder
  (lambda (port register)
    (let* ((interface (fasload port))
           (package (fasload port))
           (structure (make-structure package interface)))
      (register structure)
      structure)))

(define interface-fasl-decoder
  (lambda (port register)
    (receive (exports renames) (fasload-interface port)
      (let* ((simple (make-simple-interface #f exports))
             (interface (if (null? renames)
                            simple
                            ((make-modified-interface-maker
                              `((RENAME ,@renames)))
                             simple))))
        (register interface)
        interface))))

(define (fasload-interface port)
  (let loop ((exports '())
             (renames '()))
    (let ((external-name (fasload port)))
      (if (not external-name)
          (values exports renames)
          (let* ((internal-name (fasload port))
                 (type (cond ((fasload port)
                              => (lambda (sexp)
                                   (sexp->type sexp #t)))
                             (else undeclared-type))))
            (loop (cons (list internal-name type) exports)
                  (if (eq? internal-name external-name)
                      renames
                      (cons (list internal-name external-name)
                            renames))))))))

(define package-fasl-decoder
  (lambda (port register)
    (let* ((name (fasload port))
           (opens (fasload-opens port))
           (accesses (fasload-accesses port))
           (unstable? (fasload port))
           (file-name (fasload port))
           (clauses (fasload port))
           (package (make-fasloaded-package opens accesses unstable?
                                            file-name clauses name)))
      (register package)
      package)))

(define (fasload-opens port)
  (let loop ((opens '()))
    (let ((open (fasload port)))
      (if (not open)
          opens
          (loop (cons open opens))))))

(define (fasload-accesses port)
  (let loop ((accesses '()))
    (let ((name (fasload port)))
      (if (not name)
          accesses
          (loop (cons (cons name (fasload port)) accesses))))))

(define (make-fasloaded-package opens accesses unstable?
                                file-name clauses name)
  (make-package (lambda ()              ;** Delay resolution!
                  (map resolve-structure-reference opens))
                (lambda ()
                  (map (lambda (access)
                         (cons (car access)
                               (resolve-structure-reference
                                (cdr access))))
                       accesses))
                unstable?
                (make-reflective-tower clauses name)
                file-name
                clauses
                #f                      ; uid
                name))

(define (resolve-structure-reference reference)
  (cond ((structure? reference) reference)
        ((symbol? reference) (get-structure reference))
        ((and (pair? reference)
              (eq? (car reference) 'MODIFIED))
         (destructure (( (name interface . renames) (cdr reference)))
           (let ((structure (make-structure (structure-package
                                             (get-structure name))
                                            interface)))
             (if (null? renames)
                 structure
                 (make-modified-structure structure
                                          `((RENAME ,@renames)))))))
        (else
         (error "invalid structure reference" reference))))

(define (make-reflective-tower clauses name)
  ((environment-ref (config-package)    ;** hack
                    (string->symbol ".make-reflective-tower."))
   clauses
   name))