From fba4d502898c19c2a1c7ae27c9038f779e483b03 Mon Sep 17 00:00:00 2001
From: Noel Welsh <noel@racket-lang.org>
Date: Fri, 3 Dec 2010 10:25:01 +0000
Subject: [PATCH] Merge refactored code back into for.rkt, on Eli's advice

---
 collects/racket/private/for-base.rkt   | 125 ------
 collects/racket/private/for-vector.rkt | 207 ----------
 collects/racket/private/for.rkt        | 523 ++++++++++++++++++-------
 3 files changed, 390 insertions(+), 465 deletions(-)
 delete mode 100644 collects/racket/private/for-base.rkt
 delete mode 100644 collects/racket/private/for-vector.rkt

diff --git a/collects/racket/private/for-base.rkt b/collects/racket/private/for-base.rkt
deleted file mode 100644
index e070cd5ca9..0000000000
--- a/collects/racket/private/for-base.rkt
+++ /dev/null
@@ -1,125 +0,0 @@
-(module for-base '#%kernel
-
-  (#%require "more-scheme.rkt"
-             "misc.rkt"
-             "define.rkt"
-             "letstx-scheme.rkt"
-             '#%unsafe
-             (for-syntax '#%kernel
-                         "stx.rkt"
-                         "qqstx.rkt"
-                         "define.rkt"
-                         "small-scheme.rkt"
-                         "stxcase-scheme.rkt"))
-
-  (#%provide struct:do-sequence
-             make-do-sequence
-             do-sequence?
-             do-sequence-ref
-             do-sequence-set!
-
-             :do-in
-             
-             prop:sequence
-
-             define-sequence-syntax
-
-             sequence?
-             :sequence?
-             :sequence-ref
-
-             (for-syntax struct:sequence-transformer
-                         make-sequence-transformer
-                         sequence-transformer?
-                         sequence-transformer-ref
-                         sequence-transformer-set!
-                         
-                         create-sequence-transformer))
-  
-  (begin-for-syntax
-    (define-values (struct:sequence-transformer
-                    make-sequence-transformer
-                    sequence-transformer?
-                    sequence-transformer-ref
-                    sequence-transformer-set!)
-      (make-struct-type 'sequence-transformer #f
-                        3 0 #f
-                        null (current-inspector)
-                        0))
-
-    (define (create-sequence-transformer proc1 proc2 cert)
-      (unless (and (procedure? proc1)
-                   (or (procedure-arity-includes? proc1 1)
-                       (procedure-arity-includes? proc1 0)))
-        (raise-type-error 'define-sequence-syntax
-                          "procedure (arity 0 or 1)"
-                          0
-                          proc1 proc2))
-      (unless (and (procedure? proc2)
-                   (procedure-arity-includes? proc2 1))
-        (raise-type-error 'define-sequence-syntax
-                          "procedure (arity 1)"
-                          1
-                          proc1 proc2))
-      (make-sequence-transformer
-       (if (procedure-arity-includes? proc1 0)
-         (lambda (stx)
-           (if (identifier? stx)
-             (proc1)
-             (datum->syntax stx
-                            #`(#,(proc1) . #,(cdr (syntax-e stx)))
-                            stx
-                            stx)))
-         proc1)
-       proc2
-       cert))
-    )
-
-  (define-syntax (:do-in stx)
-    (raise-syntax-error #f
-      "illegal outside of a loop or comprehension binding" stx))
-  
-  (define-values (struct:do-sequence
-                  make-do-sequence
-                  do-sequence?
-                  do-sequence-ref
-                  do-sequence-set!)
-    (make-struct-type 'sequence #f 1 0 #f))
-
-  (define-values (prop:sequence :sequence? :sequence-ref)
-    (make-struct-type-property
-     'sequence
-     (lambda (v sinfo)
-       (unless (and (procedure? v) (procedure-arity-includes? v 1))
-         (raise-type-error 'sequence-property-guard "procedure (arity 1)" v))
-       (lambda (self)
-         (let ([s (v self)])
-           (unless (sequence? s)
-             (raise-mismatch-error
-              'sequence-generate
-              "procedure (value of prop:sequence) produced a non-sequence: "
-              s))
-           s)))))
-
-  (define-syntax define-sequence-syntax
-    (syntax-rules ()
-      [(_ id expr-transformer-expr clause-transformer-expr)
-       (define-syntax id
-         (create-sequence-transformer expr-transformer-expr
-                                      clause-transformer-expr
-                                      (syntax-local-certifier #f)))]))
-
-  (define (sequence? v)
-    (or (do-sequence? v)
-        (list? v)
-        (mpair? v)
-        (vector? v)
-        (string? v)
-        (bytes? v)
-        (input-port? v)
-        (hash? v)
-        (and (:sequence? v) (not (struct-type? v)))))
-  
-  )
-
-  
\ No newline at end of file
diff --git a/collects/racket/private/for-vector.rkt b/collects/racket/private/for-vector.rkt
deleted file mode 100644
index 406363b45c..0000000000
--- a/collects/racket/private/for-vector.rkt
+++ /dev/null
@@ -1,207 +0,0 @@
-;; Comprehensions for vector like data types
-(module for-vector '#%kernel
-
-  (#%require "more-scheme.rkt"
-             "misc.rkt"
-             "define.rkt"
-             "letstx-scheme.rkt"
-             "for-base.rkt"
-             '#%unsafe
-             (for-syntax '#%kernel
-                         "stx.rkt"
-                         "qqstx.rkt"
-                         "define.rkt"
-                         "small-scheme.rkt"
-                         "stxcase-scheme.rkt"))
-
-  (#%provide in-vector
-             in-string
-             in-bytes
-             
-             :vector-gen
-             :string-gen
-             :bytes-gen
-
-             *in-vector
-             *in-string
-             *in-bytes
-
-             define-in-vector-like
-             define-:vector-like-gen
-
-             (for-syntax make-in-vector-like))
-
-  ;; (: check-ranges (Symbol Natural Natural Integer -> Void))
-  (define (check-ranges who start stop step)
-    (unless (exact-nonnegative-integer? start) (raise-type-error who "exact non-negative integer" start))
-    (unless (exact-nonnegative-integer? stop) (raise-type-error who "exact non-negative integer or #f" stop))
-    (unless (and (exact-integer? step) (not (zero? step)))
-      (raise-type-error who "exact non-zero integer" step))
-    (when (and (< start stop) (< step 0))
-      (raise-mismatch-error who (format "start: ~a less than stop: ~a but given negative step: "
-                                        start stop)
-                            step))
-    (when (and (< stop start) (> step 0))
-      (raise-mismatch-error who (format "start: ~a more than stop: ~a but given positive step: "
-                                        start stop)
-                            step)))
-
-  (define-syntax define-in-vector-like
-    (syntax-rules ()
-      [(define-in-vector-like in-vector-name
-         type-name-str vector?-id vector-length-id :vector-gen-id)
-       (define in-vector-name
-        (case-lambda
-          [(v) (in-vector-name v 0 #f 1)]
-          [(v start) (in-vector-name v start #f 1)]
-          [(v start stop) (in-vector-name v start stop 1)]
-          [(v start stop step)
-           (unless (vector?-id v) (raise-type-error (quote in-vector-name) type-name-str v))
-           (let ([stop (or stop (vector-length-id v))])
-             (check-ranges (quote in-vector-name) start stop step)
-             (make-do-sequence (lambda () (:vector-gen-id v start stop step))))]))]))
-
-  (define-syntax define-:vector-like-gen
-    (syntax-rules ()
-      [(define-:vector-like-gen :vector-like-name unsafe-vector-ref-id)
-       (define (:vector-like-name v start stop step)
-         (values
-          ;; pos->element
-          (lambda (i) (unsafe-vector-ref-id v i))
-          ;; next-pos
-          ;; Minor optimisation.  I assume add1 is faster than \x.x+1
-          (if (= step 1) add1 (lambda (i) (+ i step)))
-          ;; initial pos
-          start
-          ;; continue?
-          (if (> step 0)
-              (lambda (i) (< i stop))
-              (lambda (i) (> i stop)))
-          void
-          void))]))
-
-  (define-for-syntax (make-in-vector-like vector?-id
-                                          unsafe-vector-length-id
-                                          in-vector-id
-                                          unsafe-vector-ref-id)
-     (define (in-vector-like stx)
-       (with-syntax ([vector? vector?-id]
-                     [in-vector in-vector-id]
-                     [unsafe-vector-length unsafe-vector-length-id]
-                     [unsafe-vector-ref unsafe-vector-ref-id])
-         (syntax-case stx ()
-           ;; Fast case
-           [[(id) (_ vec-expr)]
-            #'[(id)
-               (:do-in
-                ;;outer bindings
-                ([(vec len) (let ([vec vec-expr])
-                              (unless (vector? vec)
-                                (in-vector vec))
-                              (values vec (unsafe-vector-length vec)))])
-                ;; outer check
-                #f
-                ;; loop bindings
-                ([pos 0])
-                ;; pos check
-                (pos . unsafe-fx< . len)
-                ;; inner bindings
-                ([(id) (unsafe-vector-ref vec pos)])
-                ;; pre guard
-                #t
-                ;; post guard
-                #t
-                ;; loop args
-                ((unsafe-fx+ 1 pos)))]]
-           ;; General case
-           [((id) (_ vec-expr start))
-            (in-vector-like (syntax ((id) (_ vec-expr start #f 1))))]
-           [((id) (_ vec-expr start stop))
-            (in-vector-like (syntax ((id) (_ vec-expr start stop 1))))]
-           [((id) (_ vec-expr start stop step))
-            (let ([all-fx? (memq (syntax-e #'step) '(1 -1))])
-              #`[(id)
-                 (:do-in
-                  ;; Outer bindings
-                  ;; Prevent multiple evaluation
-                  ([(v* stop*) (let ([vec vec-expr]
-                                     [stop* stop])
-                                 (if (and (not stop*) (vector? vec))
-                                     (values vec (unsafe-vector-length vec))
-                                     (values vec stop*)))]
-                   [(start*) start]
-                   [(step*) step])
-                  ;; Outer check
-                  (when (or (not (vector? v*))
-                            (not (exact-integer? start*))
-                            (not (exact-integer? stop*))
-                            (not (exact-integer? step*))
-                            (zero? step*)
-                            (and (< start* stop*) (< step* 0))
-                            (and (> start* stop*) (> step* 0)))
-                    ;; Let in-vector report the error
-                    (in-vector v* start* stop* step*))
-                  ;; Loop bindings
-                  ([idx start*])
-                  ;; Pos guard
-                  #,(cond
-                     [(not (number? (syntax-e #'step)))
-                      #`(if (step* . >= . 0) (< idx stop*) (> idx stop*))]
-                     [((syntax-e #'step) . >= . 0)
-                      (if all-fx?
-                          #'(unsafe-fx< idx stop*)
-                          #'(< idx stop*))]
-                     [else
-                      (if all-fx?
-                          #'(unsafe-fx> idx stop*)
-                          #'(> idx stop*))])
-                  ;; Inner bindings
-                  ([(id) (unsafe-vector-ref v* idx)])
-                  ;; Pre guard
-                  #t
-                  ;; Post guard
-                  #t
-                  ;; Loop args
-                  ((#,(if all-fx? #'unsafe-fx+ #'+) idx step)))])]
-           [_ #f])))
-          in-vector-like)
-
-  (define-:vector-like-gen :vector-gen unsafe-vector-ref)
-  
-  (define-in-vector-like in-vector
-    "vector" vector? vector-length :vector-gen)
-
-
-  (define-:vector-like-gen :string-gen unsafe-string-ref)
-  
-  (define-in-vector-like in-string
-    "string" string? string-length :string-gen)
-
-
-  (define-:vector-like-gen :bytes-gen unsafe-bytes-ref)
-  
-  (define-in-vector-like in-bytes
-    "bytes" bytes? bytes-length :bytes-gen)
-
-  (define-sequence-syntax *in-vector
-    (lambda () #'in-vector)
-    (make-in-vector-like #'vector?
-                         #'unsafe-vector-length
-                         #'in-vector
-                         #'unsafe-vector-ref))
-
-  (define-sequence-syntax *in-string
-    (lambda () #'in-string)
-    (make-in-vector-like #'string?
-                         #'string-length
-                         #'in-string
-                         #'string-ref))
-
-  (define-sequence-syntax *in-bytes
-    (lambda () #'in-bytes)
-    (make-in-vector-like #'bytes?
-                         #'bytes-length
-                         #'in-bytes
-                         #'bytes-ref))
-  
-  )
\ No newline at end of file
diff --git a/collects/racket/private/for.rkt b/collects/racket/private/for.rkt
index f1941474ed..0c9ea01e6c 100644
--- a/collects/racket/private/for.rkt
+++ b/collects/racket/private/for.rkt
@@ -4,8 +4,6 @@
              "misc.rkt"
              "define.rkt"
              "letstx-scheme.rkt"
-             "for-base.rkt"
-             "for-vector.rkt"
              '#%unsafe
              (for-syntax '#%kernel
                          "stx.rkt"
@@ -67,9 +65,44 @@
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; sequence transformers:
 
-  ;; Mostly defined in for-base.rkt
-
   (begin-for-syntax
+   (define-values (struct:sequence-transformer
+                   make-sequence-transformer
+                   sequence-transformer?
+                   sequence-transformer-ref
+                   sequence-transformer-set!)
+     (make-struct-type 'sequence-transformer #f
+                       3 0 #f
+                       null (current-inspector)
+                       0))
+
+   (define (create-sequence-transformer proc1 proc2 cert)
+     (unless (and (procedure? proc1)
+                  (or (procedure-arity-includes? proc1 1)
+                      (procedure-arity-includes? proc1 0)))
+       (raise-type-error 'define-sequence-syntax
+                         "procedure (arity 0 or 1)"
+                         0
+                         proc1 proc2))
+     (unless (and (procedure? proc2)
+                  (procedure-arity-includes? proc2 1))
+       (raise-type-error 'define-sequence-syntax
+                         "procedure (arity 1)"
+                         1
+                         proc1 proc2))
+     (make-sequence-transformer
+      (if (procedure-arity-includes? proc1 0)
+          (lambda (stx)
+            (if (identifier? stx)
+                (proc1)
+                (datum->syntax stx
+                               #`(#,(proc1) . #,(cdr (syntax-e stx)))
+                               stx
+                               stx)))
+          proc1)
+      proc2
+      cert))
+
    (define cert-key (gensym 'for-cert))
 
    (define (certify-clause src-stx clause certifier introducer)
@@ -115,142 +148,186 @@
          ;; ill-formed clause...
          clause]))
 
-       (define (expand-clause orig-stx clause)
-      (let eloop ([use-transformer? #t])
-        (syntax-case clause (values in-parallel stop-before stop-after :do-in)
-          [[(id ...) rhs]
-           (let ([ids (syntax->list #'(id ...))])
-             (for-each (lambda (id)
-                         (unless (identifier? id)
-                           (raise-syntax-error
-                            #f
-                            "expected an identifier to bind"
-                            orig-stx
-                            id)))
-                       ids)
-             (let ([dup (check-duplicate-identifier (syntax->list #'(id ...)))])
-               (when dup
-                 (raise-syntax-error #f
-                   "duplicate identifier as sequence binding" orig-stx dup)))
-             #f)
-           'just-checking]
-          [[(id ...) (form . rest)]
-           (and use-transformer?
-                (identifier? #'form)
-                (sequence-transformer? (syntax-local-value #'form (lambda () #f))))
-           (let ([m (syntax-local-value #'form)])
-             (let ([xformer (sequence-transformer-ref m 1)]
-                   [introducer (make-syntax-introducer)]
-                   [certifier (sequence-transformer-ref m 2)])
-               (let ([xformed (xformer (introducer (syntax-local-introduce clause)))])
-                 (if xformed
-                     (let ([r (expand-clause orig-stx 
-                                             (certify-clause (syntax-case clause ()
-                                                               [(_ rhs) #'rhs])
-                                                             (syntax-local-introduce (introducer xformed))
-                                                             certifier
-                                                             introducer))])
-                       (syntax-property r
-                                        'disappeared-use
-                                        (cons (syntax-local-introduce #'form)
-                                              (or (syntax-property r 'disappeared-use)
-                                                  null))))
-                     (eloop #f)))))]
-          [[(id ...) (:do-in . body)]
-           (syntax-case #'body ()
-             [(([(outer-id ...) outer-rhs] ...)
+   (define (expand-clause orig-stx clause)
+     (let eloop ([use-transformer? #t])
+       (syntax-case clause (values in-parallel stop-before stop-after :do-in)
+         [[(id ...) rhs]
+          (let ([ids (syntax->list #'(id ...))])
+            (for-each (lambda (id)
+                        (unless (identifier? id)
+                          (raise-syntax-error
+                           #f
+                           "expected an identifier to bind"
+                           orig-stx
+                           id)))
+                      ids)
+            (let ([dup (check-duplicate-identifier (syntax->list #'(id ...)))])
+              (when dup
+                (raise-syntax-error #f
+                                    "duplicate identifier as sequence binding" orig-stx dup)))
+            #f)
+          'just-checking]
+         [[(id ...) (form . rest)]
+          (and use-transformer?
+               (identifier? #'form)
+               (sequence-transformer? (syntax-local-value #'form (lambda () #f))))
+          (let ([m (syntax-local-value #'form)])
+            (let ([xformer (sequence-transformer-ref m 1)]
+                  [introducer (make-syntax-introducer)]
+                  [certifier (sequence-transformer-ref m 2)])
+              (let ([xformed (xformer (introducer (syntax-local-introduce clause)))])
+                (if xformed
+                    (let ([r (expand-clause orig-stx 
+                                            (certify-clause (syntax-case clause ()
+                                                              [(_ rhs) #'rhs])
+                                                            (syntax-local-introduce (introducer xformed))
+                                                            certifier
+                                                            introducer))])
+                      (syntax-property r
+                                       'disappeared-use
+                                       (cons (syntax-local-introduce #'form)
+                                             (or (syntax-property r 'disappeared-use)
+                                                 null))))
+                    (eloop #f)))))]
+         [[(id ...) (:do-in . body)]
+          (syntax-case #'body ()
+            [(([(outer-id ...) outer-rhs] ...)
+              outer-check
+              ([loop-id loop-expr] ...)
+              pos-guard
+              ([(inner-id ...) inner-rhs] ...)
+              pre-guard
+              post-guard
+              (loop-arg ...)) #'body]
+            [else (raise-syntax-error #f "bad :do-in clause" orig-stx clause)])]
+         [[(id) (values rhs)]
+          (expand-clause orig-stx #'[(id) rhs])]
+         [[(id ...) (in-parallel rhs ...)]
+          (and (= (length (syntax->list #'(id ...)))
+                  (length (syntax->list #'(rhs ...)))))
+          ;; flatten in-parallel iterations:
+          (with-syntax ([(((outer-binding ...)
+                           outer-check
+                           (loop-binding ...)
+                           pos-guard
+                           (inner-binding ...)
+                           pre-guard
+                           post-guard
+                           (loop-arg ...)) ...)
+                         (map (lambda (id rhs)
+                                (expand-clause orig-stx #`[(#,id) #,rhs]))
+                              (syntax->list #'(id ...))
+                              (syntax->list #'(rhs ...)))])
+            #`((outer-binding ... ...)
+               (and outer-check ...)
+               (loop-binding ... ...)
+               (and pos-guard ...)
+               (inner-binding ... ...)
+               (and pre-guard ...)
+               (and post-guard ...)
+               (loop-arg ... ...)))]
+         [[(id ...) (stop-before gen-expr pred)]
+          (with-syntax ([((outer-binding ...)
+                          outer-check
+                          (loop-binding ...)
+                          pos-guard
+                          (inner-binding ...)
+                          pre-guard
+                          post-guard
+                          (loop-arg ...))
+                         (expand-clause orig-stx #`[(id ...) gen-expr])])
+            #`((outer-binding ...)
                outer-check
-               ([loop-id loop-expr] ...)
+               (loop-binding ...)
                pos-guard
-               ([(inner-id ...) inner-rhs] ...)
-               pre-guard
+               (inner-binding ...)
+               (and pre-guard (not (pred id ...)))
                post-guard
-               (loop-arg ...)) #'body]
-             [else (raise-syntax-error #f "bad :do-in clause" orig-stx clause)])]
-          [[(id) (values rhs)]
-           (expand-clause orig-stx #'[(id) rhs])]
-          [[(id ...) (in-parallel rhs ...)]
-           (and (= (length (syntax->list #'(id ...)))
-                   (length (syntax->list #'(rhs ...)))))
-           ;; flatten in-parallel iterations:
-           (with-syntax ([(((outer-binding ...)
-                            outer-check
-                            (loop-binding ...)
-                            pos-guard
-                            (inner-binding ...)
-                            pre-guard
-                            post-guard
-                            (loop-arg ...)) ...)
-                          (map (lambda (id rhs)
-                                 (expand-clause orig-stx #`[(#,id) #,rhs]))
-                               (syntax->list #'(id ...))
-                               (syntax->list #'(rhs ...)))])
-             #`((outer-binding ... ...)
-                (and outer-check ...)
-                (loop-binding ... ...)
-                (and pos-guard ...)
-                (inner-binding ... ...)
-                (and pre-guard ...)
-                (and post-guard ...)
-                (loop-arg ... ...)))]
-          [[(id ...) (stop-before gen-expr pred)]
-           (with-syntax ([((outer-binding ...)
-                           outer-check
-                           (loop-binding ...)
-                           pos-guard
-                           (inner-binding ...)
-                           pre-guard
-                           post-guard
-                           (loop-arg ...))
-                          (expand-clause orig-stx #`[(id ...) gen-expr])])
-             #`((outer-binding ...)
-                outer-check
-                (loop-binding ...)
-                pos-guard
-                (inner-binding ...)
-                (and pre-guard (not (pred id ...)))
-                post-guard
-                (loop-arg ...)))]
-          [[(id ...) (stop-after gen-expr pred)]
-           (with-syntax ([((outer-binding ...)
-                           outer-check
-                           (loop-binding ...)
-                           pos-guard
-                           (inner-binding ...)
-                           pre-guard
-                           post-guard
-                           (loop-arg ...))
-                          (expand-clause orig-stx #`[(id ...) gen-expr])])
-             #`((outer-binding ...)
-                outer-check
-                (loop-binding ...)
-                pos-guard
-                (inner-binding ...)
-                pre-guard
-                (and post-guard (not (pred id ...)))
-                (loop-arg ...)))]
-          [[(id ...) rhs]
-           (let ([introducer (make-syntax-introducer)])
-             (with-syntax ([[(id ...) rhs] (introducer (syntax-local-introduce clause))])
-               (syntax-local-introduce
-                (introducer
-                 #`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?)
-                      (#,((syntax-local-certifier #f) #'make-sequence) '(id ...) rhs)])
-                    (void)
-                    ([pos init])
-                    (pos-cont? pos)
-                    ([(id ...) (pos->vals pos)])
-                    (val-cont? id ...)
-                    (all-cont? pos id ...)
-                    ((pos-next pos)))))))]
-          [_
-           (raise-syntax-error #f
-             "bad sequence binding clause" orig-stx clause)]))))
+               (loop-arg ...)))]
+         [[(id ...) (stop-after gen-expr pred)]
+          (with-syntax ([((outer-binding ...)
+                          outer-check
+                          (loop-binding ...)
+                          pos-guard
+                          (inner-binding ...)
+                          pre-guard
+                          post-guard
+                          (loop-arg ...))
+                         (expand-clause orig-stx #`[(id ...) gen-expr])])
+            #`((outer-binding ...)
+               outer-check
+               (loop-binding ...)
+               pos-guard
+               (inner-binding ...)
+               pre-guard
+               (and post-guard (not (pred id ...)))
+               (loop-arg ...)))]
+         [[(id ...) rhs]
+          (let ([introducer (make-syntax-introducer)])
+            (with-syntax ([[(id ...) rhs] (introducer (syntax-local-introduce clause))])
+              (syntax-local-introduce
+               (introducer
+                #`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?)
+                     (#,((syntax-local-certifier #f) #'make-sequence) '(id ...) rhs)])
+                   (void)
+                   ([pos init])
+                   (pos-cont? pos)
+                   ([(id ...) (pos->vals pos)])
+                   (val-cont? id ...)
+                   (all-cont? pos id ...)
+                   ((pos-next pos)))))))]
+         [_
+          (raise-syntax-error #f
+                              "bad sequence binding clause" orig-stx clause)]))))
+
+  (define-syntax (:do-in stx)
+    (raise-syntax-error #f
+      "illegal outside of a loop or comprehension binding" stx))
+
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;  sequences
 
-  ;; Also see for-base.rkt
+  (define-values (struct:do-sequence
+                  make-do-sequence
+                  do-sequence?
+                  do-sequence-ref
+                  do-sequence-set!)
+    (make-struct-type 'sequence #f 1 0 #f))
+
+  (define-values (prop:sequence :sequence? :sequence-ref)
+    (make-struct-type-property
+     'sequence
+     (lambda (v sinfo)
+       (unless (and (procedure? v) (procedure-arity-includes? v 1))
+         (raise-type-error 'sequence-property-guard "procedure (arity 1)" v))
+       (lambda (self)
+         (let ([s (v self)])
+           (unless (sequence? s)
+             (raise-mismatch-error
+              'sequence-generate
+              "procedure (value of prop:sequence) produced a non-sequence: "
+              s))
+           s)))))
+
+  (define-syntax define-sequence-syntax
+    (syntax-rules ()
+      [(_ id expr-transformer-expr clause-transformer-expr)
+       (define-syntax id
+         (create-sequence-transformer expr-transformer-expr
+                                      clause-transformer-expr
+                                      (syntax-local-certifier #f)))]))
+
+  (define (sequence? v)
+    (or (do-sequence? v)
+        (list? v)
+        (mpair? v)
+        (vector? v)
+        (string? v)
+        (bytes? v)
+        (input-port? v)
+        (hash? v)
+        (and (:sequence? v) (not (struct-type? v)))))
 
   (define (make-sequence who v)
     (cond
@@ -397,6 +474,186 @@
             void
             void))
 
+  ;; Vector-like sequences --------------------------------------------------
+
+  ;; (: check-ranges (Symbol Natural Natural Integer -> Void))
+  (define (check-ranges who start stop step)
+    (unless (exact-nonnegative-integer? start) (raise-type-error who "exact non-negative integer" start))
+    (unless (exact-nonnegative-integer? stop) (raise-type-error who "exact non-negative integer or #f" stop))
+    (unless (and (exact-integer? step) (not (zero? step)))
+      (raise-type-error who "exact non-zero integer" step))
+    (when (and (< start stop) (< step 0))
+      (raise-mismatch-error who (format "start: ~a less than stop: ~a but given negative step: "
+                                        start stop)
+                            step))
+    (when (and (< stop start) (> step 0))
+      (raise-mismatch-error who (format "start: ~a more than stop: ~a but given positive step: "
+                                        start stop)
+                            step)))
+
+  (define-syntax define-in-vector-like
+    (syntax-rules ()
+      [(define-in-vector-like in-vector-name
+         type-name-str vector?-id vector-length-id :vector-gen-id)
+       (define in-vector-name
+        (case-lambda
+          [(v) (in-vector-name v 0 #f 1)]
+          [(v start) (in-vector-name v start #f 1)]
+          [(v start stop) (in-vector-name v start stop 1)]
+          [(v start stop step)
+           (unless (vector?-id v) (raise-type-error (quote in-vector-name) type-name-str v))
+           (let ([stop (or stop (vector-length-id v))])
+             (check-ranges (quote in-vector-name) start stop step)
+             (make-do-sequence (lambda () (:vector-gen-id v start stop step))))]))]))
+
+  (define-syntax define-:vector-like-gen
+    (syntax-rules ()
+      [(define-:vector-like-gen :vector-like-name unsafe-vector-ref-id)
+       (define (:vector-like-name v start stop step)
+         (values
+          ;; pos->element
+          (lambda (i) (unsafe-vector-ref-id v i))
+          ;; next-pos
+          ;; Minor optimisation.  I assume add1 is faster than \x.x+1
+          (if (= step 1) add1 (lambda (i) (+ i step)))
+          ;; initial pos
+          start
+          ;; continue?
+          (if (> step 0)
+              (lambda (i) (< i stop))
+              (lambda (i) (> i stop)))
+          void
+          void))]))
+
+  (define-for-syntax (make-in-vector-like vector?-id
+                                          unsafe-vector-length-id
+                                          in-vector-id
+                                          unsafe-vector-ref-id)
+     (define (in-vector-like stx)
+       (with-syntax ([vector? vector?-id]
+                     [in-vector in-vector-id]
+                     [unsafe-vector-length unsafe-vector-length-id]
+                     [unsafe-vector-ref unsafe-vector-ref-id])
+         (syntax-case stx ()
+           ;; Fast case
+           [[(id) (_ vec-expr)]
+            #'[(id)
+               (:do-in
+                ;;outer bindings
+                ([(vec len) (let ([vec vec-expr])
+                              (unless (vector? vec)
+                                (in-vector vec))
+                              (values vec (unsafe-vector-length vec)))])
+                ;; outer check
+                #f
+                ;; loop bindings
+                ([pos 0])
+                ;; pos check
+                (pos . unsafe-fx< . len)
+                ;; inner bindings
+                ([(id) (unsafe-vector-ref vec pos)])
+                ;; pre guard
+                #t
+                ;; post guard
+                #t
+                ;; loop args
+                ((unsafe-fx+ 1 pos)))]]
+           ;; General case
+           [((id) (_ vec-expr start))
+            (in-vector-like (syntax ((id) (_ vec-expr start #f 1))))]
+           [((id) (_ vec-expr start stop))
+            (in-vector-like (syntax ((id) (_ vec-expr start stop 1))))]
+           [((id) (_ vec-expr start stop step))
+            (let ([all-fx? (memq (syntax-e #'step) '(1 -1))])
+              #`[(id)
+                 (:do-in
+                  ;; Outer bindings
+                  ;; Prevent multiple evaluation
+                  ([(v* stop*) (let ([vec vec-expr]
+                                     [stop* stop])
+                                 (if (and (not stop*) (vector? vec))
+                                     (values vec (unsafe-vector-length vec))
+                                     (values vec stop*)))]
+                   [(start*) start]
+                   [(step*) step])
+                  ;; Outer check
+                  (when (or (not (vector? v*))
+                            (not (exact-integer? start*))
+                            (not (exact-integer? stop*))
+                            (not (exact-integer? step*))
+                            (zero? step*)
+                            (and (< start* stop*) (< step* 0))
+                            (and (> start* stop*) (> step* 0)))
+                    ;; Let in-vector report the error
+                    (in-vector v* start* stop* step*))
+                  ;; Loop bindings
+                  ([idx start*])
+                  ;; Pos guard
+                  #,(cond
+                     [(not (number? (syntax-e #'step)))
+                      #`(if (step* . >= . 0) (< idx stop*) (> idx stop*))]
+                     [((syntax-e #'step) . >= . 0)
+                      (if all-fx?
+                          #'(unsafe-fx< idx stop*)
+                          #'(< idx stop*))]
+                     [else
+                      (if all-fx?
+                          #'(unsafe-fx> idx stop*)
+                          #'(> idx stop*))])
+                  ;; Inner bindings
+                  ([(id) (unsafe-vector-ref v* idx)])
+                  ;; Pre guard
+                  #t
+                  ;; Post guard
+                  #t
+                  ;; Loop args
+                  ((#,(if all-fx? #'unsafe-fx+ #'+) idx step)))])]
+           [_ #f])))
+          in-vector-like)
+
+  
+  (define-:vector-like-gen :vector-gen unsafe-vector-ref)
+  
+  (define-in-vector-like in-vector
+    "vector" vector? vector-length :vector-gen)
+
+  (define-sequence-syntax *in-vector
+    (lambda () #'in-vector)
+    (make-in-vector-like #'vector?
+                         #'unsafe-vector-length
+                         #'in-vector
+                         #'unsafe-vector-ref))
+
+  
+  (define-:vector-like-gen :string-gen unsafe-string-ref)
+  
+  (define-in-vector-like in-string
+    "string" string? string-length :string-gen)
+
+  (define-sequence-syntax *in-string
+    (lambda () #'in-string)
+    (make-in-vector-like #'string?
+                         #'string-length
+                         #'in-string
+                         #'string-ref))
+
+  
+  (define-:vector-like-gen :bytes-gen unsafe-bytes-ref)
+  
+  (define-in-vector-like in-bytes
+    "bytes" bytes? bytes-length :bytes-gen)
+
+  (define-sequence-syntax *in-bytes
+    (lambda () #'in-bytes)
+    (make-in-vector-like #'bytes?
+                         #'bytes-length
+                         #'in-bytes
+                         #'bytes-ref))
+  
+
+  ;; ------------------------------------------------------------------------
+  
+  
   (define (stop-before g pred)
     (unless (sequence? g) (raise-type-error 'stop-before "sequence" g))
     (unless (and (procedure? pred)