guile-prescheme/ps-compiler/util/expand-vec.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey
;;;
;;;   scheme48-1.9.2/ps-compiler/util/expand-vec.scm
;;;
;;; Vectors of infinite length.  These work as do regular vectors except that
;;; they have no fixed size.  XVECTOR-LENGTH is one more than the highest index
;;; that has been passed to XVECTOR-SET!.
;;;
;;; (MAKE-XVECTOR <fill>)
;;; (XVECTOR-LENGTH <xvec>)
;;; (XVECTOR-REF <xvec> <index>)
;;; (XVECTOR-SET! <xvec> <index> <value>)
;;; (XVECTOR->VECTOR <xvec>)
;;;
;;; The actual record fields are:
;;;  default  - the fill value
;;;  length   - total length of internal vector(s)
;;;  contents - either:
;;;      a: vector of entries, or
;;;      b: vector of vectors of entries, vector has #f's after the last needed
;;;         sub-vector, each sub-vector has length XVEC-MAX-CONTENTS-SIZE
;;;  max      - maximum index used in a XVECTOR-SET!

(define-module (ps-compiler util expand-vec)
  #:use-module (srfi srfi-9)
  #:export (export make-xvector
                   xvector-length
                   xvector-ref
                   xvector-set!
                   xvector-length
                   xvector->vector))

(define-record-type :expanding-vector
  (make-expanding-vector default length contents max)
  expanding-vector?
  (default expanding-vector-default)
  (length expanding-vector-length set-expanding-vector-length!)
  (contents expanding-vector-contents set-expanding-vector-contents!)
  (max expanding-vector-max set-expanding-vector-max!))

(define (make-xvector default)
  (make-expanding-vector default 0 '#() -1))

;; Maximum size of any internal vector

(define xvec-max-contents-size 1024)

;; XVECTOR-LENGTH returns 1 + the maximum index passed to XVECTOR-SET!

(define (xvector-length xvec)
  (+ 1 (expanding-vector-max xvec)))

;; If INDEX points outside current storage, the default is returned, otherwise
;; the value is extracted from the one-or-two-level contents vector.

(define (xvector-ref xvec index)
  (let ((length (expanding-vector-length xvec)))
    (cond ((>= index length)
           (expanding-vector-default xvec))
          ((<= length xvec-max-contents-size)
           (vector-ref (expanding-vector-contents xvec) index))
          (else
           (vector-ref (vector-ref (expanding-vector-contents xvec)
                                   (quotient index xvec-max-contents-size))
                       (remainder index xvec-max-contents-size))))))

;; Same as the above, setting instead of extracting.  INDEX is checked agains
;; the maximum index, and the contents may have to be expanded.

(define (xvector-set! xvec index value)
  (let ((length (expanding-vector-length xvec)))
    (if (> index (expanding-vector-max xvec))
        (set-expanding-vector-max! xvec index))
    (cond ((>= index length)
           (expand-expanding-vector xvec)
           (xvector-set! xvec index value))
          ((<= length xvec-max-contents-size)
           (vector-set! (expanding-vector-contents xvec) index value))
          (else
           (vector-set! (vector-ref (expanding-vector-contents xvec)
                                    (quotient index xvec-max-contents-size))
                        (remainder index xvec-max-contents-size)
                        value)))))

;; Copy an expanding vector into a regular vector.

(define (xvector->vector xvec)
  (let ((new (make-vector (xvector-length xvec))))
    (do ((i 0 (+ i 1)))
        ((>= i (xvector-length xvec)))
      (vector-set! new i (xvector-ref xvec i)))
    new))

;; Expand an expanding vector.  A new length and contents are produced and
;; put in XVEC.  If LENGTH is below the maximum for a contents vector it is
;; doubled in size.  If the two-level structure is being used, a new sub-
;; vector is added to it.

(define (expand-expanding-vector xvec)
  (let ((length   (expanding-vector-length   xvec))
        (contents (expanding-vector-contents xvec))
        (default  (expanding-vector-default  xvec))
        (finish (lambda (length contents)
                  (set-expanding-vector-length!   xvec length)
                  (set-expanding-vector-contents! xvec contents))))
    (if (< length xvec-max-contents-size)
        (let ((new (expand-vector contents default)))
          (finish (vector-length new) new))
        (let ((contents (cond ((= length xvec-max-contents-size)
                               (let ((new (make-vector 4 #f)))
                                 (vector-set! new 0 contents)
                                 new))
                              ((vector-ref contents
                                           (- (vector-length contents) 1))
                               (expand-vector contents #f))
                              (else
                               contents))))
          (vector-set! contents
                       (quotient length xvec-max-contents-size)
                       (make-vector xvec-max-contents-size default))
          (finish (+ length xvec-max-contents-size) contents)))))

;; Make a new vector twice the length of OLD and copy the contents of OLD into
;; it.  DEFAULT is used to fill in the other slots.

(define (expand-vector old default)
  (let* ((length (vector-length old))
         (new (make-vector (if (= 0 length) 4 (* 2 length)) default)))
    (do ((i 0 (+ i 1)))
        ((>= i length))
      (vector-set! new i (vector-ref old i)))
    new))