[racket-dev] Wrapping loops for TR isn't working, and the type annotations are for the wrong value

I've attached my latest. It's possibly better.

On 08/15/2012 08:05 AM, Sam Tobin-Hochstadt wrote:
> So then the first value computed is replicated everywhere?  That seems
> unappealing as well.

I've implemented #:fill in this one. If both #:length and #:fill are 
given, the vector is created with the fill value. If only #:fill is 
given, it's a syntax error. If only #:length is given, it fills the 
vector with the first computed value.

> Also, is there any way you could generate code that uses a binding,
> instead of `set!`?  That will probably improve the performance.

I tried, but `for/fold:' doesn't handle #:when, and `for*/fold:' doesn't 
work at all.

>> I think I could work one up that expands to code with annotations when used
>> from TR and to code without annotations otherwise. I'd use the
>> "maybe-annotate" macro (`ann:') for every annotation, not just for
>> annotating with the optional result and body types.
>
> I don't think that's a good idea -- then `racket/base` would have to
> expand to Typed Racket-specific code.  Is there a way that you can
> come up with an abstraction that is oblivious to Typed Racket?

This version defines a macro `base-for/vector'. Example:

   (base-for/vector for ann T K (clauses ...) body-expr)

  * `for': the loop macro to use (e.g. `for', `for:', `for*:')
  * `ann': `ann' from TR, or an untyped Racket macro s.t. (ann v t) --> v
  * T: the vector type
  * K: the escape continuation type (e.g. ((T -> Nothing) -> T))
  * body-expr: a single body expression (e.g. (let () body ...) or (ann 
(let () body ...) A))

I'm not thrilled about the parameters, but it should work.

Neil ⊥

-------------- next part --------------
#lang typed/racket/base

(require racket/vector
         (for-syntax racket/base syntax/parse)
         racket/unsafe/ops)

(provide for/vector: for*/vector:)

(define-syntax (base-for/vector stx)
  (syntax-case stx ()
    [(name for ann T K #:length n-expr #:fill fill-expr (clauses ...) body-expr)
     (syntax/loc stx
       (call/ec
        (ann (λ (break)
               (define n n-expr)
               (define vs (ann (make-vector n fill-expr) T))
               (define i 0)
               (for (clauses ...)
                 (unsafe-vector-set! vs i body-expr)
                 (set! i (unsafe-fx+ i 1))
                 (when (i . unsafe-fx>= . n) (break vs)))
               vs)
             K)))]
    [(name for ann T K #:length n-expr (clauses ...) body-expr)
     (syntax/loc stx
       (let ([n n-expr])
         (define vs
           (call/ec
            (ann (λ (break)
                   (define vs (ann (vector) T))
                   (define i 0)
                   (for (clauses ...)
                     (define v body-expr)
                     (cond [(unsafe-fx= i 0)  (define new-vs (ann (make-vector n v) T))
                                              (set! vs new-vs)]
                           [else  (unsafe-vector-set! vs i v)])
                     (set! i (unsafe-fx+ i 1))
                     (when (i . unsafe-fx>= . n) (break vs)))
                   vs)
                 K)))
         (cond [(= (vector-length vs) n)  vs]
               [else
                ;; Only happens when n > 0 and vs = (vector)
                (error 'name "expected ~e elements; produced ~e" n (vector-length vs))])))]
    [(_ for ann T K (clauses ...) body-expr)
     (syntax/loc stx
       (let ()
         (define n 0)
         (define vs (ann (vector) T))
         (define i 0)
         (for (clauses ...)
           (define v body-expr)
           (cond [(unsafe-fx= i n)  (define new-n (max 4 (unsafe-fx* 2 n)))
                                    (define new-vs (ann (make-vector new-n v) T))
                                    (vector-copy! new-vs 0 vs)
                                    (set! n new-n)
                                    (set! vs new-vs)]
                 [else  (unsafe-vector-set! vs i v)])
           (set! i (unsafe-fx+ i 1)))
         (vector-copy vs 0 i)))]))

(define-for-syntax (base-for/vector: stx for:)
  (syntax-parse stx #:literals (:)
    [(name (~optional (~seq : T:expr))
           (~optional (~seq #:length n-expr:expr))
           (~optional (~seq #:fill fill-expr:expr))
           (clauses ...)
           (~optional (~seq : A:expr))
           body ...+)
     (let ([T  (attribute T)]
           [A  (attribute A)])
       (with-syntax ([(maybe-length ...)  (if (attribute n-expr) #'(#:length n-expr) #'())]
                     [(maybe-fill ...)  (if (attribute fill-expr) #'(#:fill fill-expr) #'())]
                     [body-expr  (if A #`(ann (let () body ...) #,A) #'(let () body ...))]
                     [T  (cond [(and T A)  #`(U #,T (Vectorof #,A))]
                               [T  T]
                               [A  #`(Vectorof #,A)]
                               [else  #'(Vectorof Any)])])
         (quasisyntax/loc stx
           (base-for/vector #,for: ann T ((T -> Nothing) -> T)
                            maybe-length ... maybe-fill ... (clauses ...) body-expr))))]))

(define-syntax (for/vector: stx)
  (base-for/vector: stx #'for:))

(define-syntax (for*/vector: stx)
  (base-for/vector: stx #'for*:))