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

;;;; Compiled Code Storage for Scheme48
;;;; Package Fasdumper

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

(define (fasdump-package-bindings package fasdump-port)
  (if (not (package-early-bound? package))
      (error "package not yet bound" package))
  (with-package-fasdumper package fasdump-port
    (lambda ()
      (for-each-definition
       (lambda (name binding)
         (fasdump name fasdump-port)
         (fasdump (binding-type binding) fasdump-port)
         (fasdump (binding-static binding)
                  fasdump-port))
       package)
      (fasdump #f fasdump-port))))

(define (fasdump-package-template package fasdump-port)
  (let ((template (package-template package)))
    (if (not template)
        (error "package not yet compiled" package))
   (with-package-fasdumper package fasdump-port
     (lambda ()
       (fasdump template fasdump-port)))))

(define (fasdump-package-debug-data package fasdump-port)
  (let ((template (package-template package)))
    (if (not template)
        (error "package not yet compiled" package))
   (with-package-fasdumper package fasdump-port
     (lambda ()
       (fasdump-template-debug-data template fasdump-port)))))

(define (with-package-fasdumper package fasdump-port body)
  (with-fasdump-port-encoder-selector fasdump-port
      package-fasl-encoder
    (lambda ()
      (let-fluid $package package
        body))))

(define (fasdump-writer fasdumper compute-file-name what)
  (lambda (package)
    (let* ((file-name                   ;Check the file name *first*.
            (or (compute-file-name package)
                (error (string-append "no file name for package " what)
                       package)))
           (fasdump-port (make-block-fasdump-port usual-fasl-encoder)))
      (fasdumper package fasdump-port)
      (call-with-output-file file-name
        (lambda (output-port)
          (write-block-fasdump! fasdump-port output-port))))))

(define write-package-bindings-to-file
  (fasdump-writer fasdump-package-bindings
                  package-bindings-file-name
                  "early bindings"))

(define write-package-template-to-file
  (fasdump-writer fasdump-package-template
                  package-template-file-name
                  "template"))

(define write-package-debug-data-to-file
  (fasdump-writer fasdump-package-debug-data
                  package-debug-data-file-name
                  "debug data"))

(define $package (make-fluid #f))

(define (package-fasl-encoder x)
  (cond ((closure?   x) (values #f 'CLOSURE     closure-fasl-encoder))
        ((location?  x) (values #f 'LOCATION   location-fasl-encoder))
        ((template?  x) (values #t 'TEMPLATE   template-fasl-encoder))
        ((generated? x) (values #f 'GENERATED generated-fasl-encoder))
        ((transform? x) (values #t 'TRANSFORM transform-fasl-encoder))
        ((node?      x) (values #f 'NODE           node-fasl-encoder))
        ((operator?  x) (values #f 'OPERATOR   operator-fasl-encoder))
        ((primop?    x) (values #t 'PRIMOP       primop-fasl-encoder))
        ((type?      x) (values #t 'TYPE           type-fasl-encoder))
        ((debug-data? x)
         (values #f 'DEBUG-DATA debug-data-fasl-encoder))
        (else           (usual-fasl-encoder x))))

(define closure-fasl-encoder
  (lambda (closure port)
    (fasdump (closure-template closure) port)
    (fasdump (closure-env closure) port)))

(define location-fasl-encoder
  (lambda (location port)
    (cond ((table-ref (package-location-map (fluid $package))
                      location)
           => (lambda (qname.type)
                (fasdump (location-id location) port)
                (fasdump (car qname.type)       port)
                (fasdump (cdr qname.type)       port)))
          (else
           (error "fasdumping unrecognized location" location)))))

(define template-fasl-encoder
  (lambda (template port)
    (let ((len (template-length template)))
      (fasdump len port)
      (fasdump (template-byte-code template) port)
      (fasdump (template-id        template) port)
      ;; Don't dump the package key or the native code.
      (do ((i template-overhead (+ i 1)))
          ((= i len))
        (fasdump (template-ref template i) port)))))

(define debug-data-fasl-encoder
  (lambda (ddata port)
    (fasdump (debug-data-name ddata) port)
    (fasdump (debug-data-parent ddata) port)
    (fasdump (debug-data-env-maps ddata) port)
    (fasdump (debug-data-source ddata) port)))

(define (fasdump-template-debug-data template port)
  (fasdump (template-debug-data template) port)
  (do ((i template-overhead (+ i 1)))
      ((= i (template-length template)))
    (let ((element (template-ref template i)))
      (if (template? element)
          (fasdump-template-debug-data element port)))))

(define generated-fasl-encoder
  (lambda (generated port)
    (fasdump (name->qualified generated
                              (package->environment (fluid $package)))
             port)))

(define transform-fasl-encoder
  (lambda (transform port)
    (fasdump (transform-id transform) port)
    (fasdump (transform-type transform) port)
    (let ((source (transform-source transform)))
      (if (and (pair? source)           ;++ kludge
               (eq? (car source) 'INLINE-TRANSFORM))
          (destructure (( (inline-transform (quote0 source)
                                            (quote1 aux-names))
                          source))
            (fasdump 'INLINE-TRANSFORM port)
            (fasdump aux-names port)
            (fasdump source port))
          (begin (fasdump (transform-procedure transform) port)
                 (fasdump (transform-aux-names transform) port)
                 (fasdump source port))))))

(define (transform-procedure transform)
  ;++ Hurk, spew, ralph.
  (record-ref transform 1))

(define node-fasl-encoder
  (lambda (node port)
    (fasdump (node-operator node) port)
    (fasdump (node-form node) port)
    (fasdump (node-ref node 'BINDING) port)))

(define operator-fasl-encoder
  (lambda (operator port)
    (fasdump (operator-name  operator) port)
    (fasdump (operator-type  operator) port)))

(define primop-fasl-encoder
  (lambda (primop port)
    (fasdump (primop-name primop) port)))

;++ Crock.  Pick a random type descriptor; take its record type; make a
;++ predicate out of that.

(define type? (record-predicate (record-type error-type)))

(define type-fasl-encoder
  (lambda (type port)
    (fasdump (type->sexp type #t) port)))