From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 23 May 2010 11:50:00 +0000 (-0700)
Subject: Implement VECTOR-HEAD!.
X-Git-Tag: 20100708-Gtk~63
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=61fc6618660506cf12b796634b8c29556c21482e;p=mit-scheme.git

Implement VECTOR-HEAD!.
---

diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm
index 770093533..31ec0161f 100644
--- a/src/runtime/vector.scm
+++ b/src/runtime/vector.scm
@@ -30,6 +30,8 @@ USA.
 
 (define-primitives
   (list->vector 1)
+  (primitive-make-object 2)
+  (primitive-object-set! 3)
   (subvector->list 3)
   (subvector-fill! 4)
   (subvector-move-left! 5)
@@ -77,6 +79,14 @@ USA.
 (define-integrable (vector-head vector end)
   (subvector vector 0 end))
 
+(define (vector-head! vector end)
+  (guarantee-subvector vector 0 end 'VECTOR-HEAD!)
+  (if (fix:< end (vector-length end))
+      (primitive-object-set! vector 0
+			     (primitive-make-object (ucode-type false)
+						    end)))
+  vector)
+
 (define (vector-tail vector start)
   (guarantee-vector vector 'VECTOR-TAIL)
   (subvector vector start (vector-length vector)))