[vector] works for no-colon, too
This commit is contained in:
ben
parent
62109f33db
commit
cdae13498c
|
|
@ -20,6 +20,7 @@
|
|||
;; TODO
|
||||
|
||||
make-alias
|
||||
make-keyword-alias
|
||||
;; TODO
|
||||
)
|
||||
|
||||
|
|
@ -125,9 +126,16 @@
|
|||
(or (parser stx)
|
||||
(syntax-parse stx
|
||||
[_:id
|
||||
#:with id-stx (format-id stx "~a" id-sym)
|
||||
#:with id-stx (format-id id-sym "~a" (syntax-e id-sym))
|
||||
(syntax/loc stx id-stx)]
|
||||
[(_ e* ...)
|
||||
#:with id-stx (format-id stx "~a" id-sym)
|
||||
#:with id-stx (format-id id-sym "~a" (syntax-e id-sym))
|
||||
#:with app-stx (format-id stx "#%app")
|
||||
(syntax/loc stx (app-stx id-stx e* ...))])))
|
||||
|
||||
(define ((make-keyword-alias id-sym parser) stx)
|
||||
(or (parser stx)
|
||||
(syntax-parse stx
|
||||
[(_ e* ...)
|
||||
#:with id-stx (format-id stx "~a" id-sym)
|
||||
(syntax/loc stx (id-stx e* ...))])))
|
||||
|
|
|
|||
|
|
@ -3,8 +3,6 @@
|
|||
;; Constant-folding math operators.
|
||||
;; Where possible, they simplify their arguments.
|
||||
|
||||
;; TODO the or- stuff is not so pretty, but it's working anyway
|
||||
|
||||
(provide
|
||||
+: -: *: /:
|
||||
;; Same signature as the racket/base operators,
|
||||
|
|
@ -16,6 +14,7 @@
|
|||
|
||||
;; --
|
||||
(for-syntax
|
||||
stx->num
|
||||
nat/expand
|
||||
int/expand
|
||||
num/expand)
|
||||
|
|
@ -36,6 +35,14 @@
|
|||
(define (division-by-zero stx)
|
||||
(raise-syntax-error '/ "division by zero" stx))
|
||||
|
||||
(define (stx->num stx)
|
||||
(syntax-parse stx
|
||||
[v:num/expand
|
||||
(if (identifier? #'v.expanded)
|
||||
(quoted-stx-value? #'v.evidence)
|
||||
(quoted-stx-value? #'v.expanded))]
|
||||
[_ #f]))
|
||||
|
||||
;; Simplify a list of expressions using an associative binary operator.
|
||||
;; Return either:
|
||||
;; - A numeric value
|
||||
|
|
@ -53,21 +60,18 @@
|
|||
prev
|
||||
(reverse (if prev (cons prev acc) acc)))
|
||||
;; else: pop the next argument from e*, fold if it's a constant
|
||||
(syntax-parse (car e*)
|
||||
[v:num/expand
|
||||
(define v (or (quoted-stx-value? #'v.expanded)
|
||||
(quoted-stx-value? #'v.evidence)))
|
||||
;; then: reduce the number
|
||||
(if prev
|
||||
;; Watch for division-by-zero
|
||||
(if (and (zero? v) (eq? / op))
|
||||
(division-by-zero stx)
|
||||
(loop (op prev v) acc (cdr e*)))
|
||||
(loop v acc (cdr e*)))]
|
||||
[v
|
||||
;; else: save value in acc
|
||||
(let ([acc+ (cons (car e*) (if prev (cons prev acc) acc))])
|
||||
(loop #f acc+ (cdr e*)))])))]
|
||||
(let ([v (stx->num (car e*))])
|
||||
(if v
|
||||
;; then: reduce the number
|
||||
(if prev
|
||||
;; Watch for division-by-zero
|
||||
(if (and (zero? v) (eq? / op))
|
||||
(division-by-zero stx)
|
||||
(loop (op prev v) acc (cdr e*)))
|
||||
(loop v acc (cdr e*)))
|
||||
;; else: save value in acc
|
||||
(let ([acc+ (cons (car e*) (if prev (cons prev acc) acc))])
|
||||
(loop #f acc+ (cdr e*)))))))]
|
||||
[else #f]))
|
||||
|
||||
(define-values (nat-key nat? nat-define nat-let)
|
||||
|
|
@ -85,8 +89,8 @@
|
|||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define-syntax define-num: (make-alias 'define num-define))
|
||||
(define-syntax let-num: (make-alias 'let num-let))
|
||||
(define-syntax define-num: (make-keyword-alias 'define num-define))
|
||||
(define-syntax let-num: (make-keyword-alias 'let num-let))
|
||||
|
||||
(define-syntax make-numeric-operator
|
||||
(syntax-parser
|
||||
|
|
@ -109,11 +113,9 @@
|
|||
|
||||
(define-syntax expt: (make-alias 'expt
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ n1:num/expand n2:num/expand)
|
||||
(let ([v1 (or (quoted-stx-value? #'n1.expanded)
|
||||
(quoted-stx-value? #'n1.evidence))]
|
||||
[v2 (or (quoted-stx-value? #'n2.expanded)
|
||||
(quoted-stx-value? #'n2.evidence))])
|
||||
[(_ n1 n2)
|
||||
(let ([v1 (stx->num #'n1)]
|
||||
[v2 (stx->num #'n2)])
|
||||
(and v1 v2 ;; Should never fail
|
||||
(quasisyntax/loc stx #,(expt v1 v2))))]
|
||||
[_ #f]))))
|
||||
|
|
|
|||
257
private/vector.rkt
Normal file
257
private/vector.rkt
Normal file
|
|
@ -0,0 +1,257 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(provide
|
||||
define-vector:
|
||||
let-vector:
|
||||
vector-length:
|
||||
vector-ref:
|
||||
vector-set!:
|
||||
vector-map:
|
||||
vector-map!:
|
||||
vector-append:
|
||||
vector->list:
|
||||
vector->immutable-vector:
|
||||
vector-fill!:
|
||||
vector-take:
|
||||
vector-take-right:
|
||||
vector-drop:
|
||||
vector-drop-right:
|
||||
; vector-split-at:
|
||||
; vector-split-at-right:
|
||||
|
||||
;; --- private
|
||||
(for-syntax parse-vector-length)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(require
|
||||
(only-in racket/unsafe/ops
|
||||
unsafe-vector-set!
|
||||
unsafe-vector-ref)
|
||||
trivial/private/math
|
||||
racket/vector
|
||||
(for-syntax
|
||||
trivial/private/common
|
||||
typed/racket/base
|
||||
syntax/parse))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(begin-for-syntax
|
||||
(define (small-vector-size? n)
|
||||
(< n 20))
|
||||
|
||||
(define (vector-bounds-error sym v-stx i)
|
||||
(raise-syntax-error
|
||||
sym
|
||||
"Index out-of-bounds"
|
||||
(syntax->datum v-stx)
|
||||
i
|
||||
(list v-stx)))
|
||||
|
||||
(define (parse-vector-length stx)
|
||||
(syntax-parse stx #:literals (#%plain-app vector make-vector build-vector)
|
||||
[(~or '#(e* ...)
|
||||
#(e* ...)
|
||||
;; TODO #{} #[] #6{} ...
|
||||
(#%plain-app vector e* ...)
|
||||
(vector e* ...))
|
||||
(length (syntax-e #'(e* ...)))]
|
||||
[(~or (make-vector n e* ...)
|
||||
(#%plain-app make-vector n e* ...)
|
||||
(build-vector n e* ...)
|
||||
(#%plain-app build-vector n e* ...))
|
||||
#:with n-stx (stx->num #'n)
|
||||
#:when (syntax-e #'n-stx)
|
||||
(syntax-e #'n-stx)]
|
||||
[_ #f]))
|
||||
|
||||
(define-values (vector-length-key vec? vec-define vec-let)
|
||||
(make-value-property 'vector:length parse-vector-length))
|
||||
(define-syntax-class/predicate vector/length vec?)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define-syntax define-vector: (make-keyword-alias 'define vec-define))
|
||||
(define-syntax let-vector: (make-keyword-alias 'let vec-let))
|
||||
|
||||
(define-syntax vector-length: (make-alias #'vector-length
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ v:vector/length)
|
||||
(syntax/loc stx 'v.evidence)]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector-ref: (make-alias #'vector-ref
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ v:vector/length e)
|
||||
#:with i-stx (stx->num #'e)
|
||||
#:when (syntax-e #'i-stx)
|
||||
(let ([i (syntax-e #'i-stx)])
|
||||
(unless (< i (syntax-e #'v.evidence))
|
||||
(vector-bounds-error 'vector-ref: #'v i))
|
||||
(syntax/loc stx (unsafe-vector-ref v.expanded 'i-stx)))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector-set!: (make-alias #'vector-set!
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ v:vector/length e val)
|
||||
#:with i-stx (stx->num #'e)
|
||||
#:when (syntax-e #'i-stx)
|
||||
(let ([i (syntax-e #'i-stx)])
|
||||
(unless (< i (syntax-e #'v.evidence))
|
||||
(vector-bounds-error 'vector-set!: #'v i))
|
||||
(syntax/loc stx (unsafe-vector-set! v.expanded 'i-stx val)))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector-map: (make-alias #'vector-map
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ f v:vector/length)
|
||||
#:with f+ (gensym 'f)
|
||||
#:with v+ (gensym 'v)
|
||||
#:with v++ (syntax-property
|
||||
(if (small-vector-size? (syntax-e #'v.evidence))
|
||||
(with-syntax ([(i* ...) (for/list ([i (in-range (syntax-e #'v.evidence))]) i)])
|
||||
(syntax/loc stx
|
||||
(let ([f+ f] [v+ v.expanded])
|
||||
(vector (f+ (unsafe-vector-ref v+ 'i*)) ...))))
|
||||
(syntax/loc stx
|
||||
(let ([f+ f] [v+ v.expanded])
|
||||
(build-vector 'v.evidence (lambda ([i : Integer])
|
||||
(f+ (vector-ref: v+ i)))))))
|
||||
vector-length-key
|
||||
(syntax-e #'v.evidence))
|
||||
(syntax/loc stx v++)]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector-map!: (make-alias #'vector-map!
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ f v:vector/length)
|
||||
#:with f+ (gensym 'f)
|
||||
#:with v+ (gensym 'v)
|
||||
#:with v++ (syntax-property
|
||||
#'(let ([f+ f]
|
||||
[v+ v.expanded])
|
||||
(for ([i (in-range 'v.evidence)])
|
||||
(unsafe-vector-set! v+ i (f+ (unsafe-vector-ref v+ i))))
|
||||
v+)
|
||||
vector-length-key
|
||||
(syntax-e #'v.evidence))
|
||||
(syntax/loc stx v++)]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector-append: (make-alias #'vector-append
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ v1:vector/length v2:vector/length)
|
||||
#:with v1+ (gensym 'v1)
|
||||
#:with v2+ (gensym 'v2)
|
||||
(define l1 (syntax-e #'v1.evidence))
|
||||
(define l2 (syntax-e #'v2.evidence))
|
||||
(syntax-property
|
||||
(if (and (small-vector-size? l1)
|
||||
(small-vector-size? l2))
|
||||
(with-syntax ([(i1* ...) (for/list ([i (in-range l1)]) i)]
|
||||
[(i2* ...) (for/list ([i (in-range l2)]) i)])
|
||||
(syntax/loc stx
|
||||
(let ([v1+ v1.expanded]
|
||||
[v2+ v2.expanded])
|
||||
(vector (vector-ref: v1+ i1*) ...
|
||||
(vector-ref: v2+ i2*) ...))))
|
||||
(quasisyntax/loc stx
|
||||
(let ([v1+ v1.expanded]
|
||||
[v2+ v2.expanded])
|
||||
(build-vector
|
||||
#,(+ l1 l2)
|
||||
(lambda (i)
|
||||
(if (< i '#,l1)
|
||||
(unsafe-vector-ref v1+ i)
|
||||
(unsafe-vector-ref v2+ i)))))))
|
||||
vector-length-key
|
||||
(+ l1 l2))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector->list: (make-alias #'vector->list
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ v:vector/length)
|
||||
#:with v+ (gensym 'v)
|
||||
(define len (syntax-e #'v.evidence))
|
||||
(if (small-vector-size? len)
|
||||
(with-syntax ([(i* ...) (for/list ([i (in-range len)]) i)])
|
||||
(syntax/loc stx
|
||||
(let ([v+ v.expanded])
|
||||
(list (unsafe-vector-ref v+ i*) ...))))
|
||||
(syntax/loc stx
|
||||
(let ([v+ v.expanded])
|
||||
(build-list 'v.evidence (lambda (i) (unsafe-vector-ref v+ i))))))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector->immutable-vector: (make-alias #'vector->immutable-vector
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ v:vector/length)
|
||||
(syntax-property
|
||||
(syntax/loc stx (vector->immutable-vector v.expanded))
|
||||
vector-length-key
|
||||
(syntax-e #'v.evidence))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector-fill!: (make-alias #'vector-fill!
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ v:vector/length val)
|
||||
#:with v+ (gensym 'v)
|
||||
(define len (syntax-e #'v.evidence))
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(let ([v+ v.expanded])
|
||||
(for ([i (in-range 'v.evidence)])
|
||||
(unsafe-vector-set! v+ i val))))
|
||||
vector-length-key
|
||||
(syntax-e #'v.evidence))]
|
||||
[_ #f]))))
|
||||
|
||||
(begin-for-syntax (define-syntax-rule (make-slice-op left? take?)
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(op-name v:vector/length n)
|
||||
#:with n-stx (stx->num #'n)
|
||||
#:when (exact-nonnegative-integer? (syntax-e #'n-stx))
|
||||
#:with (lo hi)
|
||||
(if 'take?
|
||||
(if 'left?
|
||||
(list 0 (syntax-e #'n-stx))
|
||||
(list
|
||||
(- (syntax-e #'v.evidence) (syntax-e #'n-stx))
|
||||
(syntax-e #'v.evidence)))
|
||||
(if 'left?
|
||||
(list (syntax-e #'n-stx) (syntax-e #'v.evidence))
|
||||
(list 0 (- (syntax-e #'v.evidence) (syntax-e #'n-stx)))))
|
||||
#:with n+ (gensym 'n)
|
||||
#:with v+ (gensym 'v)
|
||||
(unless (<= (syntax-e #'n-stx) (syntax-e #'v.evidence))
|
||||
(vector-bounds-error (syntax-e #'op-name) #'v
|
||||
(if 'take? (if 'left? (syntax-e #'hi) (syntax-e #'lo))
|
||||
(if 'left? (syntax-e #'lo) (syntax-e #'hi)))))
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(let ([v+ v.expanded]
|
||||
[n+ (-: 'hi 'lo)])
|
||||
(build-vector n+ (lambda ([i : Integer]) (unsafe-vector-ref v+ (+: i 'lo))))))
|
||||
vector-length-key
|
||||
(syntax-e #'v.evidence))]
|
||||
[(op-name v n:int/expand)
|
||||
(vector-bounds-error (syntax-e #'op-name) #'v (stx->num #'n.expanded))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax vector-take:
|
||||
(make-alias #'vector-take (make-slice-op #t #t)))
|
||||
|
||||
(define-syntax vector-take-right:
|
||||
(make-alias #'vector-take-right (make-slice-op #f #t)))
|
||||
|
||||
(define-syntax vector-drop-right:
|
||||
(make-alias #'vector-drop-right (make-slice-op #f #f)))
|
||||
|
||||
(define-syntax vector-drop:
|
||||
(make-alias #'vector-drop (make-slice-op #t #f)))
|
||||
|
||||
|
||||
|
|
@ -6,58 +6,6 @@
|
|||
trivial/vector
|
||||
typed/rackunit)
|
||||
|
||||
(require/typed (for-template trivial/vector)
|
||||
(parse-vector-length (-> Syntax (Option Natural))))
|
||||
|
||||
;; -- parse-vector-length
|
||||
;; --- '#
|
||||
(check-equal?
|
||||
(parse-vector-length #'#())
|
||||
0)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #`#,'#(1 2))
|
||||
; 2)
|
||||
(check-equal?
|
||||
(parse-vector-length #'#(1 2 3 4))
|
||||
4)
|
||||
(check-equal?
|
||||
(parse-vector-length #'#(a b c e s aue d al))
|
||||
8)
|
||||
;; --- vector
|
||||
(check-equal?
|
||||
(parse-vector-length #'(vector))
|
||||
0)
|
||||
(check-equal?
|
||||
(parse-vector-length #'(vector 0 1))
|
||||
2)
|
||||
;; --- make-vector
|
||||
(check-equal?
|
||||
(parse-vector-length #'(make-vector -1 1))
|
||||
#f)
|
||||
(check-equal?
|
||||
(parse-vector-length #'(make-vector 0 8))
|
||||
0)
|
||||
(check-equal?
|
||||
(parse-vector-length #'(make-vector 3 3))
|
||||
3)
|
||||
(check-equal?
|
||||
(parse-vector-length #'(make-vector 99))
|
||||
99)
|
||||
;; --- build-vector
|
||||
(check-equal?
|
||||
;; Type error
|
||||
(parse-vector-length #'(build-vector -1))
|
||||
#f)
|
||||
(check-equal?
|
||||
(parse-vector-length #'(build-vector 0 (lambda (x) x)))
|
||||
0)
|
||||
(check-equal?
|
||||
(parse-vector-length #'(build-vector 3 (lambda (x) 8)))
|
||||
3)
|
||||
(check-equal?
|
||||
(parse-vector-length #'(build-vector 61 add1))
|
||||
61)
|
||||
|
||||
;; -- vector-length:
|
||||
(check-equal?
|
||||
(vector-length: '#()) 0)
|
||||
|
|
@ -304,3 +252,53 @@
|
|||
(check-equal? (vector-ref: v 0) 1))
|
||||
;; -- let-vector:
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
; ;; -- parse-vector-length
|
||||
; ;; --- '#
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'#())
|
||||
; 0)
|
||||
;; (check-equal?
|
||||
;; (parse-vector-length #`#,'#(1 2))
|
||||
;; 2)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'#(1 2 3 4))
|
||||
; 4)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'#(a b c e s aue d al))
|
||||
; 8)
|
||||
; ;; --- vector
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(vector))
|
||||
; 0)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(vector 0 1))
|
||||
; 2)
|
||||
; ;; --- make-vector
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(make-vector -1 1))
|
||||
; #f)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(make-vector 0 8))
|
||||
; 0)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(make-vector 3 3))
|
||||
; 3)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(make-vector 99))
|
||||
; 99)
|
||||
; ;; --- build-vector
|
||||
; (check-equal?
|
||||
; ;; Type error
|
||||
; (parse-vector-length #'(build-vector -1))
|
||||
; #f)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(build-vector 0 (lambda (x) x)))
|
||||
; 0)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(build-vector 3 (lambda (x) 8)))
|
||||
; 3)
|
||||
; (check-equal?
|
||||
; (parse-vector-length #'(build-vector 61 add1))
|
||||
; 61)
|
||||
|
|
|
|||
298
vector.rkt
298
vector.rkt
|
|
@ -1,8 +1,8 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
;; TOOD abstract some designs
|
||||
|
||||
(provide
|
||||
(all-from-out racket/vector)
|
||||
|
||||
define-vector:
|
||||
let-vector:
|
||||
vector-length:
|
||||
|
|
@ -20,288 +20,26 @@
|
|||
vector-drop-right:
|
||||
; vector-split-at:
|
||||
; vector-split-at-right:
|
||||
|
||||
;; --- private
|
||||
(for-syntax parse-vector-length)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(require
|
||||
(only-in racket/unsafe/ops
|
||||
unsafe-vector-set!
|
||||
unsafe-vector-ref)
|
||||
racket/vector
|
||||
trivial/math
|
||||
(for-syntax
|
||||
typed/racket/base
|
||||
racket/syntax
|
||||
syntax/id-table
|
||||
syntax/parse
|
||||
syntax/stx
|
||||
trivial/private/common
|
||||
))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(define-for-syntax vector-length-key 'vector:length)
|
||||
(define-for-syntax id+vector-length (make-free-id-table))
|
||||
|
||||
(begin-for-syntax (define-syntax-class vector/length
|
||||
#:attributes (expanded length)
|
||||
(pattern e
|
||||
#:with e+ (expand-expr #'e)
|
||||
#:with len (parse-vector-length #'e+)
|
||||
#:when (syntax-e #'len)
|
||||
#:attr expanded #'e+
|
||||
#:attr length #'len)
|
||||
(only-in trivial/private/vector
|
||||
define-vector:
|
||||
let-vector:
|
||||
vector-length:
|
||||
vector-ref:
|
||||
vector-set!:
|
||||
vector-map:
|
||||
vector-map!:
|
||||
vector-append:
|
||||
vector->list:
|
||||
vector->immutable-vector:
|
||||
vector-fill!:
|
||||
vector-take:
|
||||
vector-take-right:
|
||||
vector-drop:
|
||||
vector-drop-right:
|
||||
))
|
||||
|
||||
(define-syntax (define-vector: stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:id v:vector/length)
|
||||
(free-id-table-set! id+vector-length #'name (syntax-e #'v.length))
|
||||
#'(define name v.expanded)]
|
||||
[(_ e* ...)
|
||||
#'(define e* ...)]))
|
||||
|
||||
(define-syntax (let-vector: stx)
|
||||
(syntax-parse stx
|
||||
[(_ ([name*:id v*:vector/length] ...) e* ...)
|
||||
#'(let ([name* v*.expanded] ...)
|
||||
(let-syntax ([name* (make-rename-transformer
|
||||
(syntax-property #'name*
|
||||
vector-length-key
|
||||
'v*.length))] ...)
|
||||
e* ...))]
|
||||
[(_ e* ...)
|
||||
#'(let e* ...)]))
|
||||
|
||||
(define-for-syntax (vector-bounds-error sym v-stx i)
|
||||
(raise-syntax-error
|
||||
sym
|
||||
"Index out-of-bounds"
|
||||
(syntax->datum v-stx)
|
||||
i
|
||||
(list v-stx)))
|
||||
|
||||
(define-syntax (vector-length: stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:vector/length)
|
||||
(syntax/loc stx 'v.length)]
|
||||
[_:id
|
||||
(syntax/loc stx vector-length)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector-length e* ...))]))
|
||||
|
||||
(define-syntax (vector-ref: stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:vector/length i:nat/expand)
|
||||
(unless (< (syntax-e #'i.expanded) (syntax-e #'v.length))
|
||||
(vector-bounds-error 'vector-ref: #'v (syntax-e #'i.expanded)))
|
||||
(syntax/loc stx (unsafe-vector-ref v.expanded 'i.expanded))]
|
||||
[_:id
|
||||
(syntax/loc stx vector-ref)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector-ref e* ...))]))
|
||||
|
||||
(define-syntax (vector-set!: stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:vector/length i:nat/expand val)
|
||||
(unless (< (syntax-e #'i.expanded) (syntax-e #'v.length))
|
||||
(vector-bounds-error 'vector-set!: #'v (syntax-e #'i.expanded)))
|
||||
(syntax/loc stx (unsafe-vector-set! v.expanded 'i.expanded val))]
|
||||
[_:id
|
||||
(syntax/loc stx vector-set!)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector-set! e* ...))]))
|
||||
|
||||
(define-syntax (vector-map: stx)
|
||||
(syntax-parse stx
|
||||
[(_ f v:vector/length)
|
||||
#:with f+ (gensym 'f)
|
||||
#:with v+ (gensym 'v)
|
||||
#:with v++ (syntax-property
|
||||
(if (small-vector-size? (syntax-e #'v.length))
|
||||
(with-syntax ([(i* ...) (for/list ([i (in-range (syntax-e #'v.length))]) i)])
|
||||
(syntax/loc stx
|
||||
(let ([f+ f] [v+ v.expanded])
|
||||
(vector (f+ (unsafe-vector-ref v+ 'i*)) ...))))
|
||||
(syntax/loc stx
|
||||
(let ([f+ f] [v+ v.expanded])
|
||||
(build-vector 'v.length (lambda ([i : Integer])
|
||||
(f+ (vector-ref: v+ i)))))))
|
||||
vector-length-key
|
||||
(syntax-e #'v.length))
|
||||
(syntax/loc stx v++)]
|
||||
[_:id
|
||||
(syntax/loc stx vector-map)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector-map e* ...))]))
|
||||
|
||||
(define-syntax (vector-map!: stx)
|
||||
(syntax-parse stx
|
||||
[(_ f v:vector/length)
|
||||
#:with f+ (gensym 'f)
|
||||
#:with v+ (gensym 'v)
|
||||
#:with v++ (syntax-property
|
||||
#'(let ([f+ f]
|
||||
[v+ v.expanded])
|
||||
(for ([i (in-range 'v.length)])
|
||||
(unsafe-vector-set! v+ i (f+ (unsafe-vector-ref v+ i))))
|
||||
v+)
|
||||
vector-length-key
|
||||
(syntax-e #'v.length))
|
||||
(syntax/loc stx v++)]
|
||||
[_:id
|
||||
(syntax/loc stx vector-map!)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector-map! e* ...))]))
|
||||
|
||||
(define-syntax (vector-append: stx)
|
||||
(syntax-parse stx
|
||||
[(_ v1:vector/length v2:vector/length)
|
||||
#:with v1+ (gensym 'v1)
|
||||
#:with v2+ (gensym 'v2)
|
||||
(define l1 (syntax-e #'v1.length))
|
||||
(define l2 (syntax-e #'v2.length))
|
||||
(syntax-property
|
||||
(if (and (small-vector-size? l1)
|
||||
(small-vector-size? l2))
|
||||
(with-syntax ([(i1* ...) (for/list ([i (in-range l1)]) i)]
|
||||
[(i2* ...) (for/list ([i (in-range l2)]) i)])
|
||||
(syntax/loc stx
|
||||
(let ([v1+ v1.expanded]
|
||||
[v2+ v2.expanded])
|
||||
(vector (vector-ref: v1+ i1*) ...
|
||||
(vector-ref: v2+ i2*) ...))))
|
||||
(quasisyntax/loc stx
|
||||
(let ([v1+ v1.expanded]
|
||||
[v2+ v2.expanded])
|
||||
(build-vector
|
||||
#,(+ l1 l2)
|
||||
(lambda (i)
|
||||
(if (< i '#,l1)
|
||||
(unsafe-vector-ref v1+ i)
|
||||
(unsafe-vector-ref v2+ i)))))))
|
||||
vector-length-key
|
||||
(+ l1 l2))]
|
||||
[_:id
|
||||
(syntax/loc stx vector-append)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector-append e* ...))]))
|
||||
|
||||
(define-syntax (vector->list: stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:vector/length)
|
||||
#:with v+ (gensym 'v)
|
||||
(define len (syntax-e #'v.length))
|
||||
(if (small-vector-size? len)
|
||||
(with-syntax ([(i* ...) (for/list ([i (in-range len)]) i)])
|
||||
(syntax/loc stx
|
||||
(let ([v+ v.expanded])
|
||||
(list (unsafe-vector-ref v+ i*) ...))))
|
||||
(syntax/loc stx
|
||||
(let ([v+ v.expanded])
|
||||
(build-list 'v.length (lambda (i) (unsafe-vector-ref v+ i))))))]
|
||||
[_:id
|
||||
(syntax/loc stx vector->list)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector->list e* ...))]))
|
||||
|
||||
(define-syntax (vector->immutable-vector: stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:vector/length)
|
||||
(syntax-property
|
||||
(syntax/loc stx (vector->immutable-vector v.expanded))
|
||||
vector-length-key
|
||||
(syntax-e #'v.length))]
|
||||
[_:id
|
||||
(syntax/loc stx vector->immutable-vector)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector->immutable-vector e* ...))]))
|
||||
|
||||
(define-syntax (vector-fill!: stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:vector/length val)
|
||||
#:with v+ (gensym 'v)
|
||||
(define len (syntax-e #'v.length))
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(let ([v+ v.expanded])
|
||||
(for ([i (in-range 'v.length)])
|
||||
(unsafe-vector-set! v+ i val))))
|
||||
vector-length-key
|
||||
(syntax-e #'v.length))]
|
||||
[_:id
|
||||
(syntax/loc stx vector->fill!)]
|
||||
[(_ e* ...)
|
||||
(syntax/loc stx (vector->fill! e* ...))]))
|
||||
|
||||
(begin-for-syntax (define-syntax-rule (make-slice-op op-name left? take?)
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:vector/length n:nat/expand)
|
||||
#:with (lo hi)
|
||||
(if 'take?
|
||||
(if 'left?
|
||||
(list 0 (syntax-e #'n.expanded))
|
||||
(list
|
||||
(- (syntax-e #'v.length) (syntax-e #'n.expanded))
|
||||
(syntax-e #'v.length)))
|
||||
(if 'left?
|
||||
(list (syntax-e #'n.expanded) (syntax-e #'v.length))
|
||||
(list 0 (- (syntax-e #'v.length) (syntax-e #'n.expanded)))))
|
||||
#:with n+ (gensym 'n)
|
||||
#:with v+ (gensym 'v)
|
||||
(unless (<= (syntax-e #'n.expanded) (syntax-e #'v.length))
|
||||
(vector-bounds-error 'op-name #'v
|
||||
(if 'take? (if 'left? (syntax-e #'hi) (syntax-e #'lo))
|
||||
(if 'left? (syntax-e #'lo) (syntax-e #'hi)))))
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(let ([v+ v.expanded]
|
||||
[n+ (-: 'hi 'lo)])
|
||||
(build-vector n+ (lambda ([i : Integer]) (unsafe-vector-ref v+ (+: i 'lo))))))
|
||||
vector-length-key
|
||||
(syntax-e #'v.length))]
|
||||
[(_ v n:int/expand)
|
||||
(vector-bounds-error 'op-name #'v (syntax-e #'n.expanded))]
|
||||
[_:id
|
||||
(syntax/loc stx op-name)]
|
||||
[(_ e* (... ...))
|
||||
(syntax/loc stx (op-name e* (... ...)))]))))
|
||||
|
||||
(define-syntax vector-take: (make-slice-op vector-take #t #t))
|
||||
(define-syntax vector-take-right: (make-slice-op vector-take-right #f #t))
|
||||
(define-syntax vector-drop-right: (make-slice-op vector-drop-right #f #f))
|
||||
(define-syntax vector-drop: (make-slice-op vector-drop #t #f))
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define-for-syntax (small-vector-size? n)
|
||||
(< n 20))
|
||||
|
||||
;; Assume `stx` is creating a vector; get the length of the vector to-be-made
|
||||
(define-for-syntax (parse-vector-length stx)
|
||||
(cond
|
||||
[(syntax-property stx vector-length-key)
|
||||
=> (lambda (x) x)]
|
||||
[(identifier? stx)
|
||||
(free-id-table-ref id+vector-length stx #f)]
|
||||
[else
|
||||
(syntax-parse stx #:literals (#%plain-app vector make-vector build-vector)
|
||||
[(~or '#(e* ...)
|
||||
#(e* ...)
|
||||
;; TODO #{} #[] #6{} ...
|
||||
(#%plain-app vector e* ...)
|
||||
(vector e* ...))
|
||||
(length (syntax->list #'(e* ...)))]
|
||||
[(~or (make-vector n e* ...)
|
||||
(#%plain-app make-vector n e* ...)
|
||||
(build-vector n e* ...)
|
||||
(#%plain-app build-vector n e* ...))
|
||||
(and (exact-nonnegative-integer? (syntax-e #'n)) (syntax-e #'n))]
|
||||
[_
|
||||
#f])]))
|
||||
|
||||
|
|
|
|||
19
vector/no-colon.rkt
Normal file
19
vector/no-colon.rkt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang typed/racket/base
|
||||
(provide (rename-out
|
||||
(define-vector: define-vector)
|
||||
(let-vector: let-vector)
|
||||
(vector-length: vector-length)
|
||||
(vector-ref: vector-ref)
|
||||
(vector-set!: vector-set!)
|
||||
(vector-map: vector-map)
|
||||
(vector-map!: vector-map!)
|
||||
(vector-append: vector-append)
|
||||
(vector->list: vector->list)
|
||||
(vector->immutable-vector: vector->immutable-vector)
|
||||
(vector-fill!: vector-fill!)
|
||||
(vector-take: vector-take)
|
||||
(vector-take-right: vector-take-right)
|
||||
(vector-drop: vector-drop)
|
||||
(vector-drop-right: vector-drop-right)
|
||||
))
|
||||
(require trivial/vector)
|
||||
Loading…
Reference in New Issue
Block a user