diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index bce921f..b15ba75 100644 --- a/syndicate/pattern.rkt +++ b/syndicate/pattern.rkt @@ -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))] diff --git a/syndicate/skeleton.rkt b/syndicate/skeleton.rkt index 0dc4516..f025204 100644 --- a/syndicate/skeleton.rkt +++ b/syndicate/skeleton.rkt @@ -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)]))) ;;--------------------------------------------------------------------------- diff --git a/syndicate/term.rkt b/syndicate/term.rkt index 3017152..97092e6 100644 --- a/syndicate/term.rkt +++ b/syndicate/term.rkt @@ -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))