From: Joe Marshall <eval.apply@gmail.com>
Date: Sat, 21 Jan 2012 18:51:37 +0000 (-0800)
Subject: Fixup scode SEQUENCE abstraction.
X-Git-Tag: release-9.2.0~334^2~7
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=aaeb5a197c423ffb7b2d7d4dbd32798023c69dd7;p=mit-scheme.git

Fixup scode SEQUENCE abstraction.
---

diff --git a/src/runtime/scomb.scm b/src/runtime/scomb.scm
index 40813256f..e3feb63e4 100644
--- a/src/runtime/scomb.scm
+++ b/src/runtime/scomb.scm
@@ -126,35 +126,53 @@ USA.
 
 ;;;; Sequence
 
+(define-integrable (%make-sequence first second)
+  (&typed-pair-cons (ucode-type sequence-2) first second))
+
+(define-integrable (sequence? object)
+  (object-type? (ucode-type sequence-2) object))
+
+(define-integrable (%sequence-first sequence) (&pair-car sequence))
+(define-integrable (%sequence-second sequence) (&pair-cdr sequence))
+
+(define-guarantee sequence "SCode sequence")
+
 (define (make-sequence actions)
   (if (null? actions)
       (error "MAKE-SEQUENCE: No actions"))
   (let loop ((actions actions))
-    (if (null? (cdr actions))
-	(car actions)
-	(&typed-pair-cons (ucode-type sequence-2)
-			  (car actions)
-			  (loop (cdr actions))))))
+    (cond ((null? (cdr actions)) (car actions))
+	  ((sequence? (car actions))
+	   (loop (append (sequence-actions (car actions)) (cdr actions))))
+	  (else	(%make-sequence (car actions) (loop (cdr actions)))))))
 
-(define (sequence? object)
-  (object-type? (ucode-type sequence-2) object))
+(define (sequence-first expression)
+  (guarantee-sequence expression 'SEQUENCE-FIRST)
+  (%sequence-first expression))
 
-(define-guarantee sequence "SCode sequence")
+(define (sequence-second expression)
+  (guarantee-sequence expression 'SEQUENCE-SECOND)
+  (%sequence-second expression))
+
+(define (sequence-immediate-actions expression)
+  (guarantee-sequence expression 'SEQUENCE-IMMEDIATE-ACTIONS)
+  (list (%sequence-first expression)
+	(%sequence-second expression)))
 
 (define (sequence-actions expression)
-  (if (object-type? (ucode-type sequence-2) expression)
-      (append! (sequence-actions (&pair-car expression))
-	       (sequence-actions (&pair-cdr expression)))
+  (if (sequence? expression)
+      (cons (%sequence-first expression)
+	    (sequence-actions (%sequence-second expression)))
       (list expression)))
 
-(define (sequence-immediate-actions expression)
-  (if (object-type? (ucode-type sequence-2) expression)
-      (list (&pair-car expression)
-	    (&pair-cdr expression))
-      (error:not-sequence expression 'SEQUENCE-IMMEDIATE-ACTIONS)))
-
 (define (sequence-components expression receiver)
   (receiver (sequence-actions expression)))
+
+(define (copy-sequence expression)
+  (guarantee-sequence expression 'COPY-SEQUENCE)
+  (%make-sequence (%sequence-first expression)
+		  (%sequence-second expression)))
+
 
 ;;;; Conditional