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

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b02226455bd98c3b5d4a856aa5f05b70edc36f39..7eabfa002ae7cc0d9e17529c1b000fbefa96c603 100644 (file)
--- 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 88a6f7b6f42bda231ec0aba9e24f96a01137f913..b07a100cd92e0a65124beacdd584209a1b8b32c9 100644 (file)
--- 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))))))
 \f
 (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*))))
 \f
 ;;;; 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