From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Mon, 15 Mar 2010 02:04:47 +0000 (-0700)
Subject: Recognize open-blocks even if they appear in a sequence-2.
X-Git-Tag: 20100708-Gtk~96
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d90a8f04d729e6edd173d436dd9888a5e5d9629e;p=mit-scheme.git

Recognize open-blocks even if they appear in a sequence-2.
---

diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm
index 34223f91d..d4a870e73 100644
--- a/src/runtime/scan.scm
+++ b/src/runtime/scan.scm
@@ -79,9 +79,19 @@ USA.
 
 (define (scan-loop expression receiver)
   (cond ((object-type? sequence-2-type expression)
-	 (scan-loop (&pair-cdr expression)
-		    (scan-loop (&pair-car expression)
-			       receiver)))
+	 (let ((first (&pair-car expression)))
+	   (if (and (vector? first)
+		    (not (zero? (vector-length first)))
+		    (eq? (vector-ref first 0) open-block-tag))
+	       (scan-loop
+		(&pair-cdr (&pair-cdr expression))
+		(lambda (names declarations body)
+		  (receiver (append (vector-ref first 1) names)
+			    (append (vector-ref first 2) declarations)
+			    body)))
+	       (scan-loop (&pair-cdr expression)
+			  (scan-loop first
+				     receiver)))))
 	((object-type? sequence-3-type expression)
 	 (let ((first (&triple-first expression)))
 	   (if (and (vector? first)
@@ -184,14 +194,23 @@ USA.
        body)))
 
 (define (open-block? object)
-  (and (object-type? sequence-3-type object)
-       (vector? (&triple-first object))
-       (eq? (vector-ref (&triple-first object) 0) open-block-tag)))
+  (or (and (object-type? sequence-2-type object)
+	   (vector? (&pair-car object))
+	   (eq? (vector-ref (&pair-car object) 0) open-block-tag))
+      (and (object-type? sequence-3-type object)
+	   (vector? (&triple-first object))
+	   (eq? (vector-ref (&triple-first object) 0) open-block-tag))))
 
 (define-guarantee open-block "SCode open-block")
 
 (define (open-block-components open-block receiver)
   (guarantee-open-block open-block 'OPEN-BLOCK-COMPONENTS)
-  (receiver (vector-ref (&triple-first open-block) 1)
-	    (vector-ref (&triple-first open-block) 2)
-	    (&triple-third open-block)))
\ No newline at end of file
+  (cond ((object-type? sequence-2-type open-block)
+	 (receiver (vector-ref (&pair-car open-block) 1)
+		   (vector-ref (&pair-car open-block) 2)
+		   (&pair-cdr (&pair-cdr open-block))))
+	((object-type? sequence-3-type open-block)
+	 (receiver (vector-ref (&triple-first open-block) 1)
+		   (vector-ref (&triple-first open-block) 2)
+		   (&triple-third open-block)))
+	(else (error:not-open-block open-block 'open-block-components))))
\ No newline at end of file