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

Adjust skeleton for extensible dataspace patterns

This commit is contained in:
Tony Garnock-Jones 2024-04-04 15:16:45 +02:00
parent b214835bcc
commit 6d1278fbb0
1 changed files with 24 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
syndicate/skeleton.rkt
View File

@ -154,13 +154,11 @@
(define (term-matches-ctor-spec? term ctor-spec) (define (term-matches-ctor-spec? term ctor-spec)
(match ctor-spec (match ctor-spec
[(? number? arity) [(cons 'rec label)
(and (list? term) (= (length term) arity))]
[(cons label (? number? arity))
(and (non-object-struct? term) (and (non-object-struct? term)
(let ((t (struct->struct-type term))) (equal? (struct-type-name (struct->struct-type term)) label))]
(and (equal? (struct-type-name t) label) ['arr
(= (struct-type-constructor-arity t) arity))))] (list? term)]
['dict ['dict
(hash? term)])) (hash? term)]))
@ -180,8 +178,8 @@
[(cons _selector table) table])) [(cons _selector table) table]))
(define ctor-spec (define ctor-spec
(match compound-pat (match compound-pat
[(DCompound-rec label field-pats) (cons label (length field-pats))] [(DCompound-rec label field-pats) (cons 'rec label)]
[(DCompound-arr item-pats) (length item-pats)] [(DCompound-arr item-pats) 'arr]
[(DCompound-dict _entries) 'dict])) [(DCompound-dict _entries) 'dict]))
(define (make-skeleton-node-with-cache) (define (make-skeleton-node-with-cache)
(define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk))) (define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk)))
@ -250,16 +248,14 @@
(define popped-stack (drop term-stack pop-count)) (define popped-stack (drop term-stack pop-count))
(define old-top (car popped-stack)) (define old-top (car popped-stack))
(define new-top (step-term old-top key)) (define new-top (step-term old-top key))
(define entry (hash-ref table (define entry
(cond [(non-object-struct? new-top) (hash-ref table
(define t (struct->struct-type new-top)) (cond [(non-object-struct? new-top) (cons 'rec (struct-type-name
(cons (struct-type-name t) (struct-type-constructor-arity t))] (struct->struct-type new-top)))]
[(list? new-top) [(list? new-top) 'arr]
(length new-top)] [(hash? new-top) 'dict]
[(hash? new-top) [else #f])
'dict] #f))
[else #f])
#f))
(when entry (walk-node! entry (cons new-top popped-stack)))))) (when entry (walk-node! entry (cons new-top popped-stack))))))
(define (add-term-to-skcont! skcont term) (define (add-term-to-skcont! skcont term)
@ -344,7 +340,13 @@
(step-term term key))) (step-term term key)))
(define (step-term term key) (define (step-term term key)
(cond [(non-object-struct? term) (vector-ref (struct->vector term) (+ key 1))] (cond [(non-object-struct? term)
[(list? term) (list-ref term key)] (define v (struct->vector term))
[(hash? term) (hash-ref term key (void))] (define k (+ key 1)) ;; skip the label
[else (error 'apply-projection "Term representation not supported: ~v" term)])) (if (>= k (vector-length v)) (void) (vector-ref v k))]
[(list? term)
(if (>= key (length term)) (void) (list-ref term key))]
[(hash? term)
(hash-ref term key (void))]
[else
(error 'apply-projection "Term representation not supported: ~v" term)]))