;;;;;; Object dumper for Scheme48                        -*- Scheme -*-
;;;;;; Loading up the dumpster & dumping

;;; Taylor Campbell wrote this code; he places it in the public domain.



;;; --------------------
;;; Loading up the dumpster

(define-record-type dumpster
  (encoder)
  ((output    (make-output-sequence))
   (shared    0)
   (table     (make-object-table))
   (keys      (make-output-sequence))))

(define make-dumpster dumpster-maker)

(define-record-type dump-descriptor
  (key-index
   object)
  ((index #f)))

(define make-dump-descriptor dump-descriptor-maker)

;;; User-exposed dumping routines

(define (dump dumpster object . maybe-encoder-selector)
  ;; The order of stuff done here is badly designed.  The dumpster's
  ;; encoder dispatcher shouldn't be called unless the object, if it's
  ;; not an immediate, will be encoded, i.e. isn't a reference.  But a
  ;; separate dispatcher for immediates would introduce a fair bit of
  ;; complexity.  Maybe next version.
  (receive (immediate? key encoder)
           ((if (null? maybe-encoder-selector)
                (dumpster-encoder dumpster)
                (car maybe-encoder-selector))
            object)
    (if (not key)
        (error "unable to dump object"
               object
               `(into dumpster ,dumpster))
        (let ((key-index
               (output-sequence-position! (dumpster-keys dumpster)
                                          key)))
          (cond (immediate?
                 (dump-tagged dumpster 'immediate key-index)
                 (encoder dumpster object))
                ((table-entry (dumpster-table dumpster) object)
                 => (lambda (desc)
                      (dump-reference dumpster desc)))
                (else
                 (dump-encoded dumpster key-index object encoder)))))))

(define (dump-using-writer dumpster writer)
  (dump-tagged dumpster 'writer writer))

(define (dump-byte dumpster byte)
  (dump-tagged dumpster 'char (ascii->char byte)))

(define (dump-char dumpster char)
  (dump-tagged dumpster 'char char))

(define (dump-block dumpster block)
  (dump-tagged dumpster 'block block))

(define (dump-integer dumpster integer)
  (if (or (negative? integer)
          (inexact? integer))
      (call-error "invalid exact, non-negative integer argument"
                  dump-integer dumpster integer)
      (dump-tagged dumpster 'integer integer)))

;;; Internal dumping routines

(define (dump-tagged dumpster tag value)
  (append-output! (dumpster-output dumpster) (cons tag value)))

(define (dump-reference dumpster desc)
  (cond ((not (dump-descriptor-index desc))
         (set-dump-descriptor-index! desc #t)
         (set-dumpster-shared! dumpster
           (+ (dumpster-shared dumpster) 1))))
  (dump-tagged dumpster 'reference desc))

(define (dump-encoded dumpster key-index object encoder)
  (let ((desc (make-dump-descriptor key-index object)))
    (set-table-entry! (dumpster-table dumpster) object desc)
    (dump-tagged dumpster 'header desc)
    (encoder dumpster object)))



;;; --------------------
;;; Dumping dumpsters' contents

(define (write-dump dumpster port)
  (write-integer dump-magic port)
  (write-integer (dumpster-shared dumpster) port)
  (write-integer (output-sequence-length (dumpster-keys dumpster))
                 port)
  (write-keys dumpster port)
  (let ((index-cell (make-cell 0)))
    (write-object-list dumpster index-cell port)
    ;; Sanity check.  I'm not sure why this is here.
    (if (not (= (cell-ref index-cell) (dumpster-shared dumpster)))
        (error "inconsistent object index & shared count in dumpster"
               `(wrote ,(cell-ref index-cell) shared headers)
               `(expected ,(dumpster-shared dumpster))))))

(define (write-dump-to-file dumpster filename)
  (call-with-output-file filename
    (lambda (port) (write-dump dumpster port))))

(define (write-keys dumpster port)
  (for-each (lambda (key)
              (let ((key-string (symbol->string key)))
                (write-integer (string-length key-string) port)
                (write-string key-string port)))
            (output-sequence->list (dumpster-keys dumpster))))

(define (write-object-list dumpster index-cell port)
  (for-each (lambda (item)
              (let ((tag (car item)) (value (cdr item)))
                ;; VALUE is...
                (cond ((eq? tag 'reference)
                       ;; the dump descriptor to which we refer.
                       (write-reference value port))
                      ((eq? tag 'immediate)
                       ;; the key index.
                       (write-immediate value port))
                      ((eq? tag 'char)
                       ;; the character to write
                       (write-char value port))
                      ((eq? tag 'integer)
                       ;; the integer to write.
                       (write-integer value port))
                      ((eq? tag 'block)
                       ;; the byte vector or string to write.
                       (write-block value 0 (block-length value) port))
                      ((eq? tag 'writer)
                       ;; the procedure to call to write stuff.
                       (value port))
                      ((eq? tag 'header)
                       ;; the dump descriptor whose header we write.
                       (write-header value port index-cell))
                      (else
                       (error "invalid dumped item tag" tag)))))
            (output-sequence->list (dumpster-output dumpster))))

(define (write-reference desc port)
  (write-byte dump-tag/reference port)
  (write-integer (dump-descriptor-index desc) port))

(define (write-immediate key-index port)
  (write-byte dump-tag/object-header port)
  (write-integer key-index port))

(define (write-header desc port index-cell)
  (cond ((dump-descriptor-index desc)
         (write-byte dump-tag/shared-header port)
         (let ((index (cell-ref index-cell)))
           (set-dump-descriptor-index! desc index)
           (cell-set! index-cell (+ index 1))))
        (else
         (write-byte dump-tag/object-header port)))
  (write-integer (dump-descriptor-key-index desc) port))

;;; Utilities for opening dumpsters

(define (call-with-file-dumpster filename encoder receiver)
  (call-with-dumpster write-dump-to-file filename encoder receiver))

(define (call-with-port-dumpster port encoder receiver)
  (call-with-dumpster write-dump port encoder receiver))

(define (call-with-dumpster write destination encoder receiver)
  (let ((dumpster (make-dumpster encoder)))
    (receive vals (receiver dumpster)
      (write dumpster destination)
      (apply values vals))))