syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Support vector in patterns, like we already support list

This commit is contained in:
Tony Garnock-Jones 2018-05-01 20:57:22 +01:00
parent 2b2d12075a
commit e4e0b5f9d4
3 changed files with 42 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
syndicate/pattern.rkt
View File

@ -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))]

24
syndicate/skeleton.rkt
View File

@ -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)])))
;;---------------------------------------------------------------------------

8
syndicate/term.rkt
View File

@ -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))