From: Chris Hanson Date: Sat, 13 Jan 2018 07:16:13 +0000 (-0800) Subject: Do stupid macrology to work around lack of vector-ish open coding. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~372 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1bf1af2bced584d97a06d640bc92f91b49d5a878;p=mit-scheme.git Do stupid macrology to work around lack of vector-ish open coding. --- diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index a8c506021..227379306 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -29,7 +29,8 @@ USA. (declare (usual-integrations)) -;;; These primitives are the building blocks for many other types. +;;;; Low-level structure primitives. + (define-primitives (%make-tagged-object 2) (%record -1) @@ -41,16 +42,33 @@ USA. (%tagged-object-tag 1) (%tagged-object? 1)) -(define (%make-record tag length #!optional init-value) - (let ((record - ((ucode-primitive %make-record 2) - length - (if (default-object? init-value) - #f - init-value)))) - (%record-set! record 0 tag) - record)) - +(define (%make-record tag length #!optional fill) + (let ((fill (if (default-object? fill) #f fill))) + (let-syntax + ((expand-cases + (sc-macro-transformer + (lambda (form use-env) + (declare (ignore use-env)) + (let ((limit (cadr form)) ;must be a power of 2 + (gen-accessor + (lambda (i) + `(%record tag ,@(make-list (- i 1) 'fill))))) + `(if (and (fix:fixnum? length) + (fix:> length 0) + (fix:<= length ,limit)) + ,(let loop ((low 1) (high limit)) + (if (< low high) + (let ((mid (quotient (- (+ high low) 1) 2))) + `(if (fix:<= length ,mid) + ,(loop low mid) + ,(loop (+ mid 1) high))) + (gen-accessor low))) + (let ((record + ((ucode-primitive %make-record 2) length fill))) + (%record-set! record 0 tag) + record))))))) + (expand-cases 16)))) + ;;;; Interrupt control (define interrupt-bit/stack #x0001) diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm index 58fd6b983..460cc2af7 100644 --- a/src/runtime/vector.scm +++ b/src/runtime/vector.scm @@ -54,11 +54,31 @@ USA. (if (not (fix:<= end (vector-length vector))) (error:bad-range-argument end procedure))) -(define (make-vector size #!optional fill) - (if (not (index-fixnum? size)) - (error:wrong-type-argument size "vector index" 'MAKE-VECTOR)) - ((ucode-primitive vector-cons) size (if (default-object? fill) #f fill))) - +(define (make-vector length #!optional fill) + (vector-cons length (if (default-object? fill) #f fill))) + +(define (vector-cons length fill) + (let-syntax + ((expand-cases + (sc-macro-transformer + (lambda (form use-env) + (declare (ignore use-env)) + (let ((limit (cadr form)) ;must be a power of 2 + (gen-accessor + (lambda (i) + `(vector ,@(make-list i 'fill))))) + `(if (and (index-fixnum? length) + (fix:< length ,limit)) + ,(let loop ((low 0) (high limit)) + (if (> (- high low) 1) + (let ((mid (quotient (+ high low) 2))) + `(if (fix:< length ,mid) + ,(loop low mid) + ,(loop mid high))) + (gen-accessor low))) + ((ucode-primitive vector-cons) length fill))))))) + (expand-cases 16))) + (define (vector-builder #!optional buffer-length) (make-sequence-builder any-object? vector? make-vector vector-length vector-set! vector-copy! @@ -131,7 +151,7 @@ USA. (error:wrong-type-argument length "vector length" 'VECTOR-GROW)) (if (fix:< length (vector-length vector)) (error:bad-range-argument length 'VECTOR-GROW)) - (let ((vector* (make-vector length (if (default-object? value) #f value)))) + (let ((vector* (make-vector length value))) (subvector-move-right! vector 0 (vector-length vector) vector* 0) vector*))