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

;;;; Fasloader & Fasdumper
;;;; Usual FASL Encoder

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

(define (usual-fasl-encoder obj)
  (cond ((usual-immediate-fasl-type obj)
         => (lambda (type)
              (values #t type immediate-fasl-encoder)))
        ;; Order of presentation is totally random.
        ((and (integer? obj) (exact? obj))
         (values #t 'INTEGER integer-fasl-encoder))
        ((pair?   obj) (values #f 'PAIR       pair-fasl-encoder))
        ((symbol? obj) (values #f 'SYMBOL   symbol-fasl-encoder))
        ((vector? obj) (values #f 'VECTOR   vector-fasl-encoder))
        ((string? obj) (values #f 'STRING   string-fasl-encoder))
        ((char?   obj) (values #t 'CHAR       char-fasl-encoder))
        ((number? obj) (values #f 'NUMBER   number-fasl-encoder))
        ((cell?   obj) (values #f 'CELL       cell-fasl-encoder))
        ((weak-pointer? obj)
         (values #f 'WEAK-POINTER weak-pointer-fasl-encoder))
        ((byte-vector? obj)
         (values #f 'BYTE-VECTOR byte-vector-fasl-encoder))
        (else
         (values #f #f #f))))

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

(define immediate-fasl-encoder
        (lambda (obj port)
          obj port
          (values)))

(define fasdump-immediate
        (immediate-encoder->fasdumper immediate-fasl-encoder))

(define-syntax define-encoder
  (syntax-rules ()
    ((DEFINE-ENCODER (encoder obj port) fasdumper
       body0
       body1
       ...)
     (BEGIN (DEFINE encoder
                    (LAMBDA (obj port)
                      body0
                      body1
                      ...))
            (DEFINE fasdumper (ENCODER->FASDUMPER encoder))))))

(define-encoder (integer-fasl-encoder integer port) fasdump-integer
  (write-octet (if (negative? integer) #xFF #x00) port)
  (write-fasl-integer (abs integer) port))

(define-encoder (pair-fasl-encoder pair port) fasdump-pair
  (fasdump (car pair) port)
  (fasdump (cdr pair) port))

(define-encoder (symbol-fasl-encoder symbol port) fasdump-symbol
  (write-fasl-string (symbol->string symbol) port))

(define-encoder (vector-fasl-encoder vector port) fasdump-vector
  (let ((length (vector-length vector)))
    (write-fasl-integer length port)
    (do ((i 0 (+ i 1)))
        ((= i length))
      (fasdump (vector-ref vector i) port))))

(define-encoder (string-fasl-encoder string port) fasdump-string
  (write-fasl-string string port))

(define-encoder (char-fasl-encoder char port) fasdump-char
  (write-char char port))

(define-encoder (number-fasl-encoder number port) fasdump-number
  ;++ Ugh.
  (write-fasl-string (number->string number) port))

(define-encoder (cell-fasl-encoder cell port) fasdump-cell
  (fasdump (cell-ref cell) port))

(define-encoder (weak-pointer-fasl-encoder weak-pointer port)
    fasdump-weak-pointer
  (fasdump (weak-pointer-ref weak-pointer) port))

(define-encoder (byte-vector-fasl-encoder bytev port)
    fasdump-byte-vector
  (let ((length (byte-vector-length bytev)))
    (write-fasl-integer length port)
    (write-block bytev 0 length port)))