;; -*- geiser-scheme-implementation: guile -*-

;; Copyright 2019 Christopher Howard

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

(define-module (buffer repository))

(use-modules (oop goops)
             (rnrs bytevectors))

(export %buffer-repository
        checkout-buffer!
        checkin-buffer!
        make-buffer-repository)

(define-class <buffer-repository> ()
  #| a vector with a bucket for each size of buffer that can be checked out |#
  (buffer-buckets #:accessor buffer-buckets)
  (buffer-bucket-sizes #:accessor buffer-bucket-sizes)
  #| the smallest buffer size that can be checked out is 2^smallest-power |#
  (smallest-power #:accessor smallest-power))

(define access-vector (make-procedure-with-setter vector-ref vector-set!))

(define (make-buffer-repository smallest-pwr largest-pwr)
  "Make a buffer repository instance. Parameters refer to the sizes of buffers
 stored in the repository. The smallest size is 2 to the smallest-pwr, the
 largest is 2 to the largest-pwr."
  (define b (make <buffer-repository>))
  (let ((buckets-needed (- largest-pwr smallest-pwr -1)))
    (set! (buffer-buckets b) (make-vector buckets-needed '()))
    (set! (buffer-bucket-sizes b) (make-vector buckets-needed))
    (let l ((current-bucket-index 0))
      (unless (equal? current-bucket-index buckets-needed)
        (set! (access-vector (buffer-bucket-sizes b) current-bucket-index)
          (expt 2 (+ current-bucket-index smallest-pwr)))
        (l (1+ current-bucket-index))))
    (set! (smallest-power b) smallest-pwr))
  b)

(define (determine-bucket-index buffer-repository requested-bytes)
  (let l ((bucket-index 0))
    (cond ((equal? bucket-index (vector-length (buffer-buckets buffer-repository)))
           (throw 'no-match))
          ((<= requested-bytes (access-vector (buffer-bucket-sizes buffer-repository) bucket-index))
           bucket-index)
          (else (l (1+ bucket-index))))))

(define (detach-buffer! buffer-repository bucket-index)
  (let ((bucket (access-vector (buffer-buckets buffer-repository) bucket-index)))
    (cond ((null? bucket)
           (throw 'buffer-bucket-empty))
          (else
           (let ((buffer (car bucket)))
             (set! (access-vector (buffer-buckets buffer-repository) bucket-index)
               (cdr bucket))
             buffer)))))

(define (attach-buffer! buffer-repository bucket-index buffer)
  (cond ((not (equal? (bytevector-length buffer)
                       (access-vector (buffer-bucket-sizes buffer-repository) bucket-index)))
         (throw 'buffer-bucket-mismatch))
        (else
         (let ((bucket (access-vector (buffer-buckets buffer-repository) bucket-index)))
           (set! (access-vector (buffer-buckets buffer-repository) bucket-index) (cons buffer bucket))
           (if #f #f)))))

(define %buffer-repository (make-parameter (make-buffer-repository 8 24)))

(define* (checkout-buffer! requested-bytes #:optional (buffer-repository (%buffer-repository)) #:key (spawn #t))
  "Checkout a buffer (bytevector) from the buffer-repository. If
 buffer-repository is not specified, parameter %buffer-repository is
 used. The default action, if a buffer is not available from the
 appropriate size bucket, is to generate a new buffer. If #:spawn #f is
 passed, checkout-buffer! will throw the 'empty-bucket exception
 instead. The buffer returned might be larger than the number of bytes
 requested. A 'no-match exception will be thrown if the size-requested
 is not in the range of buffer sizes stored by the buffer-repository."
  (let* ((bucket-index (determine-bucket-index buffer-repository requested-bytes))
         (buckets (buffer-buckets buffer-repository))
         (bucket (vector-ref buckets bucket-index))
         (bucket-size (vector-ref (buffer-bucket-sizes buffer-repository) bucket-index)))
    (cond ((and (null? bucket) (not spawn))
           (throw 'empty-bucket))
          ((null? bucket)
           (make-bytevector bucket-size))
          (else
           (detach-buffer! buffer-repository bucket-index)))))

(define* (checkin-buffer! buffer #:optional (buffer-repository (%buffer-repository)))
  "Return a buffer (bytevector) to the buffer-repository. If
 buffer-repository is not specified, parameter %buffer-repository is
 used. It is the responsibility of the calling code not to use the
 buffer after it has been checked in. Technically the buffer does not
 have to be one that was originally checked-out from the
 buffer-repository, but checkin-buffer will throw exceptions if the
 buffer is not the proper size to fit in a repository bucket."
  (let ((bucket-index (determine-bucket-index buffer-repository (bytevector-length buffer))))
    #| assumes attach-buffer! with throw if length is not exact |#
    (attach-buffer! buffer-repository bucket-index buffer)))