lazy stepper working with infinite lists
in stepper/private/marks.rkt
- in mark-binding-value, add exception handler to catch undefined vars, so
display-mark in break works with recursive fns
in /tests/stepper/automatic-tests.rkt
through-tests.rkt
- add inf list example from icfp paper
in stepper/private/model.rkt
- refactor send-step to use cond instead of unless
- in send-step, when highlight-stack = null and last-rhs != null (and lhs !=
last-rhs), send a step with lhs = last-rhs (previously skipped whenever
highlight-stack = null)
- basic filter example wasnt showing result without this
- in icfp inf list example, this shows some intermediate forcing states
- all other existing tests passed
This commit is contained in:
Stephen Chang
parent
2227516673
commit
c0f8f1cdb2
|
|
@ -90,7 +90,8 @@
|
|||
(full-mark-struct-label (mark)))
|
||||
|
||||
(define (mark-binding-value mark-binding)
|
||||
((cadr mark-binding)))
|
||||
(with-handlers ([(λ (e) #t) (λ (e) "--- undefined ---")])
|
||||
((cadr mark-binding))))
|
||||
|
||||
(define (mark-binding-binding mark-binding)
|
||||
(car mark-binding))
|
||||
|
|
|
|||
|
|
@ -279,45 +279,68 @@
|
|||
(define (send-step lhs-exps lhs-finished-exps
|
||||
rhs-exps rhs-finished-exps
|
||||
step-kind lhs-posn-info rhs-posn-info)
|
||||
(when DEBUG
|
||||
(printf "maybe sending step ... \n")
|
||||
(printf "LHS = ~a\n" (map syntax->hilite-datum lhs-exps))
|
||||
(printf "RHS = ~a\n" (map syntax->hilite-datum rhs-exps)))
|
||||
(unless
|
||||
(or (with-DEBUG
|
||||
(and (step=? lhs-exps rhs-exps)
|
||||
(when (not (step-and-highlight=? lhs-exps rhs-exps))
|
||||
(when DEBUG
|
||||
(printf "Pushing onto highlight-stack:\n ~a thunk\n"
|
||||
(syntax->hilite-datum (car lhs-exps))))
|
||||
(highlight-stack-push mark-list)))
|
||||
"SKIPPING STEP (LHS = RHS)\n")
|
||||
(and (step=? lhs-exps (list #'(... ...)))
|
||||
(or (with-DEBUG
|
||||
(step=? rhs-exps last-rhs-exps)
|
||||
"SKIPPING STEP (LHS = ellipses and RHS = last RHS)\n")
|
||||
(with-DEBUG
|
||||
(null? highlight-stack)
|
||||
"SKIPPING STEP (LHS = ellipses and highlight-stack = null)\n")
|
||||
(let ([skips (cdar highlight-stack)]
|
||||
[lhs-thunk (caar highlight-stack)])
|
||||
(if (or (zero? skips) (not (null? last-rhs-exps)))
|
||||
(begin
|
||||
(set! lhs-exps (lhs-thunk))
|
||||
(set! lhs-finished-exps rhs-finished-exps)
|
||||
(with-DEBUG
|
||||
(highlight-stack-pop)
|
||||
"Popping highlight-stack\n")
|
||||
#f)
|
||||
(highlight-stack-decrement))))))
|
||||
|
||||
(define (send-it)
|
||||
(receive-result
|
||||
(make-before-after-result
|
||||
(append lhs-finished-exps lhs-exps)
|
||||
(append rhs-finished-exps rhs-exps)
|
||||
step-kind
|
||||
lhs-posn-info rhs-posn-info))
|
||||
(when DEBUG (printf "step sent\n"))
|
||||
(set! last-rhs-exps rhs-exps)))
|
||||
(when DEBUG
|
||||
(printf "step sent:\n")
|
||||
(printf "LHS = ~a\n" (map syntax->hilite-datum lhs-exps))
|
||||
(printf "RHS = ~a\n" (map syntax->hilite-datum rhs-exps)))
|
||||
(set! last-rhs-exps rhs-exps))
|
||||
|
||||
(when DEBUG
|
||||
(printf "maybe sending step ... \n")
|
||||
(printf "LHS = ~a\n" (map syntax->hilite-datum lhs-exps))
|
||||
(printf "RHS = ~a\n" (map syntax->hilite-datum rhs-exps)))
|
||||
|
||||
(cond
|
||||
; SKIPPING step, lhs = rhs
|
||||
; if highlights differ, push highlight-stack and set last-rhs-exp
|
||||
[(step=? lhs-exps rhs-exps)
|
||||
(when DEBUG (printf "SKIPPING STEP (LHS = RHS)\n"))
|
||||
(when (not (step-and-highlight=? lhs-exps rhs-exps))
|
||||
(when DEBUG
|
||||
(printf "Pushing onto highlight-stack:\n ~a thunk\n"
|
||||
(syntax->hilite-datum (car lhs-exps))))
|
||||
(highlight-stack-push mark-list)
|
||||
(set! last-rhs-exps rhs-exps))]
|
||||
[(step=? lhs-exps (list #'(... ...)))
|
||||
(cond
|
||||
; SKIPPING step, lhs = ellipses and rhs = last-rhs-exps
|
||||
[(step=? rhs-exps last-rhs-exps)
|
||||
(when DEBUG
|
||||
(printf "SKIPPING STEP (LHS = ellipses and RHS = last RHS)\n"))]
|
||||
; SKIPPING step, lhs = ellipses and highlight-stack = null and last-rhs = null
|
||||
; if last-rhs != null, send step
|
||||
[(null? highlight-stack)
|
||||
(if (not (null? last-rhs-exps))
|
||||
(begin
|
||||
(set! lhs-exps last-rhs-exps)
|
||||
(set! lhs-finished-exps rhs-finished-exps)
|
||||
(send-it))
|
||||
(when DEBUG
|
||||
(printf "SKIPPING STEP (LHS = ellipses and highlight-stack = null)\n")))]
|
||||
; if last-rhs != null, send step
|
||||
; else if skips = 0, send step
|
||||
; else skip
|
||||
[else
|
||||
(let ([skips (cdar highlight-stack)]
|
||||
[lhs-thunk (caar highlight-stack)])
|
||||
(if (or (zero? skips) (not (null? last-rhs-exps)))
|
||||
(begin
|
||||
(set! lhs-exps (lhs-thunk))
|
||||
(set! lhs-finished-exps rhs-finished-exps)
|
||||
(when DEBUG (printf "Popping highlight-stack\n"))
|
||||
(highlight-stack-pop)
|
||||
(send-it))
|
||||
(highlight-stack-decrement)))])]
|
||||
; sending step
|
||||
[else (send-it)]))
|
||||
|
||||
; compares the lhs and rhs of a step (lists of syntaxes)
|
||||
; and returns true if the underlying datums are equal
|
||||
|
|
@ -369,6 +392,10 @@
|
|||
(set! held-exp-list (create-held lhs-unwound))
|
||||
(set! lhs-recon-thunk
|
||||
(λ ()
|
||||
(when DEBUG
|
||||
(printf "\nforcing saved MARKLIST\n")
|
||||
(for-each (λ (x) (printf "~a\n" (display-mark x))) mark-list)
|
||||
(printf "saved RETURNED VALUE LIST: ~a\n" returned-value-list))
|
||||
(map (λ (exp) (unwind exp render-settings))
|
||||
(maybe-lift
|
||||
(r:reconstruct-left-side
|
||||
|
|
|
|||
|
|
@ -149,7 +149,8 @@
|
|||
val current-so-far)
|
||||
current-so-far]
|
||||
; promise is not running if we get here
|
||||
[(promise-forced? val)
|
||||
[(and (promise-forced? val)
|
||||
(not (nested-promise-running? val)))
|
||||
(recon-value (force val) render-settings assigned-name current-so-far)]
|
||||
; unknown promise: promise not in src code, created in library fn
|
||||
[else
|
||||
|
|
@ -1105,10 +1106,10 @@
|
|||
mark-list null newly-lifted-bindings render-settings))])
|
||||
(list (recon innermost-before (cdr mark-list) #f)
|
||||
(recon innermost-after (cdr mark-list) #f)))))))
|
||||
|
||||
)
|
||||
|
||||
answer))
|
||||
answer
|
||||
))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
lazy-cddadr lazy-cdddar lazy-cddddr lazy-second lazy-third lazy-fourth
|
||||
lazy-fifth lazy-sixth lazy-seventh lazy-eighth
|
||||
lazy-if1 lazy-if2 lazy-take-0 lazy-take lazy-take-impl
|
||||
lazy-unknown1 lazy-unknown2))
|
||||
lazy-unknown1 lazy-unknown2 lazy-inf-list1))
|
||||
|
||||
(let ((outer-namespace (current-namespace)))
|
||||
(parameterize ([display-only-errors #t]
|
||||
|
|
|
|||
|
|
@ -1746,13 +1746,17 @@
|
|||
(t 'lazy-take-0 m:lazy
|
||||
,e :: {,e} -> {empty}))
|
||||
|
||||
(define (<delay#> n)
|
||||
(string->symbol
|
||||
(string-append "<DelayedEvaluation#" (number->string n) ">")))
|
||||
|
||||
; lazy-take
|
||||
(t 'lazy-take m:lazy
|
||||
(take (+ 0 2) (list (+ 1 2) (+ 3 4) (/ 1 0)))
|
||||
:: (take {(+ 0 2)} (list (+ 1 2) (+ 3 4) (/ 1 0)))
|
||||
-> (take {2} (list (+ 1 2) (+ 3 4) (/ 1 0)))
|
||||
:: {(take 2 (list (+ 1 2) (+ 3 4) (/ 1 0)))}
|
||||
-> {(cons (+ 1 2) <DelayedEvaluation#0>)})
|
||||
-> {(cons (+ 1 2) ,(<delay#> 0))})
|
||||
|
||||
; lazy-take-impl
|
||||
; (define (take-n n lst)
|
||||
|
|
@ -1836,8 +1840,8 @@
|
|||
(t 'lazy-unknown1 m:lazy
|
||||
(second (take 3 (list (+ 1 2) (+ 3 4) (/ 1 0))))
|
||||
:: (second {(take 3 (list (+ 1 2) (+ 3 4) (/ 1 0)))})
|
||||
-> (second {(cons (+ 1 2) <DelayedEvaluation#0>)})
|
||||
:: {(second (cons (+ 1 2) (cons (+ 3 4) <DelayedEvaluation#1>)))}
|
||||
-> (second {(cons (+ 1 2) ,(<delay#> 0))})
|
||||
:: {(second (cons (+ 1 2) (cons (+ 3 4) ,(<delay#> 1))))}
|
||||
-> {(+ 3 4)} -> {7})
|
||||
|
||||
; lazy-unknown2
|
||||
|
|
@ -1847,24 +1851,76 @@
|
|||
[lam `(lambda (x) ,body)]
|
||||
[subarg `(take 4 (list (+ 1 2) (+ 3 4) (+ 5 6) (+ 7 8) (/ 1 0)))]
|
||||
[arg `(cdr ,subarg)]
|
||||
[arg-red '(cons (+ 3 4) (cons (+ 5 6) <DelayedEvaluation#1>))])
|
||||
[arg-red `(cons (+ 3 4) (cons (+ 5 6) ,(<delay#> 1)))])
|
||||
(t 'lazy-unknown2 m:lazy
|
||||
,def (f ,arg)
|
||||
:: ,def ({f} ,arg) -> ,def ({,lam} ,arg)
|
||||
:: ,def {(,lam ,arg)} -> ,def {,(make-body arg)}
|
||||
:: ,def ,(make-body `(cdr {,subarg}))
|
||||
-> ,def ,(make-body `(cdr {(cons (+ 1 2) <DelayedEvaluation#0>)}))
|
||||
:: ,def ,(make-body `{(cdr (cons (+ 1 2) <DelayedEvaluation#0>))})
|
||||
-> ,def ,(make-body `{<DelayedEvaluation#0>})
|
||||
-> ,def ,(make-body `(cdr {(cons (+ 1 2) ,(<delay#> 0))}))
|
||||
:: ,def ,(make-body `{(cdr (cons (+ 1 2) ,(<delay#> 0)))})
|
||||
-> ,def ,(make-body `{,(<delay#> 0)})
|
||||
:: ,def (+ {(second ,arg-red)} (third ,arg-red))
|
||||
-> ,def (+ {(+ 5 6)} (third ,arg-red))
|
||||
:: ,def (+ {(+ 5 6)} (third (cons (+ 3 4) (cons {(+ 5 6)} <DelayedEvaluation#1>))))
|
||||
-> ,def (+ {11} (third (cons (+ 3 4) (cons {11} <DelayedEvaluation#1>))))
|
||||
:: ,def (+ 11 {(third (cons (+ 3 4) (cons 11 <DelayedEvaluation#1>)))})
|
||||
:: ,def (+ {(+ 5 6)} (third (cons (+ 3 4) (cons {(+ 5 6)} ,(<delay#> 1)))))
|
||||
-> ,def (+ {11} (third (cons (+ 3 4) (cons {11} ,(<delay#> 1)))))
|
||||
:: ,def (+ 11 {(third (cons (+ 3 4) (cons 11 ,(<delay#> 1))))})
|
||||
-> ,def (+ 11 {(+ 7 8)}) -> ,def (+ 11 {15})
|
||||
:: ,def {(+ 11 15)} -> ,def {26}
|
||||
))
|
||||
|
||||
; lazy-inf-list1
|
||||
; (define (add-one x) (+ x 1))
|
||||
; (define nats (cons 1 (map add-one nats)))
|
||||
; (+ (second nats) (third nats))
|
||||
(let* ([add1-body '(+ x 1)]
|
||||
[add1-def `(define (add-one x) ,add1-body)]
|
||||
[add1-lam `(lambda (x) ,add1-body)]
|
||||
[nats-def '(define nats (cons 1 (map add-one nats)))]
|
||||
[nats-def-expanded `(define nats (cons 1 (cons 2 (cons 3 ,(<delay#> 4)))))])
|
||||
(t 'lazy-inf-list1 m:lazy
|
||||
,add1-def ,nats-def (+ (second nats) (third nats))
|
||||
:: ,add1-def ,nats-def (+ (second {nats}) (third nats))
|
||||
-> ,add1-def ,nats-def (+ (second {(cons 1 (map add-one nats))}) (third nats))
|
||||
:: ,add1-def (define nats (cons 1 (map {add-one} nats)))
|
||||
(+ (second (cons 1 (map {add-one} nats))) (third nats))
|
||||
-> ,add1-def (define nats (cons 1 (map {,add1-lam} nats)))
|
||||
(+ (second (cons 1 (map {,add1-lam} nats))) (third nats))
|
||||
:: ,add1-def (define nats (cons 1 (map ,add1-lam {nats})))
|
||||
(+ (second (cons 1 (map ,add1-lam {nats}))) (third nats))
|
||||
-> ,add1-def (define nats (cons 1 (map ,add1-lam {(cons 1 ,(<delay#> 0))})))
|
||||
(+ (second (cons 1 (map ,add1-lam {(cons 1 ,(<delay#> 0))}))) (third nats))
|
||||
:: ,add1-def (define nats (cons 1 {(map ,add1-lam (cons 1 ,(<delay#> 0)))}))
|
||||
(+ (second (cons 1 {(map ,add1-lam (cons 1 ,(<delay#> 0)))})) (third nats))
|
||||
-> ,add1-def (define nats (cons 1 {(cons ,(<delay#> 1) ,(<delay#> 2))}))
|
||||
(+ (second (cons 1 {(cons ,(<delay#> 1) ,(<delay#> 2))})) (third nats))
|
||||
:: ,add1-def (define nats (cons 1 (cons ,(<delay#> 1) ,(<delay#> 2))))
|
||||
(+ {(second (cons 1 (cons ,(<delay#> 1) ,(<delay#> 2))))} (third nats))
|
||||
-> ,add1-def (define nats (cons 1 (cons ,(<delay#> 1) ,(<delay#> 2))))
|
||||
(+ {,(<delay#> 1)} (third nats))
|
||||
:: ,add1-def (define nats (cons 1 (cons {(+ 1 1)} ,(<delay#> 2))))
|
||||
(+ {,(<delay#> 1)} (third nats))
|
||||
-> ,add1-def (define nats (cons 1 (cons {(+ 1 1)} ,(<delay#> 2))))
|
||||
(+ {(+ 1 1)} (third nats))
|
||||
-> ,add1-def (define nats (cons 1 (cons {2} ,(<delay#> 2))))
|
||||
(+ {2} (third nats))
|
||||
:: ,add1-def (define nats (cons 1 (cons 2 ,(<delay#> 2))))
|
||||
(+ 2 (third {nats}))
|
||||
-> ,add1-def (define nats (cons 1 (cons 2 ,(<delay#> 2))))
|
||||
(+ 2 (third {(cons 1 (cons 2 ,(<delay#> 2)))}))
|
||||
:: ,add1-def (define nats (cons 1 (cons 2 ,(<delay#> 2))))
|
||||
(+ 2 {(third (cons 1 (cons 2 ,(<delay#> 2))))})
|
||||
-> ,add1-def (define nats (cons 1 (cons 2 (cons ,(<delay#> 3) ,(<delay#> 4)))))
|
||||
(+ 2 {,(<delay#> 3)})
|
||||
:: ,add1-def (define nats (cons 1 (cons 2 (cons {(+ 2 1)} ,(<delay#> 4)))))
|
||||
(+ 2 {,(<delay#> 3)})
|
||||
-> ,add1-def (define nats (cons 1 (cons 2 (cons {(+ 2 1)} ,(<delay#> 4)))))
|
||||
(+ 2 {(+ 2 1)})
|
||||
-> ,add1-def (define nats (cons 1 (cons 2 (cons {3} ,(<delay#> 4)))))
|
||||
(+ 2 {3})
|
||||
:: ,add1-def ,nats-def-expanded {(+ 2 3)}
|
||||
-> ,add1-def ,nats-def-expanded {5}
|
||||
))
|
||||
|
||||
#;
|
||||
(t1 'teachpack-callbacks
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user