[untyped] copy of typed library
This commit is contained in:
Ben Greenman
parent
fa88868254
commit
c7b99a2396
81
trivial/untyped.rkt
Normal file
81
trivial/untyped.rkt
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
#lang racket/base
|
||||
|
||||
;; TODO can't retrive values from define:number
|
||||
|
||||
(provide
|
||||
(for-syntax set-trivial-print)
|
||||
(rename-out
|
||||
[define: define]
|
||||
[let: let]
|
||||
;;
|
||||
[format: format]
|
||||
[printf: printf]
|
||||
[+: +]
|
||||
[-: -]
|
||||
[*: *]
|
||||
[/: /]
|
||||
[quotient: quotient]
|
||||
[expt: expt]
|
||||
;;
|
||||
[pair?: pair?]
|
||||
[null?: null?]
|
||||
[cons: cons]
|
||||
[car: car]
|
||||
[cdr: cdr]
|
||||
[list?: list?]
|
||||
[length: length]
|
||||
[list-ref: list-ref]
|
||||
[list-tail: list-tail]
|
||||
[append: append]
|
||||
[reverse: reverse]
|
||||
;;
|
||||
[regexp-match: regexp-match]
|
||||
[regexp: regexp]
|
||||
[pregexp: pregexp]
|
||||
[byte-regexp: byte-regexp]
|
||||
[byte-pregexp: byte-pregexp]
|
||||
;;
|
||||
[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
|
||||
(for-syntax
|
||||
trivial/private/common
|
||||
racket/base
|
||||
(only-in trivial/private/parameters set-trivial-print))
|
||||
trivial/untyped/format
|
||||
trivial/untyped/list
|
||||
trivial/untyped/math
|
||||
trivial/untyped/regexp
|
||||
trivial/untyped/vector
|
||||
)
|
||||
|
||||
(define-syntax define: (make-keyword-alias 'define
|
||||
(lambda (stx)
|
||||
(or (format-define stx)
|
||||
(num-define stx)
|
||||
(lst-define stx)
|
||||
(rx-define stx)
|
||||
;(fun-define stx)
|
||||
(vec-define stx)))))
|
||||
|
||||
(define-syntax let: (make-keyword-alias 'let
|
||||
(lambda (stx)
|
||||
(or (format-let stx)
|
||||
;(fun-let stx)
|
||||
(num-let stx)
|
||||
(lst-let stx)
|
||||
(rx-let stx)
|
||||
(vec-let stx)))))
|
||||
9
trivial/untyped/README.md
Normal file
9
trivial/untyped/README.md
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
private
|
||||
===
|
||||
|
||||
Files that no law-abiding library user should `require`.
|
||||
|
||||
- `common.rkt` Helper functions common to a few macros.
|
||||
- `set-bang.rkt` Restrict `set!` to respect our syntax property metadata.
|
||||
- `test-common.rkt` Helpers for unit testing
|
||||
- `db/` Support for the `db.rkt` implementation
|
||||
93
trivial/untyped/format.rkt
Normal file
93
trivial/untyped/format.rkt
Normal file
|
|
@ -0,0 +1,93 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Statically-checked format strings
|
||||
|
||||
(provide
|
||||
format:
|
||||
printf:
|
||||
|
||||
(for-syntax
|
||||
format-define
|
||||
format-let)
|
||||
)
|
||||
|
||||
(require
|
||||
(for-syntax
|
||||
trivial/private/common
|
||||
typed/racket/base
|
||||
syntax/parse))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(begin-for-syntax
|
||||
;; Count the number of format escapes in a string.
|
||||
;; Returns a list of optional types (to be spliced into the source code).
|
||||
;; Example: If result is '(#f Integer), then
|
||||
;; - The format string expects 2 arguments
|
||||
;; - First argument has no type constraints, second must be an Integer
|
||||
(define (format-parser stx)
|
||||
(define str (if (string? (syntax-e stx)) (syntax-e stx) (quoted-stx-value? stx)))
|
||||
(cond
|
||||
[(string? str)
|
||||
(define last-index (- (string-length str) 1))
|
||||
(let loop ([i 0] [acc '()])
|
||||
(cond
|
||||
[(>= i last-index)
|
||||
(reverse acc)]
|
||||
[(eq? #\~ (string-ref str i))
|
||||
;; From fprintf docs @ http://docs.racket-lang.org/reference/Writing.html
|
||||
(case (string-ref str (+ i 1))
|
||||
[(#\% #\n #\~ #\space #\tab #\newline)
|
||||
;; Need 0 arguments
|
||||
(loop (+ i 2) acc)]
|
||||
[(#\a #\A #\s #\S #\v #\V #\e #\E)
|
||||
;; Need 1 argument, can be anything
|
||||
(loop (+ i 2) (cons #f acc))]
|
||||
[(#\.)
|
||||
;; Need at most 1, can be anything
|
||||
(if (and (< (+ 1 i) last-index)
|
||||
(memq (string-ref str (+ i 2)) '(#\a #\A #\s #\S #\v #\V)))
|
||||
(loop (+ i 3) (cons #f acc))
|
||||
(loop (+ i 3) acc))]
|
||||
[(#\c #\C)
|
||||
;; Need 1 `char?`
|
||||
(loop (+ i 2) (cons #f acc))]
|
||||
[(#\b #\B #\o #\O #\x #\X)
|
||||
;; Need 1 `exact?`
|
||||
(loop (+ i 2) (cons #f acc))]
|
||||
[else
|
||||
;; Invalid format sequence
|
||||
(raise-user-error "format: unrecognized pattern string '~~~c'"
|
||||
(string-ref str (+ i 1)))])]
|
||||
[else
|
||||
(loop (+ i 1) acc)]))]
|
||||
[else #f]))
|
||||
|
||||
(define-values (_key fmt? format-define format-let)
|
||||
(make-value-property 'string:format format-parser))
|
||||
|
||||
(define-syntax-class/predicate string/format fmt?)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define-syntax format: (make-alias #'format
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ fmt:string/format arg* ...)
|
||||
;; -- 1. Parse expected types from the template
|
||||
#:when (let ([num-expected (length (syntax-e #'fmt.evidence))]
|
||||
[num-given (length (syntax-e #'(arg* ...)))])
|
||||
(unless (= num-expected num-given)
|
||||
(apply raise-arity-error
|
||||
'format:
|
||||
num-expected
|
||||
(map syntax->datum (syntax-e #'(arg* ...))))))
|
||||
(syntax/loc stx (format fmt.expanded arg* ...))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax printf: (make-alias #'printf
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ arg* ...)
|
||||
(syntax/loc stx (display (format: arg* ...)))]
|
||||
[_ #f]))))
|
||||
|
||||
89
trivial/untyped/function.rkt
Normal file
89
trivial/untyped/function.rkt
Normal file
|
|
@ -0,0 +1,89 @@
|
|||
#lang racket/base
|
||||
|
||||
;; TODO
|
||||
;; map passing, but cury failig; can't make a lambda like I'd like to
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
;; Track procedure arity
|
||||
;; Applications:
|
||||
;; - vectorized ops
|
||||
;; - (TODO) improve apply/map? ask Leif
|
||||
;; - TODO get types, not arity
|
||||
|
||||
(provide
|
||||
curry:
|
||||
map:
|
||||
|
||||
;; --
|
||||
(for-syntax
|
||||
fun-define
|
||||
fun-let)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(require
|
||||
(for-syntax
|
||||
typed/racket/base
|
||||
syntax/parse
|
||||
racket/syntax
|
||||
trivial/private/common
|
||||
))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(begin-for-syntax
|
||||
(define TYPE-KEY 'type-label)
|
||||
|
||||
(define (formal->type x)
|
||||
#f)
|
||||
|
||||
(define (parse-procedure-arity stx)
|
||||
(syntax-parse stx #:literals (: #%plain-lambda lambda)
|
||||
[(#%plain-lambda (x*:id ...) e* ...)
|
||||
(map formal->type (syntax-e #'(x* ...)))]
|
||||
;; TODO polydots, keywords, optional args
|
||||
;; TODO standard library functions
|
||||
[_ #f]))
|
||||
|
||||
(define-values (arity-key fun? fun-define fun-let)
|
||||
(make-value-property 'procedure:arity parse-procedure-arity))
|
||||
|
||||
(define-syntax-class/predicate procedure/arity fun?)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define-syntax (curry: stx)
|
||||
(syntax-parse stx
|
||||
[(_ p:procedure/arity)
|
||||
#:with x* (for/list ([_t (in-list (syntax-e #'p.evidence))]) (gensym))
|
||||
#:with p+ (for/fold ([e (quasisyntax/loc stx (p.expanded #,@#'x*))])
|
||||
([x (in-list (reverse (syntax-e #'x*)))])
|
||||
(quasisyntax/loc stx
|
||||
(lambda (#,x) #,e)))
|
||||
(syntax/loc stx p+)]
|
||||
[_
|
||||
(raise-user-error 'curry "Fail at: ~a" (syntax->datum stx))]))
|
||||
|
||||
;; TODO try the other direction, inferring type from arguments.
|
||||
;; (may not be practical here, may need to be inside TR)
|
||||
(define-syntax map: (make-alias #'map
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ p:procedure/arity e* ...)
|
||||
;; --
|
||||
#:when
|
||||
(let ([num-expected (length (syntax-e #'p.evidence))]
|
||||
[num-actual (length (syntax-e #'(e* ...)))])
|
||||
(unless (= num-expected num-actual)
|
||||
(apply raise-arity-error
|
||||
'map:
|
||||
num-expected
|
||||
(map syntax->datum (syntax-e #'(e* ...))))))
|
||||
;; --
|
||||
#:with (e+* ...)
|
||||
(for/list ([e (in-list (syntax-e #'(e* ...)))])
|
||||
(quasisyntax/loc stx #,e))
|
||||
(syntax/loc stx (map p.expanded e+* ...))]))))
|
||||
|
||||
200
trivial/untyped/list.rkt
Normal file
200
trivial/untyped/list.rkt
Normal file
|
|
@ -0,0 +1,200 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide
|
||||
define-list:
|
||||
let-list:
|
||||
pair?:
|
||||
null?:
|
||||
cons:
|
||||
car:
|
||||
cdr:
|
||||
list?:
|
||||
length:
|
||||
list-ref:
|
||||
list-tail:
|
||||
append:
|
||||
reverse:
|
||||
;map:
|
||||
;andmap:
|
||||
;ormap:
|
||||
;for-each:
|
||||
;foldl:
|
||||
;foldr:
|
||||
;filter:
|
||||
;remove:
|
||||
;remq:
|
||||
;remv:
|
||||
;remove*:
|
||||
;remq*:
|
||||
;remv*:
|
||||
;sort:
|
||||
;member:
|
||||
|
||||
;; --- private
|
||||
(for-syntax
|
||||
lst-define
|
||||
lst-let
|
||||
parse-list-length
|
||||
lst-length-key ;; TODO generic "data structure length" key?
|
||||
)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(require
|
||||
trivial/private/math
|
||||
typed/racket/unsafe
|
||||
racket/list
|
||||
(for-syntax
|
||||
trivial/private/common
|
||||
trivial/private/sequence
|
||||
typed/racket/base
|
||||
syntax/parse))
|
||||
|
||||
;; Thank you based Asumu
|
||||
(require (only-in racket/unsafe/ops
|
||||
unsafe-car
|
||||
unsafe-cdr
|
||||
unsafe-cons-list
|
||||
unsafe-list-ref
|
||||
unsafe-list-tail
|
||||
))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(begin-for-syntax
|
||||
(define (parse-list-length stx)
|
||||
(syntax-parse stx #:literals (#%plain-app cons list list* make-list build-list null)
|
||||
[(~or '(e* ...)
|
||||
(list e* ...)
|
||||
(#%plain-app list e* ...))
|
||||
(length (syntax-e #'(e* ...)))]
|
||||
[(~or (make-list n e* ...)
|
||||
(#%plain-app make-list n e* ...)
|
||||
(build-list n e* ...)
|
||||
(#%plain-app build-list n e* ...))
|
||||
#:with n-stx (stx->num #'n)
|
||||
#:when (syntax-e #'n-stx)
|
||||
(syntax-e #'n-stx)]
|
||||
[(~or (cons e es)
|
||||
(#%plain-app cons e es))
|
||||
#:with n+ (parse-list-length #'es)
|
||||
#:when (syntax-e #'n+)
|
||||
(+ 1 (syntax-e #'n+))]
|
||||
[(~or (list* e* ... es)
|
||||
(#%plain-app list* e* ... es))
|
||||
#:with n+ (parse-list-length #'es)
|
||||
#:when (syntax-e #'n+)
|
||||
(+ (length (syntax-e #'(e* ...))) (syntax-e #'n+))]
|
||||
[(~or (null)
|
||||
(#%plain-app null))
|
||||
0]
|
||||
[+ #f]))
|
||||
|
||||
(define-values (lst-length-key lst? lst-define lst-let)
|
||||
(make-value-property 'list:length parse-list-length))
|
||||
(define-syntax-class/predicate list/length lst?)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define-syntax define-list: (make-keyword-alias 'define lst-define))
|
||||
(define-syntax let-list: (make-keyword-alias 'let lst-let))
|
||||
|
||||
(define-syntax pair?: (make-alias #'pair?
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length)
|
||||
(quasisyntax/loc stx '#,(not (zero? (syntax-e #'l.evidence))))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax null?: (make-alias #'null?
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length)
|
||||
(quasisyntax/loc stx '#,(zero? (syntax-e #'l.evidence)))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax cons: (make-alias #'cons
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ x l:list/length)
|
||||
#:with l+ (syntax-property
|
||||
(syntax/loc stx (unsafe-cons-list x l.expanded))
|
||||
lst-length-key (+ 1 (syntax-e #'l.evidence)))
|
||||
(syntax/loc stx l+)]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax car: (make-alias #'car
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length)
|
||||
(when (zero? (syntax-e #'l.evidence))
|
||||
(bounds-error 'car: #'l 0))
|
||||
(syntax/loc stx (unsafe-car l.expanded))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax cdr: (make-alias #'cdr
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length)
|
||||
(when (zero? (syntax-e #'l.evidence))
|
||||
(bounds-error 'cdr: #'l 0))
|
||||
(syntax/loc stx (unsafe-cdr l.expanded))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax list?: (make-alias #'list?
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length)
|
||||
(syntax/loc stx '#t)]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax length: (make-alias #'length
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length)
|
||||
(syntax/loc stx 'l.evidence)]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax list-ref: (make-alias #'list-ref
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length e)
|
||||
#:with i-stx (stx->num #'e)
|
||||
#:when (syntax-e #'i-stx)
|
||||
(let ([i (syntax-e #'i-stx)])
|
||||
(unless (< -1 i (syntax-e #'l.evidence))
|
||||
(bounds-error 'list-ref: #'l i))
|
||||
(syntax/loc stx (unsafe-list-ref l.expanded 'i-stx)))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax list-tail: (make-alias #'list-tail
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length e)
|
||||
#:with i-stx (stx->num #'e)
|
||||
#:when (syntax-e #'i-stx)
|
||||
(let ([i (syntax-e #'i-stx)])
|
||||
(unless (< i (syntax-e #'l.evidence))
|
||||
(bounds-error 'list-tail: #'l i))
|
||||
(syntax/loc stx (unsafe-list-tail l.expanded 'i-stx)))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax append: (make-alias #'append
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l1:list/length l2:list/length)
|
||||
#:with l+ (syntax-property (syntax/loc stx (append l1.expanded l2.expanded))
|
||||
lst-length-key (+ (syntax-e #'l1.evidence) (syntax-e #'l2.evidence)))
|
||||
(quasisyntax/loc stx l+)]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax reverse: (make-alias #'reverse
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ l:list/length)
|
||||
#:with l+ (syntax-property (syntax/loc stx (reverse l.expanded))
|
||||
lst-length-key (syntax-e #'l.evidence))
|
||||
(quasisyntax/loc stx l+)]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax map: (make-alias #'map
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ f l:list/length l*:list/length ...)
|
||||
#:with l+ (syntax-property
|
||||
(syntax/loc stx (map f l.expanded l*.expanded ...))
|
||||
lst-length-key
|
||||
(syntax-e #'l.evidence))
|
||||
(syntax/loc stx l+)]
|
||||
[_ #f]))))
|
||||
|
||||
57
trivial/untyped/main.rkt
Normal file
57
trivial/untyped/main.rkt
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
#lang racket/base
|
||||
|
||||
;; TODO define/let
|
||||
|
||||
(provide
|
||||
(for-syntax set-trivial-print)
|
||||
(rename-out
|
||||
[format: format]
|
||||
[printf: printf]
|
||||
[+: +]
|
||||
[-: -]
|
||||
[*: *]
|
||||
[/: /]
|
||||
[quotient: quotient]
|
||||
[expt: expt]
|
||||
;;
|
||||
[pair?: pair?]
|
||||
[null?: null?]
|
||||
[cons: cons]
|
||||
[car: car]
|
||||
[cdr: cdr]
|
||||
[list?: list?]
|
||||
[length: length]
|
||||
[list-ref: list-ref]
|
||||
[list-tail: list-tail]
|
||||
[append: append]
|
||||
[reverse: reverse]
|
||||
;;
|
||||
[regexp-match: regexp-match]
|
||||
[regexp: regexp]
|
||||
[pregexp: pregexp]
|
||||
[byte-regexp: byte-regexp]
|
||||
[byte-pregexp: byte-pregexp]
|
||||
;;
|
||||
[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
|
||||
(for-syntax (only-in trivial/private/parameters set-trivial-print))
|
||||
trivial/untyped/format
|
||||
trivial/untyped/list
|
||||
trivial/untyped/math
|
||||
trivial/untyped/regexp
|
||||
trivial/untyped/vector
|
||||
)
|
||||
139
trivial/untyped/math.rkt
Normal file
139
trivial/untyped/math.rkt
Normal file
|
|
@ -0,0 +1,139 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Constant-folding math operators.
|
||||
;; Where possible, they simplify their arguments.
|
||||
|
||||
(provide
|
||||
+: -: *: /:
|
||||
;; Same signature as the racket/base operators,
|
||||
;; but try to simplify arguments during expansion.
|
||||
|
||||
expt:
|
||||
quotient:
|
||||
|
||||
define-num: let-num:
|
||||
|
||||
;; --
|
||||
(for-syntax
|
||||
stx->num
|
||||
nat/expand
|
||||
int/expand
|
||||
num/expand
|
||||
num-key
|
||||
num-define
|
||||
num-let)
|
||||
)
|
||||
|
||||
(require (for-syntax
|
||||
racket/base
|
||||
(only-in racket/format ~a)
|
||||
(only-in racket/syntax format-id)
|
||||
syntax/id-table
|
||||
syntax/parse
|
||||
trivial/private/common
|
||||
))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(begin-for-syntax
|
||||
(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
|
||||
;; - A list of syntax objects, to be spliced back in the source code
|
||||
(define (reduce/op op stx)
|
||||
(define expr* (syntax-e stx))
|
||||
(cond
|
||||
[(list? expr*)
|
||||
(let loop ([prev #f] ;; (U #f Number), candidate for reduction
|
||||
[acc '()] ;; (Listof Syntax), irreducible arguments
|
||||
[e* expr*]) ;; (Listof Syntax), arguments to process
|
||||
(if (null? e*)
|
||||
;; then: finished, return a number (prev) or list of expressions (acc)
|
||||
(if (null? acc)
|
||||
prev
|
||||
(reverse (if prev (cons prev acc) acc)))
|
||||
;; else: pop the next argument from e*, fold if it's a constant
|
||||
(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)
|
||||
(make-value-property 'number:natural (lift-predicate exact-nonnegative-integer?)))
|
||||
(define-syntax-class/predicate nat/expand nat?)
|
||||
|
||||
(define-values (int-key int? int-define int-let)
|
||||
(make-value-property 'number:integer (lift-predicate integer?)))
|
||||
(define-syntax-class/predicate int/expand int?)
|
||||
|
||||
(define-values (num-key num? num-define num-let)
|
||||
(make-value-property 'number:number (lift-predicate number?)))
|
||||
(define-syntax-class/predicate num/expand num?)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(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
|
||||
[(_ f:id)
|
||||
#:with f: (format-id #'f "~a:" (syntax-e #'f))
|
||||
#'(define-syntax f: (make-alias #'f
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ e* (... ...))
|
||||
#:with f-id (format-id stx "~a" 'f)
|
||||
(let ([e+ (reduce/op f #'(e* (... ...)))])
|
||||
(if (list? e+)
|
||||
(quasisyntax/loc stx (#%app f-id #,@e+))
|
||||
(quasisyntax/loc stx #,e+)))]
|
||||
[_ #f]))))]))
|
||||
|
||||
(make-numeric-operator +)
|
||||
(make-numeric-operator -)
|
||||
(make-numeric-operator *)
|
||||
(make-numeric-operator /)
|
||||
|
||||
(define-syntax expt: (make-alias #'expt
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ n1 n2)
|
||||
(let ([v1 (stx->num #'n1)]
|
||||
[v2 (stx->num #'n2)])
|
||||
(cond
|
||||
[(and v1 v2)
|
||||
(quasisyntax/loc stx #,(expt v1 v2))]
|
||||
[(and v2 (<= 0 v2 10))
|
||||
(quasisyntax/loc stx (* #,@(for/list ([_i (in-range v2)]) (quasisyntax/loc stx n1))))]
|
||||
[else
|
||||
#f]))]
|
||||
[_ #f]))))
|
||||
|
||||
(define-syntax quotient: (make-alias #'quotient
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ n1 n2)
|
||||
(let ([v1 (stx->num #'n1)]
|
||||
[v2 (stx->num #'n2)])
|
||||
(and v1 v2
|
||||
(quasisyntax/loc stx #,(quotient v1 v2))))]
|
||||
[_ #f]))))
|
||||
244
trivial/untyped/regexp.rkt
Normal file
244
trivial/untyped/regexp.rkt
Normal file
|
|
@ -0,0 +1,244 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Stronger types for regular expression matching.
|
||||
|
||||
;; Specification:
|
||||
;; - Racket docs:
|
||||
;; http://docs.racket-lang.org/reference/regexp.html
|
||||
;;
|
||||
;; - Pregexp docs:
|
||||
;; http://ds26gte.github.io/pregexp/index.html
|
||||
;;
|
||||
;; - Racket source:
|
||||
;; https://github.com/racket/racket/blob/master/racket/src/racket/src/regexp.c
|
||||
|
||||
(provide
|
||||
regexp:
|
||||
pregexp:
|
||||
byte-regexp:
|
||||
byte-pregexp:
|
||||
define-regexp:
|
||||
let-regexp:
|
||||
|
||||
regexp-match:
|
||||
|
||||
(for-syntax
|
||||
rx-key
|
||||
rx-define
|
||||
rx-let)
|
||||
)
|
||||
|
||||
(require
|
||||
(for-syntax
|
||||
(only-in racket/syntax format-id)
|
||||
typed/racket/base
|
||||
(only-in racket/list range)
|
||||
(only-in racket/format ~a)
|
||||
syntax/parse
|
||||
trivial/private/common))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(begin-for-syntax
|
||||
(define errloc-key 'regexp-match:)
|
||||
|
||||
(define (group-error str reason)
|
||||
(raise-argument-error
|
||||
errloc-key
|
||||
(format "Invalid regexp pattern (unmatched ~a)" reason)
|
||||
str))
|
||||
|
||||
;; Dispatch for counting groups
|
||||
(define (parse-groups v-stx)
|
||||
(define v (quoted-stx-value? v-stx))
|
||||
(cond
|
||||
[(string? v) (parse-groups/string v #:src v-stx)]
|
||||
[(regexp? v) (parse-groups/regexp v #:src v-stx)]
|
||||
[(pregexp? v) (parse-groups/pregexp v #:src v-stx)]
|
||||
[(bytes? v) (parse-groups/bytes v #:src v-stx)]
|
||||
[(byte-regexp? v) (parse-groups/byte-regexp v #:src v-stx)]
|
||||
[(byte-pregexp? v) (parse-groups/byte-pregexp v #:src v-stx)]
|
||||
[else #f]))
|
||||
|
||||
;; Handle pipes
|
||||
;; If there is a pipe, everything is nullable, but we know the number of groups
|
||||
(define (parse-groups/untyped str #:src stx)
|
||||
(define alt* (string->alt* str))
|
||||
(cond
|
||||
[(null? alt*)
|
||||
(list 0 '())]
|
||||
[(null? (cdr alt*))
|
||||
(parse-groups-for-alt (car alt*) #:src stx)]
|
||||
[else
|
||||
(define num-groups
|
||||
(for/fold ([num-groups 0])
|
||||
([alt (in-list alt*)])
|
||||
(define ng+null* (parse-groups-for-alt alt #:src stx))
|
||||
(+ num-groups (car ng+null*))))
|
||||
(list num-groups (range num-groups))]))
|
||||
|
||||
;; Count the number of matched parentheses in a regexp pattern.
|
||||
;; Raise an exception if there are unmatched parens.
|
||||
(define (parse-groups-for-alt str #:src stx)
|
||||
(define last-index (- (string-length str) 1))
|
||||
(define in-square? (box #f))
|
||||
(let loop ([i 0] [in-paren '()] [num-groups 0] [null-idx* '()])
|
||||
(if (> i last-index)
|
||||
(cond
|
||||
[(not (null? in-paren))
|
||||
(group-error str (format "'(' at index ~a" (car in-paren)))]
|
||||
[(unbox in-square?)
|
||||
(group-error str (format "'[' at index ~a" (car in-paren)))]
|
||||
[else
|
||||
(list num-groups null-idx*)])
|
||||
(if (unbox in-square?)
|
||||
(if (eq? #\] (string-ref str i))
|
||||
(begin (set-box! in-square? #f)
|
||||
(loop (+ i 1) (cdr in-paren) num-groups null-idx*))
|
||||
(loop (+ i 1) in-paren num-groups null-idx*))
|
||||
(case (string-ref str i)
|
||||
[(#\[)
|
||||
;; Ignore things between [ ... ]
|
||||
(set-box! in-square? #t)
|
||||
(loop (+ i 1) (cons i in-paren) num-groups null-idx*)]
|
||||
[(#\()
|
||||
;; Watch for (? patterns
|
||||
(if (and (< i last-index)
|
||||
(eq? #\? (string-ref str (+ i 1))))
|
||||
(loop (+ i 2) (cons #f in-paren) num-groups null-idx*)
|
||||
(loop (+ i 1) (cons i in-paren) num-groups null-idx*))]
|
||||
[(#\))
|
||||
(cond
|
||||
[(null? in-paren)
|
||||
(group-error str (format "')' at index ~a" i))]
|
||||
[(eq? #f (car in-paren))
|
||||
;; Matched closing paren, but does not count as a group
|
||||
(loop (+ i 1) (cdr in-paren) num-groups null-idx*)]
|
||||
[(and (< i last-index)
|
||||
(or
|
||||
(eq? #\? (string-ref str (+ i 1)))
|
||||
(eq? #\* (string-ref str (+ i 1)))))
|
||||
;; group = may be #f
|
||||
(loop (+ i 1) (cdr in-paren) (+ 1 num-groups) (cons num-groups null-idx*))]
|
||||
[else
|
||||
(loop (+ i 1) (cdr in-paren) (+ 1 num-groups) null-idx*)])]
|
||||
[(#\\)
|
||||
(if (and (< i last-index)
|
||||
(eq? #\\ (string-ref str (+ i 1))))
|
||||
(loop (+ i 3) in-paren num-groups null-idx*)
|
||||
(loop (+ i 2) in-paren num-groups null-idx*))]
|
||||
[(#\|)
|
||||
;; Nope! Can't handle pipes
|
||||
(error 'internal-error "Found '|' character in regexp string.")]
|
||||
[else
|
||||
(loop (+ i 1) in-paren num-groups null-idx*)])))))
|
||||
|
||||
(define (parse-groups/string str #:src stx)
|
||||
(let ([ng (parse-groups/untyped str #:src stx)])
|
||||
(and ng (cons 'String ng))))
|
||||
|
||||
(define (parse-groups/bytes b #:src stx)
|
||||
(let ([ng (parse-groups/untyped (~a b) #:src stx)])
|
||||
(and ng (cons 'Bytes ng))))
|
||||
|
||||
(define (parse-groups/regexp rx #:src stx)
|
||||
(parse-groups/string (~a rx) #:src stx))
|
||||
|
||||
(define parse-groups/pregexp
|
||||
parse-groups/regexp)
|
||||
|
||||
(define (parse-groups/byte-regexp bx #:src stx)
|
||||
(parse-groups/bytes (~a bx) #:src stx))
|
||||
|
||||
(define parse-groups/byte-pregexp
|
||||
parse-groups/byte-regexp)
|
||||
|
||||
(define-values (rx-key rx? rx-define rx-let)
|
||||
(make-value-property 'rx:groups parse-groups))
|
||||
(define-syntax-class/predicate pattern/groups rx?)
|
||||
|
||||
)
|
||||
;; -----------------------------------------------------------------------------
|
||||
;; --- Other helpers
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
;; Divide string into |-separated substrings (regex alternates)
|
||||
;; Be wary of escaped | characters.
|
||||
(define (string->alt* str)
|
||||
(define L (string-length str))
|
||||
(let loop ([prev-i 0] [i 0])
|
||||
(cond
|
||||
[(= i L)
|
||||
;; End of string, return last alternate
|
||||
(list (substring str prev-i i))]
|
||||
[(and (eq? (string-ref str i) #\|)
|
||||
(< 1 i)
|
||||
(not (and (eq? (string-ref str (- i 1)) #\\)
|
||||
(eq? (string-ref str (- i 2)) #\\))))
|
||||
;; Found a pipe, save current alternate
|
||||
(cons (substring str prev-i i)
|
||||
(loop (+ i 1) (+ i 1)))]
|
||||
[else
|
||||
;; Nothing interesting, continue building alternate
|
||||
(loop prev-i (+ i 1))])))
|
||||
|
||||
(define (intlist-union i* j*)
|
||||
(cond
|
||||
[(null? i*)
|
||||
j*]
|
||||
[(null? j*)
|
||||
i*]
|
||||
[(< (car i*) (car j*))
|
||||
(cons (car i*) (intlist-union (cdr i*) j*))]
|
||||
[(> (car i*) (car j*))
|
||||
(cons (car j*) (intlist-union i* (cdr j*)))]
|
||||
[else
|
||||
(cons (car i*) (intlist-union (cdr i*) (cdr j*)))]))
|
||||
|
||||
(define (infer-return-type pattern-sym arg-stx)
|
||||
(if (and
|
||||
(or (eq? pattern-sym 'String)
|
||||
(eq? pattern-sym 'Regexp))
|
||||
(or (syntax-parse arg-stx
|
||||
((x:str) #t)
|
||||
((x) #:when (bytes? (syntax-e #'x)) #f)
|
||||
(_ #t))))
|
||||
'String
|
||||
'Bytes))
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define-syntax (define-matcher* stx)
|
||||
(syntax-parse stx
|
||||
[(_ f*:id ...)
|
||||
#:with (f+* ...) (for/list ([f (in-list (syntax-e #'(f* ...)))])
|
||||
(format-id stx "~a:" (syntax-e f)))
|
||||
#`(begin
|
||||
(define-syntax f+* (make-alias #'f*
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ pat:pattern/groups)
|
||||
(syntax-property
|
||||
(syntax/loc stx (f* pat.expanded))
|
||||
rx-key
|
||||
#'pat.evidence)]
|
||||
[_ #f])))) ...)]))
|
||||
|
||||
(define-matcher* regexp pregexp byte-regexp byte-pregexp)
|
||||
|
||||
(define-syntax define-regexp: (make-keyword-alias 'define rx-define))
|
||||
(define-syntax let-regexp: (make-keyword-alias 'let rx-let))
|
||||
|
||||
(define-syntax regexp-match: (make-alias #'regexp-match
|
||||
(lambda (stx) (syntax-parse stx
|
||||
[(_ pat:pattern/groups arg* ...)
|
||||
#:with (type-sym num-groups null-idx*) (syntax/loc stx pat.evidence)
|
||||
;; TODO keep source location in type-sym, stop using format-id
|
||||
;; (Is it really that bad?)
|
||||
(syntax/loc stx
|
||||
(let ([maybe-match (regexp-match pat.expanded arg* ...)])
|
||||
(if maybe-match
|
||||
maybe-match
|
||||
#f)))]
|
||||
[_ #f]))))
|
||||
20
trivial/untyped/sequence.rkt
Normal file
20
trivial/untyped/sequence.rkt
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide
|
||||
small-sequence-size?
|
||||
bounds-error
|
||||
)
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(define (small-sequence-size? n)
|
||||
(< n 20))
|
||||
|
||||
(define (bounds-error sym v-stx i)
|
||||
(raise-syntax-error
|
||||
sym
|
||||
"Index out-of-bounds"
|
||||
(syntax->datum v-stx)
|
||||
i
|
||||
(list v-stx)))
|
||||
|
||||
33
trivial/untyped/set-bang.rkt
Normal file
33
trivial/untyped/set-bang.rkt
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
#lang racket/base
|
||||
|
||||
;(provide
|
||||
; (rename-out [set!: set!])
|
||||
;)
|
||||
;
|
||||
;(require
|
||||
; (for-syntax
|
||||
; racket/base
|
||||
; syntax/parse
|
||||
; trivial/private/common)
|
||||
; (only-in trivial/private/db connection-key)
|
||||
; (only-in trivial/private/math num-key)
|
||||
; (only-in trivial/private/regexp rx-key)
|
||||
; (only-in trivial/private/vector vector-length-key)
|
||||
;)
|
||||
;
|
||||
;;; =============================================================================
|
||||
;
|
||||
;(define-for-syntax (has-important-syntax-property? stx)
|
||||
; (or #t)) ;; Safe over-approximation
|
||||
;; (syntax-property stx connection-key)
|
||||
;; (syntax-property stx num-key)
|
||||
;; (syntax-property stx rx-key)
|
||||
;; (syntax-property stx vector-length-key)))
|
||||
;
|
||||
;(define-syntax set!: (make-keyword-alias 'set!
|
||||
; (lambda (stx) (syntax-parse stx
|
||||
; [(_ name val)
|
||||
; #:when (has-important-syntax-property? #'name)
|
||||
; (raise-syntax-error 'trivial "mutation not allowed"); stx); #'name)
|
||||
; #'(void)]
|
||||
; [_ #f]))))
|
||||
255
trivial/untyped/vector.rkt
Normal file
255
trivial/untyped/vector.rkt
Normal file
|
|
@ -0,0 +1,255 @@
|
|||
#lang racket/base
|
||||
|
||||
;; TODO:
|
||||
;; - use unsafe-vector* operations? (will we ever have an impersonator? not yet)
|
||||
|
||||
(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
|
||||
vec-define
|
||||
vec-let
|
||||
parse-vector-length
|
||||
vector-length-key)
|
||||
)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(require
|
||||
(only-in racket/unsafe/ops
|
||||
unsafe-vector-set!
|
||||
unsafe-vector-ref)
|
||||
trivial/private/math
|
||||
racket/vector
|
||||
(for-syntax
|
||||
trivial/private/common
|
||||
trivial/private/sequence
|
||||
racket/base
|
||||
syntax/parse))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(begin-for-syntax
|
||||
(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* ...)
|
||||
(#%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))
|
||||
(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))
|
||||
(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-sequence-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) ;;bg
|
||||
(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-sequence-size? l1)
|
||||
(small-sequence-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-sequence-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))
|
||||
(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)
|
||||
(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)))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user