222 lines
11 KiB
Scheme
222 lines
11 KiB
Scheme
;step collector state machine (not yet implemented):
|
|
;
|
|
; datatype held-type = NO-HELD-STEP | SKIPPED-STEP | HELD(args)
|
|
;
|
|
; states: global state of held
|
|
; global: held : held-type
|
|
; edge-names: first, skipped-first, second, skipped-second, double, late-let
|
|
;
|
|
;transitions (& actions):
|
|
;
|
|
; held = NO-HELD-STEP :
|
|
; first(x) : held := HELD(x)
|
|
; skipped-first : held := SKIPPED-STEP
|
|
; second(x) : trigger(NO-HELD-STEP, x), held := NO-HELD-STEP ; this happens when evaluating unannotated code
|
|
; skipped-second : held := NO-HELD-STEP ; I believe this can also arise in unannotated code
|
|
; double(x) : double-trigger(x), held := NO-HELD-STEP
|
|
; late-let(x) : late-let-trigger(x), held := NO-HELD-STEP
|
|
;
|
|
; held = SOME(SKIPPED-STEP) :
|
|
; first(x) : ERROR
|
|
; skipped-first : ERROR
|
|
; second(x) : held := NO-HELD-STEP ; this happens e.g. for evaluation of top-level var bound to a procedure
|
|
; skipped-second : held := NO-HELD-STEP
|
|
; double(x) : ERROR
|
|
; late-let(x) : ERROR
|
|
;
|
|
; held = SOME(HELD(args))
|
|
; first(x) : ERROR
|
|
; skipped-first : ERROR
|
|
; second(x) : trigger(HELD(args),x), held = NO-HELD-STEP
|
|
; skipped-second : held = NO-HELD-STEP
|
|
; double(x) : ERROR
|
|
; late-let(x) : ERROR
|
|
|
|
|
|
(module model mzscheme
|
|
(require (lib "contract.ss")
|
|
(lib "etc.ss")
|
|
(lib "list.ss")
|
|
"my-macros.ss"
|
|
(prefix a: "annotate.ss")
|
|
(prefix r: "reconstruct.ss")
|
|
"shared.ss"
|
|
"marks.ss"
|
|
"testing-shared.ss"
|
|
"model-settings.ss")
|
|
|
|
|
|
(define program-expander-contract
|
|
((-> void?) ; init
|
|
((union eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter
|
|
. -> .
|
|
void?))
|
|
|
|
|
|
(provide/contract [go (program-expander-contract ; program-expander
|
|
(step-result? . -> . void?) ; receive-result
|
|
(union render-settings? false/c) ; render-settings
|
|
boolean? ; track-inferred-names?
|
|
. -> .
|
|
void?)])
|
|
|
|
; go starts a stepper instance
|
|
; see provide stmt for contract
|
|
(define (go program-expander receive-result render-settings track-inferred-names?)
|
|
|
|
(local
|
|
|
|
((define finished-exprs null)
|
|
|
|
(define held-expr-list no-sexp)
|
|
(define held-step-was-app? #f)
|
|
|
|
(define basic-eval (current-eval))
|
|
|
|
; redivide takes a list of sexps and divides them into the 'before', 'during', and 'after' lists,
|
|
; where the before and after sets are maximal-length lists where none of the s-expressions contain
|
|
; a highlight-placeholder
|
|
; (->* ((listof syntax)) (list/c syntax syntax syntax))
|
|
(define (redivide exprs)
|
|
(letrec ([contains-highlight
|
|
(lambda (expr)
|
|
(or (syntax-property expr 'stepper-highlight)
|
|
(syntax-case expr ()
|
|
[(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))]
|
|
[else #f])))])
|
|
(let* ([list-length (length exprs)]
|
|
[split-point-a (- list-length (length (or (memf contains-highlight exprs) null)))]
|
|
[split-point-b (length (or (memf contains-highlight (reverse exprs)) null))])
|
|
(if (<= split-point-b split-point-a)
|
|
(error 'redivide-exprs "s-expressions did not contain the highlight-placeholder: ~v" (map syntax-object->hilite-datum exprs))
|
|
(values (sublist 0 split-point-a exprs) ; before
|
|
(sublist split-point-a split-point-b exprs) ; during
|
|
(sublist split-point-b list-length exprs)))))) ; after
|
|
|
|
|
|
; (redivide `(3 4 (+ (define ,highlight-placeholder) 13) 5 6))
|
|
; (values `(3 4) `((+ (define ,highlight-placeholder) 13)) `(5 6))
|
|
;
|
|
; (redivide `(,highlight-placeholder 5 6))
|
|
; (values `() `(,highlight-placeholder) `(5 6))
|
|
;
|
|
; (redivide `(4 5 ,highlight-placeholder ,highlight-placeholder))
|
|
; (values `(4 5) `(,highlight-placeholder ,highlight-placeholder) `())
|
|
;
|
|
; (printf "will be errors:~n")
|
|
; (equal? (redivide `(1 2 3 4))
|
|
; error-value)
|
|
;
|
|
; (redivide `(1 2 ,highlight-placeholder 3 ,highlight-placeholder 4 5))
|
|
; (values `(1 2) `(,highlight-placeholder 3 ,highlight-placeholder) `(4 5))
|
|
|
|
|
|
(define break
|
|
(opt-lambda (mark-set break-kind [returned-value-list null])
|
|
|
|
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
|
|
|
|
(define (double-redivide finished-exprs new-exprs-before new-exprs-after)
|
|
(let*-values ([(before current after) (redivide new-exprs-before)]
|
|
[(before-2 current-2 after-2) (redivide new-exprs-after)])
|
|
(unless (equal? (map syntax-object->hilite-datum before)
|
|
(map syntax-object->hilite-datum before-2))
|
|
(error 'double-redivide "reconstructed before defs are not equal."))
|
|
(unless (equal? (map syntax-object->hilite-datum after)
|
|
(map syntax-object->hilite-datum after-2))
|
|
(error 'double-redivide "reconstructed after defs are not equal."))
|
|
(values (append finished-exprs before) current current-2 after)))
|
|
|
|
(define (reconstruct-helper)
|
|
(r:reconstruct-current mark-list break-kind returned-value-list render-settings))
|
|
|
|
(if (r:skip-step? break-kind mark-list render-settings)
|
|
(when (eq? break-kind 'normal-break)
|
|
(set! held-expr-list skipped-step))
|
|
(case break-kind
|
|
[(normal-break)
|
|
(begin
|
|
(set! held-expr-list (reconstruct-helper))
|
|
(set! held-step-was-app? (r:step-was-app? mark-list)))]
|
|
|
|
[(result-exp-break result-value-break)
|
|
(if (eq? held-expr-list skipped-step)
|
|
(set! held-expr-list no-sexp)
|
|
(let* ([reconstructed (reconstruct-helper)]
|
|
[result
|
|
(if (not (eq? held-expr-list no-sexp))
|
|
(let*-values
|
|
([(step-kind) (if (and held-step-was-app?
|
|
(eq? break-kind 'result-exp-break))
|
|
'user-application
|
|
'normal)]
|
|
[(new-finished current-pre current-post after)
|
|
(double-redivide finished-exprs held-expr-list reconstructed)])
|
|
(make-before-after-result new-finished current-pre current-post after step-kind))
|
|
|
|
(let*-values
|
|
([(before current after) (redivide reconstructed)])
|
|
(make-before-after-result (append finished-exprs before) (list
|
|
(syntax-property #`(... ...)
|
|
'stepper-highlight
|
|
#t))
|
|
current after 'normal)))])
|
|
(set! held-expr-list no-sexp)
|
|
(receive-result result)))]
|
|
[(double-break)
|
|
; a double-break occurs at the beginning of a let's evaluation.
|
|
(let* ([reconstruct-quadruple (reconstruct-helper)])
|
|
(when (not (eq? held-expr-list no-sexp))
|
|
(error 'break-reconstruction
|
|
"held-expr-list not empty when a double-break occurred"))
|
|
(let*-values
|
|
([(new-finished current-pre current-post after)
|
|
(double-redivide finished-exprs
|
|
(list-ref reconstruct-quadruple 0)
|
|
(list-ref reconstruct-quadruple 1))])
|
|
(receive-result (make-before-after-result new-finished
|
|
current-pre
|
|
current-post
|
|
after
|
|
'normal))))]
|
|
[(late-let-break)
|
|
(let ([new-finished (r:reconstruct-current mark-list break-kind returned-value-list render-settings)])
|
|
(set! finished-exprs (append finished-exprs new-finished)))]
|
|
|
|
[(expr-finished-break)
|
|
(let ([reconstructed (r:reconstruct-completed mark-list returned-value-list render-settings)])
|
|
(set! finished-exprs (append finished-exprs (list reconstructed))))]
|
|
|
|
[(define-struct-break)
|
|
(set! finished-exprs (append finished-exprs
|
|
(list (car returned-value-list))))]
|
|
|
|
[else (error 'break "unknown label on break")])))))
|
|
|
|
(define (step-through-expression expanded expand-next-expression)
|
|
(let* ([annotated (a:annotate expanded break track-inferred-names?)])
|
|
(eval-syntax annotated)
|
|
(expand-next-expression)))
|
|
|
|
(define (err-display-handler message exn)
|
|
(if (not (eq? held-expr-list no-sexp))
|
|
(let*-values ([(before current after) (redivide held-expr-list)])
|
|
(set! held-expr-list no-sexp)
|
|
(receive-result (make-before-error-result (append finished-exprs before)
|
|
current message after)))
|
|
(receive-result (make-error-result finished-exprs message)))))
|
|
|
|
(program-expander
|
|
(lambda ()
|
|
; swap these to allow errors to escape (e.g., when debugging)
|
|
(error-display-handler err-display-handler)
|
|
;(void)
|
|
)
|
|
(lambda (expanded continue-thunk) ; iter
|
|
(if (eof-object? expanded)
|
|
(begin
|
|
(receive-result (make-finished-result finished-exprs))
|
|
(receive-result (make-finished-stepping)))
|
|
(step-through-expression expanded continue-thunk)))))))
|
|
|