Remove SEQUENCE-3 from Scheme code.

diff --git a/src/compiler/fggen/canon.scm b/src/compiler/fggen/canon.scm
index 9ca9833b2143bce312aae02a9d2b2408b6041032..f5a1c946e6b759597d2b708c15138e29bcd20ce1 100644 (file)
--- a/src/compiler/fggen/canon.scm
+++ b/src/compiler/fggen/canon.scm
@@ -874,7 +874,7 @@ ARBITRARY:  The expression may be executed more than once.  It
                                       primitive-combination-3)
                        canonicalize/combination)
       (dispatch-entries (lambda lexpr extended-lambda) canonicalize/lambda)
-      (dispatch-entries (sequence-2 sequence-3) canonicalize/sequence))
+      (dispatch-entry sequence-2 canonicalize/sequence))
     (named-lambda (canonicalize/expression expression bound context)
       ((vector-ref dispatch-vector (object-type expression))
        expression bound context))))
\ No newline at end of file

diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm
index afebe531d91281cb741e7521b873fb06de46c2e0..e711e4190b21f86b8bd00be0d712725ee3227ab8 100644 (file)
--- a/src/compiler/fggen/fggen.scm
+++ b/src/compiler/fggen/fggen.scm
@@ -501,30 +501,17 @@ USA.
 ;;;; Combinators
 
 (define (generate/sequence block continuation context expression)
-  (let ((join (scfg*ctype->ctype! continuation)))
-    (let ((do-action
-          (lambda (action continuation-type)
-            (generate/subproblem/effect block continuation context
-                                        action continuation-type expression)))
-         (do-result
-          (lambda (expression)
-            (generate/expression block continuation context expression))))
-      ;; These are done in a funny way to enforce processing in sequence order.
+  (if (object-type? (ucode-type sequence-2) expression)
+      ;; This is done in a funny way to enforce processing in sequence order.
       ;; In this way, compile-by-procedures compiles in a predictable order.
-      (cond ((object-type? (ucode-type sequence-2) expression)
-            (let ((first (do-action (&pair-car expression) 'SEQUENCE-2-SECOND)))
-              (join first
-                    (do-result (&pair-cdr expression)))))
-           ((object-type? (ucode-type sequence-3) expression)
-            (let ((first (do-action (&triple-first expression) 'SEQUENCE-3-SECOND)))
-              (join
-               first
-               (let ((second (do-action (&triple-second expression) 'SEQUENCE-3-THIRD)))
-                 (join
-                  second
-                  (do-result (&triple-third expression)))))))
-           (else
-            (error "Not a sequence" expression))))))
+      (let ((first (generate/subproblem/effect
+                   block continuation context
+                   (&pair-car expression) 'SEQUENCE-2-SECOND
+                   expression)))
+       ((scfg*ctype->ctype! continuation)
+        first
+        (generate/expression block continuation context (&pair-cdr expression))))
+      (error "Not a sequence" expression)))
 
 (define (generate/conditional block continuation context expression)
   (scode/conditional-components expression

diff --git a/src/runtime/codwlk.scm b/src/runtime/codwlk.scm
index f318359d318a33ca8a214df5d53f5ae764e90e33..86349f316fe9f3d8c519b460a63307ec4ac45c75 100644 (file)
--- a/src/runtime/codwlk.scm
+++ b/src/runtime/codwlk.scm
@@ -123,7 +123,7 @@ USA.
                      (DISJUNCTION ,walk/disjunction)
                      ((LAMBDA LEXPR EXTENDED-LAMBDA) ,walk/lambda)
                      (QUOTATION ,walk/quotation)
-                     ((SEQUENCE-2 SEQUENCE-3) ,walk/sequence)
+                     (SEQUENCE-2 ,walk/sequence)
                      (THE-ENVIRONMENT ,walk/the-environment)
                      (VARIABLE ,walk/variable)))
          table)))

diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm
index abcf00095e1cf452a2609bf032a18736cb8f3559..8b2e34d67af909447ed0dc1c9cd388a9092b097d 100644 (file)
--- a/src/runtime/conpar.scm
+++ b/src/runtime/conpar.scm
@@ -811,8 +811,6 @@ USA.
     (standard-subproblem 'ASSIGNMENT-CONTINUE 3)
     (standard-subproblem 'DEFINITION-CONTINUE 3)
     (standard-subproblem 'SEQUENCE-2-SECOND 3)
-    (standard-subproblem 'SEQUENCE-3-SECOND 3)
-    (standard-subproblem 'SEQUENCE-3-THIRD 3)
     (standard-subproblem 'CONDITIONAL-DECIDE 3)
     (standard-subproblem 'DISJUNCTION-DECIDE 3)
     (standard-subproblem 'COMBINATION-1-PROCEDURE 3)

diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm
index f0d7fdec3ae6d8945081ab7f412de13ca57e05b4..563ae539a6d5b629709550cf81602c81fd6d2a8b 100644 (file)
--- a/src/runtime/framex.scm
+++ b/src/runtime/framex.scm
@@ -230,11 +230,8 @@ USA.
                       ((ASSIGNMENT-CONTINUE
                         DEFINITION-CONTINUE)
                        (win &pair-cdr))
-                      ((SEQUENCE-3-SECOND
-                        CONDITIONAL-DECIDE)
+                      ((CONDITIONAL-DECIDE)
                        (win &triple-first))
-                      ((SEQUENCE-3-THIRD)
-                       (win &triple-second))
                       ((COMBINATION-OPERAND)
                        (values
                         expression
@@ -283,11 +280,9 @@ USA.
     (record-method 'COMBINATION-1-PROCEDURE method)
     (record-method 'DEFINITION-CONTINUE method))
   (let ((method (method/standard &triple-first)))
-    (record-method 'CONDITIONAL-DECIDE method)
-    (record-method 'SEQUENCE-3-SECOND method))
+    (record-method 'CONDITIONAL-DECIDE method))
   (let ((method (method/standard &triple-second)))
-    (record-method 'COMBINATION-2-PROCEDURE method)
-    (record-method 'SEQUENCE-3-THIRD method))
+    (record-method 'COMBINATION-2-PROCEDURE method))
   (let ((method (method/standard &triple-third)))
     (record-method 'COMBINATION-2-FIRST-OPERAND method)
     (record-method 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND method))

diff --git a/src/runtime/prgcop.scm b/src/runtime/prgcop.scm
index bf9c7c16f104802d746be32db33ee2dfb16c9333..0550a2dc4b1900b854fde66efb3de22954e0d026 100644 (file)
--- a/src/runtime/prgcop.scm
+++ b/src/runtime/prgcop.scm
@@ -227,12 +227,9 @@ USA.
     typed))
 \f
 (define (copy-SEQUENCE-object obj)
-  (cond ((object-type? (ucode-type SEQUENCE-2) obj)
-        (%%copy-pair (ucode-type SEQUENCE-2) obj))
-       ((object-type? (ucode-type SEQUENCE-3) obj)
-        (%%copy-triple (ucode-type SEQUENCE-3) obj))
-       (else
-        (error "copy-SEQUENCE-object: Unknown type" obj))))
+  (if (object-type? (ucode-type SEQUENCE-2) obj)
+      (%%copy-pair (ucode-type SEQUENCE-2) obj)
+      (error "copy-SEQUENCE-object: Unknown type" obj)))
 
 (define (copy-COMBINATION-object obj)
   (cond ((object-type? (ucode-type combination) obj)

diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm
index 447f4358b9cee70b55bf97851bab75d7b205e204..88a6f7b6f42bda231ec0aba9e24f96a01137f913 100644 (file)
--- a/src/runtime/scan.scm
+++ b/src/runtime/scan.scm
@@ -48,19 +48,16 @@ USA.
 (define-integrable open-block-tag
   ((ucode-primitive string->symbol) "#[open-block]"))
 
-(define-integrable sequence-2-type
+(define-integrable sequence-type
   (ucode-type sequence-2))
 
-(define-integrable sequence-3-type
-  (ucode-type sequence-3))
-
 (define null-sequence
   '(NULL-SEQUENCE))
 
 (define (cons-sequence action seq)
   (if (eq? seq null-sequence)
       action
-      (&typed-pair-cons sequence-2-type action seq)))
+      (&typed-pair-cons sequence-type action seq)))
 \f
 ;;;; Scanning
 
@@ -73,7 +70,7 @@ USA.
   ((scan-loop expression receiver) '() '() null-sequence))
 
 (define (scan-loop expression receiver)
-  (cond ((object-type? sequence-2-type expression)
+  (cond ((object-type? sequence-type expression)
         (let ((first (&pair-car expression)))
           (if (and (vector? first)
                    (not (zero? (vector-length first)))
@@ -87,21 +84,6 @@ USA.
               (scan-loop (&pair-cdr expression)
                          (scan-loop first
                                     receiver)))))
-       ((object-type? sequence-3-type expression)
-        (let ((first (&triple-first expression)))
-          (if (and (vector? first)
-                   (not (zero? (vector-length first)))
-                   (eq? (vector-ref first 0) open-block-tag))
-              (scan-loop
-               (&triple-third expression)
-               (lambda (names declarations body)
-                 (receiver (append (vector-ref first 1) names)
-                           (append (vector-ref first 2) declarations)
-                           body)))
-              (scan-loop (&triple-third expression)
-                         (scan-loop (&triple-second expression)
-                                    (scan-loop first
-                                               receiver))))))
        ((definition? expression)
         (definition-components expression
           (lambda (name value)
@@ -131,7 +113,7 @@ USA.
                 names*))
       (if (null? declarations)
          body*
-         (&typed-pair-cons sequence-2-type
+         (&typed-pair-cons sequence-type
                            (make-block-declaration declarations)
                            body*)))))
 
@@ -146,29 +128,15 @@ USA.
                           (make-definition name value))
                 (receiver names
                           body)))))
-       ((object-type? sequence-2-type 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-2-type
+                          (&typed-pair-cons sequence-type
                                             body*
                                             body**)))))))
-       ((object-type? sequence-3-type body)
-        (unscan-loop names (&triple-first body)
-          (lambda (names* body*)
-            (unscan-loop names* (&triple-second body)
-              (lambda (names** body**)
-                (unscan-loop names** (&triple-third body)
-                  (lambda (names*** body***)
-                    (receiver names***
-                              (&typed-pair-cons sequence-2-type
-                                                body*
-                                                (&typed-pair-cons
-                                                 sequence-2-type
-                                                 body**
-                                                 body***))))))))))
        (else
         (receiver names
                   body))))
@@ -180,10 +148,10 @@ USA.
           (null? declarations))
       body
       (&typed-pair-cons
-       sequence-2-type
+       sequence-type
        (vector open-block-tag names declarations)
        (&typed-pair-cons
-       sequence-2-type
+       sequence-type
        (if (null? names)
            '()
            (make-sequence
@@ -193,23 +161,16 @@ USA.
        body))))
 
 (define (open-block? object)
-  (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))))
+  (and (object-type? sequence-type object)
+       (vector? (&pair-car object))
+       (eq? (vector-ref (&pair-car 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)
-  (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
+  (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

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 12ee4225b2081371d19668b9b607eddacdb56871..7c6bf1d56ec26fe5bc762e43d58cb76eee22280b 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -299,8 +299,7 @@ USA.
     (PRIMITIVE-COMBINATION-1 . COMBINATION)
     (PRIMITIVE-COMBINATION-2 . COMBINATION)
     (PRIMITIVE-COMBINATION-3 . COMBINATION)
-    (SEQUENCE-2 . SEQUENCE)
-    (SEQUENCE-3 . SEQUENCE)))
+    (SEQUENCE-2 . SEQUENCE)))
 \f
 (define (unparse/false object)
   (if (eq? object #f)