Support vector in patterns, like we already support list
This commit is contained in:
parent
2b2d12075a
commit
e4e0b5f9d4
|
@ -56,6 +56,10 @@
|
|||
(and (identifier? stx)
|
||||
(free-identifier=? #'list stx)))
|
||||
|
||||
(define (vector-id? stx)
|
||||
(and (identifier? stx)
|
||||
(free-identifier=? #'vector stx)))
|
||||
|
||||
(define (analyse-pattern stx)
|
||||
(syntax-case stx ($)
|
||||
[(ctor piece ...)
|
||||
|
@ -68,6 +72,11 @@
|
|||
(list* 'compound
|
||||
'list
|
||||
(stx-map analyse-pattern #'(piece ...)))]
|
||||
[(vector piece ...)
|
||||
(vector-id? #'vector)
|
||||
(list* 'compound
|
||||
'vector
|
||||
(stx-map analyse-pattern #'(piece ...)))]
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
(list 'capture (undollar #'id) (list 'discard))]
|
||||
|
@ -87,6 +96,9 @@
|
|||
[(list piece ...)
|
||||
(list-id? #'list)
|
||||
(quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
|
||||
[(vector piece ...)
|
||||
(vector-id? #'vector)
|
||||
(quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
(undollar #'id)]
|
||||
|
@ -106,6 +118,9 @@
|
|||
[(list piece ...)
|
||||
(list-id? #'list)
|
||||
(quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->value #'(piece ...))))]
|
||||
[(vector piece ...)
|
||||
(vector-id? #'vector)
|
||||
(quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->value #'(piece ...))))]
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
(undollar #'id)]
|
||||
|
@ -148,6 +163,8 @@
|
|||
(match desc
|
||||
[`(compound list ,pieces ...)
|
||||
#`(list 'list #,@(map desc->skeleton-stx pieces))]
|
||||
[`(compound vector ,pieces ...)
|
||||
#`(list 'vector #,@(map desc->skeleton-stx pieces))]
|
||||
[`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
|
||||
#`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
|
||||
[`(capture ,_ ,p) (desc->skeleton-stx p)]
|
||||
|
@ -168,6 +185,8 @@
|
|||
(match desc
|
||||
[`(compound list ,pieces ...)
|
||||
#`(list #,@(map desc->assertion-stx pieces))]
|
||||
[`(compound vector ,pieces ...)
|
||||
#`(vector #,@(map desc->assertion-stx pieces))]
|
||||
[`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
|
||||
#`(#,ctor #,@(map desc->assertion-stx pieces))]
|
||||
[`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
|
||||
|
|
|
@ -27,11 +27,12 @@
|
|||
;;
|
||||
;; Skeleton = (skeleton-node SkCont (AListof SkSelector (MutableHash SkClass SkNode)))
|
||||
;; SkSelector = (skeleton-selector Nat Nat)
|
||||
;; SkClass = StructType | (list-type Nat)
|
||||
;; SkClass = StructType | (list-type Nat) | (vector-type Nat)
|
||||
;;
|
||||
(struct skeleton-node (continuation [edges #:mutable]) #:transparent)
|
||||
(struct skeleton-selector (pop-count index) #:transparent)
|
||||
(struct list-type (arity) #:transparent)
|
||||
(struct vector-type (arity) #:transparent)
|
||||
;;
|
||||
;; A `SkDesc` is a single assertion silhouette, usually the
|
||||
;; evaluation-result of `desc->skeleton-stx` from `pattern.rkt`.
|
||||
|
@ -156,6 +157,7 @@
|
|||
(define (term-matches-class? term class)
|
||||
(cond
|
||||
[(list-type? class) (and (list? term) (= (length term) (list-type-arity class)))]
|
||||
[(vector-type? class) (and (vector? term) (= (vector-length term) (vector-type-arity class)))]
|
||||
[(struct-type? class) (and (non-object-struct? term) (eq? (struct->struct-type term) class))]
|
||||
[else (error 'term-matches-class? "Invalid class: ~v" class)]))
|
||||
|
||||
|
@ -170,8 +172,9 @@
|
|||
(match desc
|
||||
[(list class-desc pieces ...)
|
||||
(define class
|
||||
(cond [(eq? class-desc 'list) (list-type (length pieces))]
|
||||
[(struct-type? class-desc) class-desc]
|
||||
(cond [(struct-type? class-desc) class-desc]
|
||||
[(eq? class-desc 'list) (list-type (length pieces))]
|
||||
[(eq? class-desc 'vector) (vector-type (length pieces))]
|
||||
[else (error 'extend-skeleton! "Invalid class-desc: ~v" class-desc)]))
|
||||
(define selector (skeleton-selector pop-count index))
|
||||
(define table
|
||||
|
@ -232,14 +235,16 @@
|
|||
(define pieces (car popped-stack))
|
||||
(define term (vector-ref pieces (+ index 1))) ;; adjust for struct identifier at beginning
|
||||
(define entry (hash-ref table
|
||||
(cond [(list? term) (list-type (length term))]
|
||||
[(non-object-struct? term) (struct->struct-type term)]
|
||||
(cond [(non-object-struct? term) (struct->struct-type term)]
|
||||
[(list? term) (list-type (length term))]
|
||||
[(vector? term) (vector-type (vector-length term))]
|
||||
[else #f])
|
||||
#f))
|
||||
(when entry
|
||||
(define new-pieces
|
||||
(cond [(list? term) (list->vector (cons 'list term))]
|
||||
[(non-object-struct? term) (struct->vector term)]))
|
||||
(cond [(non-object-struct? term) (struct->vector term)]
|
||||
[(list? term) (list->vector (cons 'list term))]
|
||||
[(vector? term) (list->vector (cons 'list (vector->list term)))]))
|
||||
(walk-node! entry (cons new-pieces term-stack)))))
|
||||
|
||||
(walk-node! sk (list (vector 'list term0))))
|
||||
|
@ -303,8 +308,9 @@
|
|||
|
||||
(define (apply-projection-path term path)
|
||||
(for/fold [(term (list term))] [(index (in-list path))]
|
||||
(cond [(list? term) (list-ref term index)]
|
||||
[(non-object-struct? term) (vector-ref (struct->vector term) (+ index 1))]
|
||||
(cond [(non-object-struct? term) (vector-ref (struct->vector term) (+ index 1))]
|
||||
[(list? term) (list-ref term index)]
|
||||
[(vector? term) (vector-ref term index)]
|
||||
[else (error 'apply-projection "Term representation not supported: ~v" term)])))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
|
|
@ -22,6 +22,8 @@
|
|||
(cons (struct->struct-type t) (map walk (cdr (vector->list (struct->vector t)))))]
|
||||
[(? list?)
|
||||
(cons 'list (map walk t))]
|
||||
[(? vector?)
|
||||
(cons 'vector (map walk (vector->list t)))]
|
||||
[atom
|
||||
#f])))
|
||||
|
||||
|
@ -36,6 +38,8 @@
|
|||
(walk-edge 0 key-rev (cdr (vector->list (struct->vector t))))]
|
||||
[(? list?)
|
||||
(walk-edge 0 key-rev t)]
|
||||
[(? vector?)
|
||||
(walk-edge 0 key-rev (vector->list t))]
|
||||
[atom
|
||||
(atom-fn key-rev atom)]))
|
||||
|
||||
|
@ -79,6 +83,8 @@
|
|||
(for-each pop-captures! (cdr (vector->list (struct->vector t))))]
|
||||
[(? list?)
|
||||
(for-each pop-captures! t)]
|
||||
[(? vector?)
|
||||
(for [(tt (in-vector t))] (pop-captures! tt))]
|
||||
[_ (void)]))
|
||||
|
||||
(define (walk t)
|
||||
|
@ -93,6 +99,8 @@
|
|||
(map walk (cdr (vector->list (struct->vector t)))))]
|
||||
[(? list?)
|
||||
(map walk t)]
|
||||
[(? vector?)
|
||||
(for/vector [(tt t)] (walk tt))]
|
||||
[other other]))
|
||||
|
||||
(walk t))
|
||||
|
|
Loading…
Reference in New Issue