;;;;;; Object dumper for Scheme48                        -*- Scheme -*-
;;;;;; Dump encoder for usual Scheme data

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

(define (usual-dump-encoder object)
  ;; Order is pretty random in this dispatch...
  (cond ((usual-immediate-dump-key object)
         => (lambda (key) (values #t key ignore)))
        ((and (integer? object) (exact? object))
         (values #t (if (negative? object)
                        'negative-integer
                        'integer)
                 integer-dump-encoder))
        ((pair?         object)
         (values #f 'pair                 pair-dump-encoder))
        ((symbol?       object)
         (values #f 'symbol             symbol-dump-encoder))
        ((vector?       object)
         (values #f 'vector             vector-dump-encoder))
        ((string?       object)
         (values #f 'string             string-dump-encoder))
        ((char?         object)
         (values #t 'char                 char-dump-encoder))
        ((number?       object)
         (values #f 'number             number-dump-encoder))
        ((cell?         object)
         (values #f 'cell                 cell-dump-encoder))
        ((weak-pointer? object)
         (values #f 'weak-pointer weak-pointer-dump-encoder))
        ((byte-vector? object)
         (values #f 'byte-vector   byte-vector-dump-encoder))
        (else (values #f #f #f))))

(define (usual-immediate-dump-key obj)
  (cond ((null?       obj) 'nil)
        ((eq? #t      obj) 'true)
        ((eq? #f      obj) 'false)
        ((eof-object? obj) 'eof)
        ((unspecific? obj) 'unspecific)
        (else #f)))

(define integer-dump-encoder
  (lambda (dumpster integer)
    (dump-integer dumpster (if (negative? integer)
                               (bitwise-not integer)
                               integer))))

(define char-dump-encoder
  (lambda (dumpster char)
    (dump-char dumpster char)))

(define number-dump-encoder
  (lambda (dumpster number)
    ;++ Ugh.
    (dump dumpster (number->string number))))

;;; Macro to force integration.

(define-syntax fixed-d-vector-dump-encoder
  (syntax-rules ()
    ((FIXED-D-VECTOR-DUMP-ENCODER access ...)
     (LAMBDA (DUMPSTER OBJECT)
       (DUMP DUMPSTER (access OBJECT))
       ...))))

(define pair-dump-encoder
  (fixed-d-vector-dump-encoder car cdr))

(define cell-dump-encoder
  (fixed-d-vector-dump-encoder cell-ref))

(define weak-pointer-dump-encoder
  (fixed-d-vector-dump-encoder weak-pointer-ref))

;;; Macro to force integration.

(define-syntax indexed-d-vector-dump-encoder
  (syntax-rules ()
    ((INDEXED-D-VECTOR-DUMP-ENCODER object-size object-elt)
     (LAMBDA (DUMPSTER OBJECT)
       (LET ((SIZE (object-size OBJECT)))
         (DUMP-INTEGER DUMPSTER SIZE)
         (DO ((I 0 (+ I 1)))
             ((= I SIZE))
           (DUMP DUMPSTER (object-elt OBJECT I))))))))

(define vector-dump-encoder
  (indexed-d-vector-dump-encoder vector-length vector-ref))

(define-syntax b-vector-dump-encoder
  (syntax-rules ()
    ((B-VECTOR-DUMP-ENCODER x->block block-size)
     (LAMBDA (DUMPSTER OBJECT)
       (LET* ((BLOCK (x->block OBJECT))
              (SIZE (block-size BLOCK)))
         (DUMP-INTEGER DUMPSTER SIZE)
         (DUMP-BLOCK DUMPSTER BLOCK))))))

(define symbol-dump-encoder
  (b-vector-dump-encoder symbol->string string-length))

(define string-dump-encoder
  (b-vector-dump-encoder (lambda (x) x) string-length))

(define byte-vector-dump-encoder
  (b-vector-dump-encoder (lambda (x) x) byte-vector-length))