From: Joe Marshall <eval.apply@gmail.com>
Date: Tue, 7 Feb 2012 18:42:30 +0000 (-0800)
Subject: Add selectors for OPEN-BLOCKs, rewrite unscan-defines in direct style.
X-Git-Tag: release-9.2.0~313
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2dc04032a1ee29408a6ed438a48008fdd562d40a;p=mit-scheme.git

Add selectors for OPEN-BLOCKs, rewrite unscan-defines in direct style.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b02226455..7eabfa002 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3715,7 +3715,11 @@ USA.
   (parent (runtime))
   (export ()
 	  make-open-block
+	  open-block-actions
 	  open-block-components
+	  open-block-declarations
+	  open-block-definitions
+	  open-block-names
 	  open-block?
 	  scan-defines
 	  unscan-defines))
diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm
index 88a6f7b6f..b07a100cd 100644
--- a/src/runtime/scan.scm
+++ b/src/runtime/scan.scm
@@ -70,20 +70,20 @@ USA.
   ((scan-loop expression receiver) '() '() null-sequence))
 
 (define (scan-loop expression receiver)
-  (cond ((object-type? sequence-type expression)
-	 (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)))))
+  (cond ((open-block? expression)	; must come before SEQUENCE? clause
+	 (scan-loop
+	  (%open-block-actions expression)
+	  (lambda (names declarations body)
+	    (receiver (append (%open-block-names expression) names)
+		      (append (%open-block-declarations expression) declarations)
+		      body))))
+	((sequence? expression)
+	 ;; Build the sequence from the tail-end first so that the
+	 ;; null-sequence shows up in the tail and is detected by
+	 ;; cons-sequence.
+	 (scan-loop (sequence-immediate-second expression)
+		    (scan-loop (sequence-immediate-first expression)
+			       receiver)))
 	((definition? expression)
 	 (definition-components expression
 	   (lambda (name value)
@@ -105,72 +105,127 @@ USA.
 		     (cons-sequence expression body))))))
 
 (define (unscan-defines names declarations body)
-  (unscan-loop names body
-    (lambda (names* body*)
-      (if (not (null? names*))
-	  (error "Extraneous auxiliaries -- get a wizard"
-		 'UNSCAN-DEFINES
-		 names*))
-      (if (null? declarations)
-	  body*
-	  (&typed-pair-cons sequence-type
-			    (make-block-declaration declarations)
-			    body*)))))
-
-(define (unscan-loop names body receiver)
-  (cond ((not (pair? names))
-	 (receiver '() body))
-	((assignment? body)
-	 (assignment-components body
-	   (lambda (name value)
-	     (if (eq? name (car names))
-		 (receiver (cdr names)
-			   (make-definition name value))
-		 (receiver names
-			   body)))))
-	((object-type? sequence-type body)
-	 (unscan-loop names (&pair-car body)
-	   (lambda (names* body*)
-	     (unscan-loop names* (&pair-cdr body)
-	       (lambda (names** body**)
-		 (receiver names**
-			   (&typed-pair-cons sequence-type
-					     body*
-					     body**)))))))
-	(else
-	 (receiver names
-		   body))))
+
+  (define (unscan-loop names body)
+    (cond ((not (pair? names))
+	   (values '() body))
+
+	  ((assignment? body)
+	   (assignment-components body
+	     (lambda (name value)
+	       (if (eq? name (car names))
+		   (values (cdr names) (make-definition name value))
+		   (values names body)))))
+
+	  ((sequence? body)
+	   (let ((head (sequence-immediate-first body))
+		 (tail (sequence-immediate-second body)))
+
+	     (receive (names1 unscanned-head) (unscan-loop names head)
+	       (receive (names2 unscanned-tail) (unscan-loop names1 tail)
+		 (values names2
+			 ;; Only cons a new sequence if something changed.
+			 (if (and (eq? head unscanned-head)
+				  (eq? tail unscanned-tail))
+			     body
+			     (&typed-pair-cons
+			      sequence-type
+			      unscanned-head unscanned-tail)))))))
+
+	  (else
+	   (values names body))))
+
+  (receive (names* body*) (unscan-loop names body)
+    (if (not (null? names*))
+	(error "Extraneous auxiliaries -- get a wizard"
+	       'UNSCAN-DEFINES
+	       names*))
+
+    (if (null? declarations)
+	body*
+	(&typed-pair-cons
+	 sequence-type
+	 (make-block-declaration declarations)
+	 body*))))
 
 ;;;; Open Block
 
-(define (make-open-block names declarations body)
+(define (make-open-block names declarations actions)
   (if (and (null? names)
 	   (null? declarations))
-      body
+      actions
       (&typed-pair-cons
        sequence-type
-       (vector open-block-tag names declarations)
+       (make-open-block-descriptor names declarations)
        (&typed-pair-cons
 	sequence-type
-	(if (null? names)
-	    '()
-	    (make-sequence
-	     (map (lambda (name)
-		    (make-definition name (make-unassigned-reference-trap)))
-		  names)))
-	body))))
+	(make-open-block-definitions names)
+	actions))))
 
 (define (open-block? object)
-  (and (object-type? sequence-type object)
-       (vector? (&pair-car object))
-       (eq? (vector-ref (&pair-car object) 0) open-block-tag)))
+  (and (sequence? object)
+       (open-block-descriptor? (sequence-immediate-first object))
+       (sequence? (sequence-immediate-second object))))
 
-(define-guarantee open-block "SCode open-block")
+(define (open-block-actions open-block)
+  (guarantee-open-block open-block 'OPEN-BLOCK-ACTIONS)
+  (%open-block-actions open-block))
+
+(define (open-block-declarations open-block)
+  (guarantee-open-block open-block 'OPEN-BLOCK-DECLARATIONS)
+  (%open-block-declarations open-block))
+
+(define (open-block-definitions open-block)
+  (guarantee-open-block open-block 'OPEN-BLOCK-DEFINITIONS)
+  (%open-block-definitions open-block))
+
+(define (open-block-names open-block)
+  (guarantee-open-block open-block 'OPEN-BLOCK-NAMES)
+  (%open-block-names open-block))
 
 (define (open-block-components open-block receiver)
   (guarantee-open-block open-block 'OPEN-BLOCK-COMPONENTS)
-  (if (object-type? sequence-type open-block)
-      (receiver (vector-ref (&pair-car open-block) 1)
-		(vector-ref (&pair-car open-block) 2)
-		(&pair-cdr (&pair-cdr open-block)))
-      (error:not-open-block open-block 'open-block-components)))
\ No newline at end of file
+  (let ((descriptor (sequence-immediate-first open-block)))
+    (receiver (%open-block-descriptor-names descriptor)
+	      (%open-block-descriptor-declarations descriptor)
+	      (%open-block-actions open-block))))
+
+(define (make-open-block-definitions names)
+  (let ((definitions
+	  (map (lambda (name)
+		 (make-definition name (make-unassigned-reference-trap)))
+	       names)))
+    (if (null? definitions)
+	'()
+	(make-sequence definitions))))
+
+(define-guarantee open-block "SCode open-block")
+
+(define (%open-block-descriptor open-block)
+  (sequence-immediate-first open-block))
+
+(define (%open-block-actions open-block)
+  (sequence-immediate-second (sequence-immediate-second open-block)))
+
+(define (%open-block-declarations open-block)
+  (%open-block-descriptor-declarations (%open-block-descriptor open-block)))
+
+(define (%open-block-definitions open-block)
+  (sequence-immediate-first (sequence-immediate-second open-block)))
+
+(define (%open-block-names open-block)
+  (%open-block-descriptor-names (%open-block-descriptor open-block)))
+
+(define (make-open-block-descriptor names declarations)
+  (vector open-block-tag names declarations))
+
+(define (open-block-descriptor? object)
+  (and (vector? object)
+       (not (zero? (vector-length object)))
+       (eq? (vector-ref object 0) open-block-tag)))
+
+(define (%open-block-descriptor-names descriptor)
+  (vector-ref descriptor 1))
+
+(define (%open-block-descriptor-declarations descriptor)
+  (vector-ref descriptor 2))
\ No newline at end of file