From: Chris Hanson Date: Mon, 24 Apr 2017 00:15:05 +0000 (-0700) Subject: Refactor make-sequence-builder and add vector-builder. X-Git-Tag: mit-scheme-pucked-9.2.12~153^2~17 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=54a600601fcac2921be7fc9f51aa60526a41d319;p=mit-scheme.git Refactor make-sequence-builder and add vector-builder. --- diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm index 4cbecc02c..95c310b24 100644 --- a/src/runtime/bytevector.scm +++ b/src/runtime/bytevector.scm @@ -113,33 +113,14 @@ USA. ((ucode-primitive string-hash) bytevector) ((ucode-primitive string-hash-mod) bytevector modulus))) -(define (bytevector-builder) - (let ((builder - (make-sequence-builder allocate-bytevector - bytevector-length - bytevector-u8-ref - bytevector-u8-set! - (lambda (bv) bv) - 16 - bytevector-builder:finish-build))) - (lambda (#!optional object) - (cond ((default-object? object) ((builder 'build))) - ((byte? object) ((builder 'append-element!) object)) - ((bytevector? object) ((builder 'append-sequence!) object)) - ((memq object '(empty? count reset!)) ((builder object))) - (else (error "Not a byte or bytevector:" object)))))) - -(define (bytevector-builder:finish-build parts) - (let ((result - (do ((parts parts (cdr parts)) - (n 0 (fix:+ n (cdar parts)))) - ((not (pair? parts)) - (allocate-bytevector n))))) - (do ((parts parts (cdr parts)) - (i 0 (fix:+ i (cdar parts)))) - ((not (pair? parts))) - (bytevector-copy! result i (caar parts) 0 (cdar parts))) - result)) +(define (bytevector-builder #!optional buffer-length) + (make-sequence-builder u8? bytevector? allocate-bytevector bytevector-length + bytevector-u8-set! bytevector-copy! + (if (default-object? buffer-length) + 16 + (begin + (guarantee positive-fixnum? buffer-length 'bytevector-builder) + buffer-length)))) (define (list->bytevector bytes) (let ((bytevector (allocate-bytevector (length bytes)))) diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 1ab2a8357..dc9b9fd97 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -580,69 +580,76 @@ USA. ;;;; Builder for vector-like sequences -(define (make-sequence-builder make-sequence sequence-length sequence-ref - sequence-set! sequence-copy buffer-length - finish-build) - ;; This is optimized to minimize copying, so it wastes some space. +(define (make-sequence-builder elt? seq? make-seq seq-length seq-set! seq-copy! + buffer-length) (let ((buffers) (buffer) - (index)) + (start) + (index) + (count)) (define (reset!) (set! buffers '()) - (set! buffer (make-sequence buffer-length)) + (set! buffer (make-seq buffer-length)) + (set! start 0) (set! index 0) + (set! count 0) unspecific) - (define (new-buffer!) - (set! buffers (cons (cons buffer index) buffers)) - (set! buffer (make-sequence buffer-length)) - (set! index 0) - unspecific) - - (define (empty?) - (and (fix:= 0 index) - (null? buffers))) - - (define (count) - (do ((buffers buffers (cdr buffers)) - (n 0 (fix:+ n (cdr (car buffers))))) - ((not (pair? buffers)) (fix:+ n index)))) - - (define (append-element! element) - (if (not (fix:< index buffer-length)) - (new-buffer!)) - (sequence-set! buffer index element) + (define (append-elt! elt) + (seq-set! buffer index elt) (set! index (fix:+ index 1)) - unspecific) - - (define (append-sequence! sequence) - (let ((length (sequence-length sequence))) - (if (fix:<= length buffer-length) - (do ((i 0 (fix:+ i 1))) - ((not (fix:< i length))) - (append-element! (sequence-ref sequence i))) + (set! count (fix:+ count 1)) + (if (not (fix:< index buffer-length)) + (begin + (set! buffers (cons (get-partial) buffers)) + (set! buffer (make-seq buffer-length)) + (set! start 0) + (set! index 0) + unspecific))) + + (define (append-seq! seq) + (let ((length (seq-length seq))) + (if (fix:> length 0) (begin - (if (fix:> index 0) - (new-buffer!)) - (set! buffers - (cons (cons (sequence-copy sequence) length) - buffers)) + (if (fix:> index start) + (begin + (set! buffers (cons (get-partial) buffers)) + (set! start index))) + (set! buffers (cons (vector seq 0 length) buffers)) + (set! count (fix:+ count length)) unspecific)))) (define (build) - (finish-build (reverse (cons (cons buffer index) buffers)))) + (let ((result (make-seq count))) + (do ((parts (reverse + (if (fix:> index start) + (cons (get-partial) buffers) + buffers)) + (cdr parts)) + (i 0 + (let ((v (car parts))) + (let ((start (vector-ref v 1)) + (end (vector-ref v 2))) + (seq-copy! result i (vector-ref v 0) start end) + (fix:+ i (fix:- end start)))))) + ((not (pair? parts)))) + result)) + + (define (get-partial) + (vector buffer start index)) (reset!) - (lambda (operator) - (case operator - ((append-element!) append-element!) - ((append-sequence!) append-sequence!) - ((build) build) - ((empty?) empty?) - ((count) count) - ((reset!) reset!) - (else (error "Unknown operator:" operator)))))) + (lambda (#!optional object) + (cond ((default-object? object) (build)) + ((elt? object) (append-elt! object)) + ((seq? object) (append-seq! object)) + (else + (case object + ((empty?) (fix:= count 0)) + ((count) count) + ((reset!) (reset!)) + (else (error "Unsupported argument:" object)))))))) ;;;; Ephemerons diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 0d30485dc..2cad4fedc 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -779,6 +779,7 @@ USA. vector->list vector-append vector-binary-search + vector-builder vector-copy vector-copy! vector-eighth diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm index 9b20aca08..58fd6b983 100644 --- a/src/runtime/vector.scm +++ b/src/runtime/vector.scm @@ -59,6 +59,15 @@ USA. (error:wrong-type-argument size "vector index" 'MAKE-VECTOR)) ((ucode-primitive vector-cons) size (if (default-object? fill) #f fill))) +(define (vector-builder #!optional buffer-length) + (make-sequence-builder any-object? vector? make-vector vector-length + vector-set! vector-copy! + (if (default-object? buffer-length) + 16 + (begin + (guarantee positive-fixnum? buffer-length 'vector-builder) + buffer-length)))) + (define (vector->list vector #!optional start end) (subvector->list vector (if (default-object? start) 0 start)