From: Chris Hanson <org/chris-hanson/cph>
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*))