;;;;;; Object dumper for Scheme48                        -*- Scheme -*-
;;;;;; Various utilities used in the object dumper

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

(define (write-byte byte port)
  (write-char (ascii->char (bitwise-and byte #xFF)) port))

(define (read-byte port)
  (char->ascii (read/careful read-char port)))

;;; Integers are encoded as little-endian sequences of bytes whose
;;; seventh bit, zero-indexed, is unset, and a terminating byte whose
;;; seventh bit is set.

(define (write-integer integer port)
  (do ((integer integer (arithmetic-shift integer -7)))
      ((< integer #x80)   ;(zero? (arithmetic-shift integer -7))
       (write-byte (adjoin-bits 1 integer 7) port))
    (write-byte (bitwise-and integer #x7F) port)))

(define (read-integer port)
  (let loop ((integer 0) (width 0))
    (let ((byte (read/careful read-byte port)))
      (if (zero?                        ;(bit-set? 7 byte)
           (bitwise-and byte #x80))
          (loop (adjoin-bits byte integer width) (+ width 7))
          (adjoin-bits (bitwise-and byte #x7F)
                       integer width)))))

(define (read/careful reader port)
  (let ((datum (reader port)))
    (if (eof-object? datum)
        (error "corrupt dump -- premature EOF"
               (list reader port))
        datum)))

(define (read/check pred reader port)
  (let ((datum (read/careful reader port)))
    (if (pred datum)
        datum
        (error "corrupt dump -- invalid datum read"
               datum
               (list reader port)))))

(define (read-string port size)
  (let* ((string (make-string size))
         (count (read-block string 0 size port)))
    (if (= count size)
        string
        (error "corrupt dump -- premature EOF" port))))

(define-syntax select
  (syntax-rules (ELSE)
    ((SELECT (key ...) clause ...)
     (LET ((K (key ...)))
       (SELECT K clause ...)))
    ((SELECT key
       ((datum ...) body1 body2 ...)
       more ...)
     ;+++ EQ? on integers bad for pedantic correctness, but good for
     ;+++ speed.
     (IF (OR (EQ? key datum) ...)
         (BEGIN body1 body2 ...)
         (SELECT key more ...)))
    ((SELECT key (ELSE body1 body2 ...))
     (BEGIN body1 body2 ...))))

(define (block-length block)
  (cond ((byte-vector? block)
         (byte-vector-length block))
        ((string? block)
         (string-length block))
        (else
         (call-error "invalid argument"
                     block-length
                     block))))

(define (ignore . args) (values))

(define (unspecific? x) (eq? x (unspecific)))

;;; Adjoins two bit fields at WIDTH.

(define (adjoin-bits high low width)
  (bitwise-ior (arithmetic-shift high width) low))



;;; --------------------
;;; Output sequences

(define-record-type output-sequence
  (front
   (tail))
  ((length 0)))

(define (make-output-sequence)
  (let ((cell (cons 'sentinel '())))
    (output-sequence-maker cell cell)))

(define (append-output! out-seq object)
  (let ((cell (cons object '())))
    (set-cdr! (output-sequence-tail out-seq) cell)
    (set-output-sequence-tail! out-seq cell)
    (set-output-sequence-length! out-seq
      (+ (output-sequence-length out-seq) 1))))

(define (output-sequence->list out-seq)
  (cdr (output-sequence-front out-seq)))

(define (output-sequence-position! out-seq elt)
  (let ((front (output-sequence-front out-seq)))
    (let loop ((list (cdr front)) (lag front) (i 0))
      (cond ((null? list)
             (set-cdr! lag (cons elt '()))
             (set-output-sequence-length! out-seq (+ i 1))
             i)
            ((eq? (car list) elt)
             i)
            (else
             (loop (cdr list) list (+ i 1)))))))