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 a8c506021a532fad65ca721e247ca89e67092313..22737930647715e07ab3e1aac45e474a47f4370f 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -29,7 +29,8 @@ USA.
 
 (declare (usual-integrations))
 \f
-;;; 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))))
+\f
 ;;;; Interrupt control
 
 (define interrupt-bit/stack     #x0001)

diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm
index 58fd6b9836e74dee066068e74099a75bfd5d16c0..460cc2af77702bb5b75246ec091741ae51e66331 100644 (file)
--- 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)))
+\f
 (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*))