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

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

;;; See usual-encoder.scm.

(define (usual-dump-decoder key)
  (or (usual-immediate-decoder key)
      (cond ((eq? key 'integer)           integer-dump-decoder)
            ((eq? key 'negative-integer) ninteger-dump-decoder)
            ((eq? key 'pair)                 pair-dump-decoder)
            ((eq? key 'symbol)             symbol-dump-decoder)
            ((eq? key 'vector)             vector-dump-decoder)
            ((eq? key 'char)                 char-dump-decoder)
            ((eq? key 'string)             string-dump-decoder)
            ((eq? key 'number)             number-dump-decoder)
            ((eq? key 'cell)                 cell-dump-decoder)
            ((eq? key 'weak-pointer) weak-pointer-dump-decoder)
            ((eq? key 'byte-vector)   byte-vector-dump-decoder)
            (else #f))))

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

;;; Macro to force integration.

(define-syntax immediate-dump-decoder
  (syntax-rules ()
    ((IMMEDIATE-DUMP-DECODER value)
     (LAMBDA (RETRIEVER PORT REGISTER!) value))))

(define        nil-dump-decoder (immediate-dump-decoder '()))
(define       true-dump-decoder (immediate-dump-decoder #t))
(define      false-dump-decoder (immediate-dump-decoder #f))
(define eof-object-dump-decoder (immediate-dump-decoder (eof-object)))
(define unspecific-dump-decoder (immediate-dump-decoder (unspecific)))

(define integer-dump-decoder
  (lambda (retriever port register!)
    (retrieve-integer retriever)))

(define ninteger-dump-decoder
  (lambda (retriever port register!)
    (bitwise-not (retrieve-integer retriever))))

(define char-dump-decoder
  (lambda (retriever port register!)
    (read/careful read-char port)))

(define number-dump-decoder
  (lambda (retriever port register!)
    (let ((string (retrieve/check string? retriever)))
      (cond ((string->number string)
             => (lambda (number)
                  (register! number)
                  number))
            (else (error "corrupt dump -- invalid dumped number"
                         string
                         retriever))))))

;;; Macro to force integration.

(define-syntax fixed-d-vector-dump-decoder
  (syntax-rules ()
    ((FIXED-D-VECTOR-DUMP-DECODER cons initialize-slot! ...)
     (LAMBDA (RETRIEVER PORT REGISTER!)
       (LET ((OBJ cons))
         (REGISTER! OBJ)
         (initialize-slot! OBJ (RETRIEVE RETRIEVER))
         ...
         OBJ)))))

(define pair-dump-decoder
  (fixed-d-vector-dump-decoder (cons #f #f) set-car! set-cdr!))

(define cell-dump-decoder
  (fixed-d-vector-dump-decoder (make-cell #f) cell-set!))

(define weak-pointer-dump-decoder
  (fixed-d-vector-dump-decoder (make-weak-pointer #f)
                               weak-pointer-set!))

;;; This is used for defining setters for fields that don't have them
;;; built-in, namely closures & weak pointers.  This uses explicit
;;; renaming macros, not SYNTAX-RULES, because the LAP transducer can't
;;; handle the generated names in the output of SYNTAX-RULES macros.
;;; This is used locally to this module anyway, so it doesn't need to
;;; be hygienic.

(define-syntax define-stob-setter
  (lambda (form rename compare)
    (let ((name      (cadr   form))
          (stob-type (caddr  form))
          (index     (cadddr form)))
      `(DEFINE ,name
         (LAP ,name ()
           (PROTOCOL 2)                 ; Two arguments.
           (POP)
           (STORED-OBJECT-SET! ,stob-type ,index
                               0)       ; The 0 tells it not to log in
           (RETURN))))))                ;   the current proposal.

;;; There used to be a stob setter defined for closures, too, but it
;;; was removed after closures, continuations, & templates, were made
;;; undumpable.

(define-stob-setter weak-pointer-set! weak-pointer 0)

;;; Macro to force integration.

(define-syntax indexed-d-vector-dump-decoder
  (syntax-rules ()
    ((INDEXED-D-VECTOR-DUMP-DECODER make-object object-set!)
     (LAMBDA (RETRIEVER PORT REGISTER!)
       (LET* ((SIZE (READ-INTEGER PORT))
              (OBJ (make-object SIZE #F)))
         (REGISTER! OBJ)
         (DO ((I 0 (+ I 1)))
             ((= I SIZE) OBJ)
           (object-set! OBJ I (RETRIEVE RETRIEVER))))))))

;;; Again, there used to be more here, but then (the broken) support
;;; for dumping continuations & templates was removed.

(define vector-dump-decoder
  (indexed-d-vector-dump-decoder make-vector vector-set!))

;;; Macro to force integration.

(define-syntax b-vector-dump-decoder
  (syntax-rules ()
    ((B-VECTOR-DUMP-DECODER make-block block->x)
     (LAMBDA (RETRIEVER PORT REGISTER!)
       (LET* ((SIZE (READ/CAREFUL READ-INTEGER PORT))
              (BLOCK (make-block SIZE))
              (COUNT (READ-BLOCK BLOCK 0 SIZE PORT)))
         (IF (= COUNT SIZE)
             (LET ((RESULT (block->x BLOCK)))
               (REGISTER! RESULT)
               RESULT)
             (ERROR "corrupt dump -- premature EOF"
                    RETRIEVER)))))))

(define symbol-dump-decoder
  (b-vector-dump-decoder make-string string->symbol))

(define string-dump-decoder
  (b-vector-dump-decoder make-string (lambda (x) x)))

(define byte-vector-dump-decoder
  (b-vector-dump-decoder (lambda (size) (make-byte-vector size 0))
                         (lambda (x) x)))