;;; -*- Mode: Scheme; scheme48-package: fasloading -*-

;;;; Fasloader

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

(define (make-fasload-port input-port type data decoder-selector id)
  (make-buffered-input-port fasload-port-handler
                            (make-fasloader input-port type data
                                            decoder-selector
                                            (if (null? id)
                                                #f
                                                (car id)))
                            (make-byte-vector default-buffer-size 0)
                            0 0))

(define-record-type* fasloader
  (make-fasloader input-port
                  type
                  data
                  (decoder-selector)
                  id)
  ())

(define (set-fasload-port-decoder-selector! fasload-port selector)
  ;; Do the update first, so that if an error occurs the call to this
  ;; procedure will remain on the stack, and also any error will not
  ;; leave permanent effects.
  (update-fasl-decoding fasload-port selector)
  (set-fasloader-decoder-selector!
   (guarantee-fasload-port fasload-port)
   selector))

(define (with-fasload-port-decoder-selector fasload-port new-selector
          body)
  (let* ((fasloader (guarantee-fasload-port fasload-port))
         (old-selector (fasloader-decoder-selector fasloader)))
    (dynamic-wind
      (lambda ()
        (set-fasload-port-decoder-selector! fasload-port new-selector))
      body
      (lambda ()
        (set-fasload-port-decoder-selector! fasload-port
                                            old-selector)))))

(define-record-type* fasloader-type
  (make-fasloader-type id
                       reference-loader
                       immediate-loader
                       shared-loader
                       unshared-loader
                       decoding-updater)
  ())

(define-syntax define-fasload-methods
  (syntax-rules ()
    ((DEFINE-FASLOAD-METHODS
       ((proc arg ...) field)
       ...)
     (BEGIN (DEFINE (proc PORT arg ...)
              (LET ((FASLOADER (PORT-DATA PORT)))
                ((field (FASLOADER-TYPE FASLOADER))
                 PORT
                 (FASLOADER-DATA FASLOADER)
                 arg
                 ...)))
            ...))))

(define-fasload-methods
  ((fasload-reference index) fasloader-type-reference-loader)
  ((fasload-immediate decoder-selector)
   fasloader-type-immediate-loader)
  ((fasload-shared decoder-selector) fasloader-type-shared-loader)
  ((fasload-unshared decoder-selector) fasloader-type-unshared-loader)
  ((update-fasl-decoding decoder-selector)
   fasloader-type-decoding-updater))

(define (fasload-port? obj)
  (and (port? obj)
       (fasloader? (port-data obj))))

(define (guarantee-fasload-port obj)
  (if (port? obj)
      (let ((data (port-data obj)))
        (if (fasloader? data)
            data
            (error "invalid fasload port" obj)))
      (error "invalid fasload port" obj)))

;;;; Fasload Entry Points

(define (fasload port . decoder-selector-option)
  (let* ((fasloader (guarantee-fasload-port port))
         (decoder-selector (if (null? decoder-selector-option)
                               (fasloader-decoder-selector fasloader)
                               (car decoder-selector-option))))
    (cond ((read-octet port)
           => (lambda (octet)
                (fasload-dispatch octet port decoder-selector)))
          (else (signal-end-of-fasl port)))))

(define (fasload-refusing-eof port . decoder-selector-option)
  (let* ((fasloader (guarantee-fasload-port port))
         (decoder-selector (if (null? decoder-selector-option)
                               (fasloader-decoder-selector fasloader)
                               (car decoder-selector-option))))
    (cond ((read-octet port)
           => (lambda (octet)
                (fasload-dispatch octet port decoder-selector)))
          (else (signal-end-of-fasl-error port)))))

(define (maybe-fasload port win lose . decoder-selector-option)
  (let* ((fasloader (guarantee-fasload-port port))
         (decoder-selector (if (null? decoder-selector-option)
                               (fasloader-decoder-selector fasloader)
                               (car decoder-selector-option))))
    (cond ((read-octet port)
           => (lambda (octet)
                (win (fasload-dispatch octet port decoder-selector))))
          (else (lose)))))

(define (fasload-dispatch octet port decoder-selector)
  (enum-case fasl-header octet
    ((REFERENCE)
     (fasload-reference port (read-fasl-integer port)))
    ((IMMEDIATE)
     (fasload-immediate port decoder-selector))
    ((SHARED-OBJECT)
     (fasload-shared port decoder-selector))
    ((UNSHARED-OBJECT)
     (fasload-unshared port decoder-selector))))

;;; This way of writing READ-FASL-INTEGER has noticeable speed boosts
;;; in Scheme48 over the obvious way with a local loop, even if it is
;;; lambda-lifted.

(define (read-fasl-integer port)
  (read-fasl-integer-loop port 0 0))

(define (read-fasl-integer-loop port integer width)
  (cond ((read-octet port)
         => (lambda (octet)
              (if (< octet #x80)
                  (read-fasl-integer-loop
                   port
                   (adjoin-bit-field width integer octet)
                   (+ width 7))
                  (adjoin-bit-field width integer
                                    (bitwise-and octet #x7F)))))
        (else (signal-end-of-fasl-error port))))

(define (read-fasl-string port)
  (let* ((length (read-fasl-integer port))
         (string (make-string length))
         (count (read-block string 0 length port)))
    (if (or (eof-object? count)
            (not (= count length)))
        (signal-end-of-fasl port)
        string)))

;;;; Fasload Port Handler

(define fasload-port-handler)

(define (initialize-fasload-ports!)
  (set! fasload-port-handler
        (make-buffered-input-port-handler disclose-fasloader
                                          close-fasloader
                                          fill-fasloader-buffer
                                          fasloader-char-ready?)))

(define (disclose-fasloader fasloader)
  (let ((type-id (fasloader-type-id (fasloader-type fasloader)))
        (id (fasloader-id fasloader)))
    (if id
        (list type-id id)
        (list type-id))))

(define (close-fasloader fasloader)
  (close-input-port (fasloader-input-port fasloader))
  ;++ clobber other fields
  )

(define (fasloader-char-ready? port)
  (let ((ready? (or (< (provisional-port-index port)
                       (provisional-port-limit port))
                    (char-ready? (fasloader-input-port port)))))
    (values (maybe-commit) ready?)))

(define (fill-fasloader-buffer port wait?)
  (let* ((buffer (port-buffer port))
         (count (read-block buffer
                            0
                            (byte-vector-length buffer)
                            (fasloader-input-port (port-data port))
                            wait?)))
    (note-buffer-reuse! port)
    (provisional-set-port-index! port 0)
    (provisional-set-port-limit!
     port
     (if (eof-object? count)
         (begin
           (provisional-set-port-pending-eof?! port #t)
           0)
         count)))
  (maybe-commit))

;;;; Block Fasloading

(define-record-type* fasload-block
  (make-fasload-block objects types (decoders))
  ((index 0)))

(define (open-block-fasload-port input-port decoder-selector . id)
  (receive (shared-count type-count)
           (read-block-fasl-identification input-port)
    (let* ((types (read-block-fasl-types type-count input-port))
           (decoders (compute-block-fasl-decoders types
                                                  decoder-selector)))
      (make-fasload-port input-port
                         block-fasloader-type
                         (make-fasload-block (make-vector shared-count)
                                             types
                                             decoders)
                         decoder-selector
                         id))))

(define (read-block-fasl-identification input-port)
  (let* ((len (string-length fasl-identification))
         (buf (make-string len))
         (count (read-block buf 0 len input-port)))
    (cond ((or (eof-object? count)
               (not (= count len)))
           (signal-malformed-fasl
            input-port
            "premature end of stream before identification"))
          ((not (and (string=? buf fasl-identification)
                     (char=? (read-char input-port)
                             #\newline)))
           (signal-malformed-fasl input-port
                                  "invalid FASL identification string"
                                  buf))
          (else
           (let ((version (read-fasl-integer input-port)))
             (if (and (<= fasl-oldest-version version)
                      (<= version fasl-newest-version))
                 (let* ((shared-count (read-fasl-integer input-port))
                        (type-count (read-fasl-integer input-port)))
                   (values shared-count type-count))
                 (signal-fasl-incompatibility input-port version)))))))

(define (read-block-fasl-types type-count port)
  (let ((types (make-vector type-count)))
    (do ((i 0 (+ i 1)))
        ((= i type-count))
      (vector-set! types i
                   (let* ((len (read-fasl-integer port))
                          (buf (make-string len))
                          (count (read-block buf 0 len port)))
                     (if (= len count)
                         (string->symbol buf)
                         (signal-malformed-fasl
                          port
                          "premature end of stream in type table")))))
    types))

(define block-fasloader-type)

(define (initialize-block-fasloader-type!)
  (set! block-fasloader-type
        (make-fasloader-type 'BLOCK-FASLOADER-PORT
                             block-fasload-reference
                             block-fasload-immediate
                             block-fasload-shared
                             block-fasload-unshared
                             update-block-fasl-decoding)))

(define (block-fasload-reference port block index)
  (let ((objects (fasload-block-objects block)))
    (if (< index (vector-length objects))
        (vector-ref objects index)
        (signal-malformed-fasl port
                               "object reference index out of range"
                               index
                               `(maximum ,(- (vector-length objects)
                                             1))))))

(define (block-fasload-immediate port block select-decoder)
  (decode-block-fasl-datum port block select-decoder
    (lambda (decoder)
      (decoder port))))

(define (block-fasload-shared port block select-decoder)
  (decode-block-fasl-datum port block select-decoder
    (lambda (decoder)
      (decoder port
               (let ((index (fasload-block-index block)))
                 (set-fasload-block-index! block (+ index 1))
                 (lambda (obj)
                   (vector-set! (fasload-block-objects block)
                                index
                                obj)))))))

(define (block-fasload-unshared port block select-decoder)
  (decode-block-fasl-datum port block select-decoder
    (lambda (decoder)
      (decoder port values))))

(define-substitution (decode-block-fasl-datum port block select-decoder
                                              continuation)
  (let ((type-index (read-fasl-integer port))
        (decoders (fasload-block-decoders block)))
    (if (and (<= 0 type-index)
             (< type-index (vector-length decoders))
             (vector-ref decoders type-index))
        (continuation (vector-ref decoders type-index))
        (signal-malformed-fasl port "type index out of range"
                               type-index))))

(define (update-block-fasl-decoding port block decoder-selector)
  (set-fasload-block-decoders! block
                               (compute-block-fasl-decoders
                                (fasload-block-types block)
                                decoder-selector)))

(define (compute-block-fasl-decoders types select-decoder)
  (let* ((length (vector-length types))
         (decoders (make-vector length)))
    (do ((i 0 (+ i 1)))
        ((= i length))
      (vector-set! decoders i (select-decoder (vector-ref types i))))
    decoders))

(initialize-fasload-ports!)
(initialize-block-fasloader-type!)