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

;;;; Compiled Code Storage for Scheme48
;;;; Bundles Fasdumper

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

(define (dump-bundle filespec definitions auxiliary-structures)
  (let ((fasdump-port (make-block-fasdump-port usual-fasl-encoder)))
    (fasdump-bundle definitions auxiliary-structures fasdump-port)
    (call-with-output-file (bundle-file-name filespec)
      (lambda (output-port)
        (write-block-fasdump! fasdump-port output-port)))))

(define (fasdump-bundle definitions auxiliary-structures fasdump-port)
  (let* ((structures (extract-bundled-structures definitions
                                                 auxiliary-structures))
         ;; We could just do (MAP STRUCTURE-PACKAGE STRUCTURES) here,
         ;; but we must topologically sort it at some point so that the
         ;; loader gets the packages in the right order, and
         ;; COLLECT-PACKAGES sorts it for us.
         (packages (collect-packages structures
                     (let ((packages (map structure-package
                                          structures)))
                       (lambda (package)
                         (memq package packages))))))
    (for-each compile-package packages)
    (with-fasdump-port-encoder-selector fasdump-port
        bundle-fasl-encoder
      (lambda ()
        (let-fluid $bundled-structures structures
          (lambda ()
            (fasdump-definitions definitions fasdump-port)
            (fasdump-packages packages fasdump-port)))))))

(define $bundled-structures (make-fluid #f))

(define (make-definition name value) (cons name value))
(define (definition-name definition) (car definition))
(define (definition-value definition) (cdr definition))

(define (extract-bundled-structures definitions structures)
  (if (null? definitions)
      structures
      (extract-bundled-structures
       (cdr definitions)
       (let ((value (definition-value (car definitions))))
         (if (structure? value)
             (cons value structures)
             structures)))))

(define (fasdump-definitions definitions port)
  (for-each (lambda (definition)
              (fasdump (definition-name definition) port)
              (fasdump (definition-value definition) port))
            definitions)
  (fasdump #f port))

(define (fasdump-packages packages port)
  (for-each (lambda (package)
              (fasdump package port)
              (fasdump-package package port))
            packages)
  (fasdump #f port))

(define (fasdump-package package port)
  (fasdump-package-bindings package port)
  (fasdump-package-template package port)
  (fasdump-package-debug-data package port))

(define (bundle-fasl-encoder obj)
  (cond ((structure? obj) (values #f 'STRUCTURE structure-fasl-encoder))
        ((interface? obj) (values #f 'INTERFACE interface-fasl-encoder))
        ((package?   obj) (values #f 'PACKAGE     package-fasl-encoder))
        (else             (usual-fasl-encoder obj))))

(define structure-fasl-encoder
  (lambda (structure port)
    (fasdump (structure-interface structure) port)
    (fasdump (structure-package structure) port)))

(define interface-fasl-encoder
  (lambda (interface port)
    (for-each-declaration (lambda (external-name internal-name type)
                            (fasdump external-name port)
                            (fasdump internal-name port)
                            (fasdump (if (eq? type undeclared-type)
                                         #f
                                         (type->sexp type #t))
                                     port))
                          interface)
    (fasdump #f port)))

(define package-fasl-encoder
  (lambda (package port)
    (fasdump (package-name package) port)
    (for-each (lambda (open)
                (fasdump (make-structure-reference open) port))
              (reverse (package-opens package)))
    (fasdump #f port)
    (for-each (lambda (access)
                (fasdump (car access) port)
                (fasdump (make-structure-reference (cdr access)) port))
              (reverse (package-accesses package)))
    (fasdump #f port)
    (fasdump (package-unstable? package) port)
    (fasdump (package-file-name package) port)     ;** Hmmm...
    (fasdump (package-clauses package) port)))

;;; Random utilities

(define (any predicate list)
  (and (pair? list)
       (or (predicate (car list))
           (any predicate (cdr list)))))

(define (append-map fn list)
  (if (null? list)
      '()
      (append (fn (car list))
              (append-map fn (cdr list)))))

(define (make-structure-reference structure)
  (cond ((memq structure (fluid $bundled-structures))
         structure)
        ((structure-name structure))
        ((structure-modifier structure))
        (else
         (error "unable to store reference to anonymous structure"
                structure))))

;++ This is a heuristic crock.

(define (structure-modifier struct)
  (and-let* ((package (structure-package struct))
             (name (package-name package))
             (binding (package-lookup (config-package) name))
             ((not (eq? (binding-type binding) syntax-type)))
             (loc (binding-place binding))
             ((location? loc))
             ((location-defined? loc))
             (obj (contents loc))
             ((not (eq? obj struct)))   ; Probably unnecessary.
             ((structure? obj))
             ((eq? (structure-package obj) package)))
    (receive (exported renamed)
             (decompose-modified-interface
              (structure-interface struct))
      `(MODIFIED ,name
                 ,(make-simple-interface #f exported)
                 ,@renamed))))

(define (decompose-modified-interface interface)
  (let ((exported '())
        (renamed '()))
    (for-each-declaration (lambda (name base-name type)
                            (set! exported
                                  (cons (if (eq? type undeclared-type)
                                            base-name
                                            (list base-name type))
                                        exported))
                            (if (not (eq? name base-name))
                                (set! renamed
                                      (cons (list base-name name)
                                            renamed))))
                          interface)
    (values exported renamed)))