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

Add in-* annotations to for loops

This commit is contained in:
Tony Garnock-Jones 2018-04-30 09:14:00 +01:00
parent a6811f2ba5
commit eb3a93e32b
1 changed files with 9 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
syndicate/skeleton.rkt
View File

@ -117,7 +117,7 @@
(define (skcont-add! c i) (define (skcont-add! c i)
(match-define (skeleton-interest _desc cs cv vs h _cleanup) i) (match-define (skeleton-interest _desc cs cv vs h _cleanup) i)
(define (make-matched-constant) (define (make-matched-constant)
(skeleton-matched-constant (for/mutable-set [(a (skeleton-continuation-cache c)) (skeleton-matched-constant (for/mutable-set [(a (in-set (skeleton-continuation-cache c)))
#:when (equal? (apply-projection a cs) cv)] #:when (equal? (apply-projection a cs) cv)]
a) a)
(make-hash))) (make-hash)))
@ -125,7 +125,7 @@
(define sc (hash-ref! cvt cv make-matched-constant)) (define sc (hash-ref! cvt cv make-matched-constant))
(define (make-accumulator) (define (make-accumulator)
(define cache (make-bag)) (define cache (make-bag))
(for [(a (skeleton-matched-constant-cache sc))] (for [(a (in-set (skeleton-matched-constant-cache sc)))]
(define vars (apply-projection a vs)) (define vars (apply-projection a vs))
(bag-change! cache vars 1)) (bag-change! cache vars 1))
(skeleton-accumulator cache (mutable-seteq))) (skeleton-accumulator cache (mutable-seteq)))
@ -181,7 +181,7 @@
(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)))
(make-empty-skeleton/cache (make-empty-skeleton/cache
(for/mutable-set [(a unfiltered) #:when (subterm-matches-class? a path class)] a))) (for/mutable-set [(a (in-set unfiltered)) #:when (subterm-matches-class? a path class)] a)))
(define next (hash-ref! table class make-skeleton-node-with-cache)) (define next (hash-ref! table class make-skeleton-node-with-cache))
(walk-edge! (update-path path pop-count 0) next 0 0 pieces)] (walk-edge! (update-path path pop-count 0) next 0 0 pieces)]
[_ [_
@ -218,7 +218,7 @@
(define variables (apply-projection term0 variable-proj)) (define variables (apply-projection term0 variable-proj))
(modify-skacc! acc variables term0)))) (modify-skacc! acc variables term0))))
(for [(edge edges)] (for [(edge (in-list edges))]
(match-define (cons (skeleton-selector pop-count index) table) edge) (match-define (cons (skeleton-selector pop-count index) table) edge)
(define popped-stack (drop term-stack pop-count)) (define popped-stack (drop term-stack pop-count))
(define pieces (car popped-stack)) (define pieces (car popped-stack))
@ -243,7 +243,7 @@
(define (add-term-to-skacc! skacc vars _term) (define (add-term-to-skacc! skacc vars _term)
(match (bag-change! (skeleton-accumulator-cache skacc) vars 1) (match (bag-change! (skeleton-accumulator-cache skacc) vars 1)
['absent->present ['absent->present
(for [(handler (skeleton-accumulator-handlers skacc))] (for [(handler (in-set (skeleton-accumulator-handlers skacc)))]
(apply handler '+ vars))] (apply handler '+ vars))]
;; 'present->absent and 'absent->absent absurd ;; 'present->absent and 'absent->absent absurd
['present->present ['present->present
@ -265,7 +265,7 @@
(if (bag-member? cache vars) (if (bag-member? cache vars)
(match (bag-change! cache vars -1) (match (bag-change! cache vars -1)
['present->absent ['present->absent
(for [(handler (skeleton-accumulator-handlers skacc))] (for [(handler (in-set (skeleton-accumulator-handlers skacc)))]
(apply handler '- vars))] (apply handler '- vars))]
;; 'absent->absent and 'absent->present absurd ;; 'absent->absent and 'absent->present absurd
['present->present ['present->present
@ -285,16 +285,16 @@
void void
void void
(lambda (skacc vars _term) (lambda (skacc vars _term)
(for [(handler (skeleton-accumulator-handlers skacc))] (for [(handler (in-set (skeleton-accumulator-handlers skacc)))]
(apply handler '! vars))))) (apply handler '! vars)))))
;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj` ;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj`
(define (apply-projection term proj) (define (apply-projection term proj)
(for/list [(path proj)] (for/list [(path (in-list proj))]
(apply-projection-path term path))) (apply-projection-path term path)))
(define (apply-projection-path term path) (define (apply-projection-path term path)
(for/fold [(term (list term))] [(index path)] (for/fold [(term (list term))] [(index (in-list path))]
(cond [(list? term) (list-ref term index)] (cond [(list? term) (list-ref term index)]
[(non-object-struct? term) (vector-ref (struct->vector term) (+ index 1))] [(non-object-struct? term) (vector-ref (struct->vector term) (+ index 1))]
[else (error 'apply-projection "Term representation not supported: ~v" term)]))) [else (error 'apply-projection "Term representation not supported: ~v" term)])))