;;; -*- Mode: Scheme; scheme48-package: usual-fasl-decoder -*-

;;;; Fasloader & Fasdumper
;;;; Usual FASL Decoder

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define (usual-fasl-decoder type)
  (or (usual-immediate-fasl-decoder type)
      (case type
        ((INTEGER)           integer-fasl-decoder)
        ((PAIR)                 pair-fasl-decoder)
        ((SYMBOL)             symbol-fasl-decoder)
        ((VECTOR)             vector-fasl-decoder)
        ((STRING)             string-fasl-decoder)
        ((CHAR)                 char-fasl-decoder)
        ((NUMBER)             number-fasl-decoder)
        ((CELL)                 cell-fasl-decoder)
        ((WEAK-POINTER) weak-pointer-fasl-decoder)
        ((BYTE-VECTOR)   byte-vector-fasl-decoder)
        (else #f))))

(define (usual-immediate-fasl-decoder type)
  (case type
    ((NIL)               nil-fasl-decoder)
    ((TRUE)             true-fasl-decoder)
    ((FALSE)           false-fasl-decoder)
    ((EOF-OBJECT) eof-object-fasl-decoder)
    ((UNSPECIFIC) unspecific-fasl-decoder)
    (else #f)))

(define-syntax define-immediate-decoder
  (syntax-rules ()
    ((DEFINE-IMMEDIATE-DECODER name obj)
     (DEFINE name (LAMBDA (PORT) PORT obj)))))

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

(define integer-fasl-decoder
  (lambda (port)
    (if (zero? (read-octet port))
        (read-fasl-integer port)
        (- (read-fasl-integer port)))))

(define pair-fasl-decoder
  (lambda (port register)
    (let ((pair (cons #f #f)))
      (register pair)
      (set-car! pair (fasload-refusing-eof port))
      (set-cdr! pair (fasload-refusing-eof port))
      pair)))

(define symbol-fasl-decoder
  (lambda (port register)
    (let ((symbol (string->symbol (read-fasl-string port))))
      (register symbol)
      symbol)))

(define vector-fasl-decoder
  (lambda (port register)
    (let* ((length (read-fasl-integer port))
           (vector (make-vector length)))
      (register vector)
      (do ((i 0 (+ i 1)))
          ((= i length))
        (vector-set! vector i (fasload-refusing-eof port)))
      vector)))

(define string-fasl-decoder
  (lambda (port register)
    (let ((string (read-fasl-string port)))
      (register string)
      string)))

(define char-fasl-decoder
  (lambda (port)
    (read-char port)))

(define number-fasl-decoder
  (lambda (port register)
    (let ((string (read-fasl-string port)))
      (cond ((string->number string)
             => (lambda (number)
                  (register number)
                  number))
            (else
             (signal-malformed-fasl port
                                    "invalid fasdumped number string"
                                    string))))))

(define cell-fasl-decoder
  (lambda (port register)
    (let ((cell (make-cell #f)))
      (register cell)
      (cell-set! cell (fasload-refusing-eof port))
      cell)))

(define weak-pointer-fasl-decoder
  (lambda (port register)
    (let ((weak-pointer (make-weak-pointer #f)))
      (register weak-pointer)
      ;** BEGIN HORRIBLE HACK
      ((lap weak-pointer-set! ()
         (protocol 2)
         (pop)
         (stored-object-set! weak-pointer 0 0)
         (return))
       weak-pointer
       (fasload-refusing-eof port))
      ;** END HORRIBLE HACK
      weak-pointer)))

(define byte-vector-fasl-decoder
  (lambda (port register)
    (let* ((length (read-fasl-integer port))
           (bytev (make-byte-vector length 0))
           (count (read-block bytev 0 length port)))
      (cond ((or (eof-object? count)
                 (not (= count length)))
             (signal-end-of-fasl-error port))
            (else
             (register bytev)
             bytev)))))