;;;;;; Object dumper for Scheme48                        -*- Scheme -*-
;;;;;; Retrieving objects from dumps

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

(define-record-type retriever
  ((port)
   (key-vector)
   (object-vector)
   (decoder))
  ((index 0)))

(define (open-retriever filename decoder)
  (make-retriever (open-input-file filename) decoder))

(define (close-retriever retriever)
  (close-input-port (retriever-port retriever))
  ;; Kill references for GC.
  (set-retriever-port!          retriever #f)
  (set-retriever-key-vector!    retriever #f)
  (set-retriever-object-vector! retriever #f)
  (set-retriever-decoder!       retriever #f))

(define (make-retriever port decoder)
  (check-dump-magic port)
  (let* ((obj-count  (read/careful read-integer port))
         (key-count  (read/careful read-integer port))
         (key-vector (read-key-vector port key-count))
         (obj-vector (make-vector obj-count 'unretrieved-slot)))
    (retriever-maker port key-vector obj-vector decoder)))

(define (check-dump-magic port)
  (let ((magic (read/careful read-integer port)))
    (if (not (= magic dump-magic))
        (error "corrupt dump -- format version difference"
               magic
               `(current is ,dump-magic)
               `(while reading from ,port)))))

(define (read-key-vector port key-count)
  (let ((vec (make-vector key-count)))
    (do ((i 0 (+ i 1)))
        ((= i key-count) vec)
      (let* ((key-length (read/check ok-key-length? read-integer port))
             (key-string (read-string port key-length)))
        (vector-set! vec i (string->symbol key-string))))))

;;; Arbitrary limit.  You should never have to go beyond this.
(define (ok-key-length? len) (< len 1024))

(define (retrieve retriever . maybe-decoder-selector)
  (let* ((port (retriever-port retriever))
         (tag (read/careful read-byte port)))
    (select tag
      ((dump-tag/reference)
       (vector-ref (retriever-object-vector retriever)
                   (read/careful read-integer port)))
      ((dump-tag/shared-header)
       (retrieve-shared retriever port maybe-decoder-selector))
      ((dump-tag/object-header)
       (retrieve-object retriever port ignore maybe-decoder-selector))
      (else
       (error "corrupt dump -- bad dump tag" tag retriever)))))

(define (retrieve/check predicate retriever . maybe-decoder-selector)
  (let ((datum (apply retrieve retriever maybe-decoder-selector)))
    (if (predicate datum)
        datum
        (error
         "corrupt dump -- retrieved datum does not satisfy predicate"
         (list predicate datum)
         retriever))))

(define (retrieve-integer retriever)
  (read-integer (retriever-port retriever)))

(define (retrieve-shared retriever port maybe-decoder-selector)
  (let ((index (retriever-index retriever))
        (obj-vector (retriever-object-vector retriever)))
    (set-retriever-index! retriever (+ index 1))
    (retrieve-object retriever port
                     (lambda (obj)
                       (vector-set! obj-vector index obj))
                     maybe-decoder-selector)))

(define (retrieve-object retriever port register!
                         maybe-decoder-selector)
  (let ((key (vector-ref (retriever-key-vector retriever)
                         (read/careful read-integer port)))
        (decoder-selector (if (null? maybe-decoder-selector)
                              (retriever-decoder retriever)
                              (car maybe-decoder-selector))))
    (cond ((decoder-selector key)
           => (lambda (decoder) (decoder retriever port register!)))
          (else (error "corrupt dump -- unknown encoding key"
                       key retriever)))))

;;; Utility for opening a retriever

(define (call-with-file-retriever filename decoder receiver)
  (call-with-input-file filename
    (lambda (port)
      (receiver (make-retriever port decoder)))))