4ef7e1fae3
remove stepper/private/lazy-highlighting.rkt in stepper/private/macro-unwind.rkt: - in fall-through, add lazy-proc to lazy #%app special case in stepper/private/model.rkt - in send-step, dont use highlight-table, just match top called fn in mark-list instead in tests/stepper/ - add lazy stepper tests for filter and fold
558 lines
24 KiB
Racket
558 lines
24 KiB
Racket
#lang scheme/base
|
|
|
|
;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
|
|
|
|
|
|
(require scheme/contract
|
|
scheme/match
|
|
scheme/class
|
|
scheme/list
|
|
(prefix-in a: "annotate.ss")
|
|
(prefix-in r: "reconstruct.ss")
|
|
"shared.ss"
|
|
"marks.ss"
|
|
"model-settings.ss"
|
|
"macro-unwind.ss"
|
|
"lifting.ss"
|
|
(prefix-in test-engine: test-engine/scheme-tests)
|
|
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
|
|
;; for breakpoint display
|
|
;; (commented out to allow nightly testing)
|
|
#;"display-break-stuff.ss"
|
|
(for-syntax scheme/base))
|
|
|
|
|
|
(define program-expander-contract
|
|
((-> void?) ; init
|
|
((or/c 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
|
|
(or/c render-settings? false/c)) ; render-settings
|
|
(#:raw-step-receiver
|
|
(-> continuation-mark-set? symbol? void?)
|
|
#:disable-error-handling? boolean?)
|
|
void?)])
|
|
|
|
|
|
(define-struct posn-info (posn span))
|
|
|
|
(provide (struct-out posn-info))
|
|
|
|
|
|
; go starts a stepper instance
|
|
; see provide stmt for contract
|
|
(define (go program-expander receive-result render-settings
|
|
#:disable-error-handling? [disable-error-handling? #f]
|
|
#:raw-step-receiver [raw-step-receiver #f])
|
|
|
|
(define DEBUG #f)
|
|
|
|
;; finished-exps:
|
|
;; (listof (list/c syntax-object? (or/c number? false?)( -> any)))
|
|
;; because of mutation, these cannot be fixed renderings, but must be
|
|
;; re-rendered at each step.
|
|
(define finished-exps null)
|
|
(define/contract add-to-finished
|
|
((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any)
|
|
. -> . void?)
|
|
(lambda (exp-thunk lifting-indices getter)
|
|
(set! finished-exps
|
|
(append finished-exps
|
|
(list (list exp-thunk lifting-indices getter))))))
|
|
|
|
;; the "held" variables are used to store the "before" step.
|
|
(define held-exp-list the-no-sexp)
|
|
|
|
(define-struct held (exps was-app? source-info))
|
|
|
|
(define held-finished-list null)
|
|
|
|
(define (reset-held-exp-list)
|
|
(set! held-exp-list the-no-sexp)
|
|
(set! held-finished-list null)
|
|
(set! lhs-recon-thunk null))
|
|
|
|
; used when determining whether to skip step with ellipses on LHS
|
|
(define last-rhs-exps null)
|
|
|
|
; thunk that can re-reconstruct the last lhs
|
|
(define lhs-recon-thunk null)
|
|
|
|
; used to resolve lhs ellipses, to make sure highlighting is correct
|
|
; steps are pushed onto the stack:
|
|
; when step=? but not step-and-highlight=?
|
|
; steps are popped off the stack:
|
|
; lhs = ellipses and rhs != last-rhs-exps and skips = 0
|
|
; skips are defined for each fn in lazy-highlighting.rkt;
|
|
; # of skips depends on # of hidden !'s in fn def
|
|
(define highlight-stack null)
|
|
(define (highlight-stack-push mark-list)
|
|
(let ([top-called-fn (find-top-called-fn mark-list)])
|
|
(when DEBUG
|
|
(printf "top called fn = ~a\n" top-called-fn))
|
|
(set! highlight-stack
|
|
(cons (cons top-called-fn lhs-recon-thunk) highlight-stack))))
|
|
(define (find-top-called-fn mark-list)
|
|
(if (null? mark-list)
|
|
#f
|
|
(let ([top-mark (car mark-list)])
|
|
(if (eq? 'called (mark-label top-mark))
|
|
(object-name (lookup-binding (list top-mark) (get-arg-var 0)))
|
|
(find-top-called-fn (cdr mark-list))))))
|
|
(define (highlight-stack-pop)
|
|
(set! highlight-stack (cdr highlight-stack)))
|
|
|
|
|
|
|
|
;; highlight-mutated-expressions :
|
|
;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?))
|
|
;; -> (list/c (listof syntax?) (listof syntax?)))
|
|
;; highlights changes occurring due to mutation. This function accepts the
|
|
;; left-hand-side expressions and the right-hand-side expressions, and
|
|
;; matches them against each other to see which ones have changed due to
|
|
;; mutation, and highlights these.
|
|
;; POSSIBLE RESEARCH POINT: if, say, (list 3 4) is mutated to (list 4 5),
|
|
;; should the 4 & 5 be highlighted individually or should the list as a
|
|
;; whole be highlighted. Is either one "wrong?" equivalences between
|
|
;; reduction semantics?
|
|
;;
|
|
;; 2005-11-14: punting. just highlight the whole darn thing if there are
|
|
;; any differences. In fact, just test for eq?-ness.
|
|
|
|
#;
|
|
(define (highlight-mutated-expressions lefts rights)
|
|
(if (or (null? lefts) (null? rights))
|
|
(list lefts rights)
|
|
(let ([left-car (car lefts)]
|
|
[right-car (car rights)])
|
|
(if (eq? (syntax-property left-car 'user-source)
|
|
(syntax-property right-car 'user-source))
|
|
(let ([highlights-added
|
|
(highlight-mutated-expression left-car right-car)]
|
|
[rest (highlight-mutated-expressions
|
|
(cdr lefts) (cdr rights))])
|
|
(cons (cons (car highlights-added) (car rest))
|
|
(cons (cadr highlights-added) (cadr rest))))))))
|
|
|
|
;; highlight-mutated-expression: syntax? syntax? -> syntax?
|
|
;; given two expressions, highlight 'em both if they differ at all.
|
|
|
|
;; notes: wanted to use simple "eq?" test... but this will fail when a
|
|
;; being-stepped definition (e.g. in a let) turns into a permanent one.
|
|
;; We pay a terrible price for the lifting thing. And, for the fact that
|
|
;; the highlighting follows from the reductions but can't obviously be
|
|
;; deduced from them.
|
|
|
|
#;
|
|
(define (highlight-mutated-expression left right)
|
|
(cond
|
|
;; if either one is already highlighted, leave them alone.
|
|
[(or (stepper-syntax-property left 'stepper-highlight)
|
|
(stepper-syntax-property right 'stepper-highlight))
|
|
(list left right)]
|
|
|
|
;; first pass: highlight if not eq?. Should be broken for local-bound
|
|
;; things as they pass into permanence.
|
|
[(eq? left right)
|
|
(list left right)]
|
|
|
|
[else (list (stepper-syntax-property left 'stepper-highlight)
|
|
(stepper-syntax-property right 'stepper-highlight))]))
|
|
|
|
;; mutated on receipt of a break, used in displaying breakpoint stuff.
|
|
(define steps-received 0)
|
|
|
|
(define break
|
|
(lambda (mark-set break-kind [returned-value-list #f])
|
|
(when DEBUG
|
|
(printf "\n---------- BREAK TYPE = ~a ----------\n" break-kind))
|
|
|
|
(set! steps-received (+ steps-received 1))
|
|
;; have to be careful else this won't be looked up right away:
|
|
;; (commented out to allow nightly tests to proceed, 2007-09-04
|
|
#;(when (getenv "PLTSTEPPERUNSAFE")
|
|
(let ([steps-received/current steps-received])
|
|
(run-on-drscheme-side
|
|
(lambda ()
|
|
(display-break-stuff
|
|
steps-received/current
|
|
mark-set break-kind returned-value-list)))))
|
|
|
|
(let* ([mark-list (and mark-set (extract-mark-list mark-set))]
|
|
[dump-marks
|
|
(when DEBUG
|
|
(printf "MARKLIST:\n")
|
|
(and mark-set
|
|
(map (λ (x) (printf "~a\n" (display-mark x))) mark-list))
|
|
(printf "RETURNED VALUE LIST: ~a\n" returned-value-list))])
|
|
|
|
(define (reconstruct-all-completed)
|
|
(filter-map
|
|
(match-lambda
|
|
[(list source-thunk lifting-indices getter)
|
|
(let ([source (source-thunk)])
|
|
(if (r:hide-completed? source)
|
|
#f
|
|
(match (r:reconstruct-completed
|
|
source lifting-indices
|
|
getter render-settings)
|
|
[(vector exp #f) (unwind exp render-settings)]
|
|
[(vector exp #t) exp])))])
|
|
finished-exps))
|
|
|
|
(define (compute-posn-info)
|
|
(mark-list->posn-info mark-list))
|
|
|
|
(define (compute-step-was-app?)
|
|
(r:step-was-app? mark-list))
|
|
|
|
(define (compute-step-kind held-step-was-app?)
|
|
(if (and held-step-was-app?
|
|
(eq? break-kind 'result-exp-break))
|
|
'user-application
|
|
'normal))
|
|
|
|
(define (create-held exps)
|
|
(make-held exps (compute-step-was-app?) (compute-posn-info)))
|
|
|
|
(define-syntax (with-DEBUG stx)
|
|
(syntax-case stx ()
|
|
[(_ exp msg) #'(and exp (when DEBUG (printf msg)))]))
|
|
|
|
; sends a step to the stepper, except if
|
|
; - lhs = rhs
|
|
; - lhs = ellipses, highlight-stack = null (ie, this is first step)
|
|
; - lhs = ellipses, rhs = last-rhs-exps
|
|
; when lhs = ellipses, and highlight-stack != null,
|
|
; pop step from stack and use lhs
|
|
(define (send-step lhs-exps lhs-finished-exps
|
|
rhs-exps rhs-finished-exps
|
|
step-kind lhs-posn-info rhs-posn-info)
|
|
|
|
(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")
|
|
(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 (lhs = ...)
|
|
[(null? highlight-stack)
|
|
(if (not (null? last-rhs-exps))
|
|
(send-it)
|
|
(when DEBUG
|
|
(printf "SKIPPING STEP (LHS = ellipses and highlight-stack = null)\n")))]
|
|
; if top-called-fn = top of highlight stack,
|
|
; then send step with lhs = lhs-thunk on highlight stack
|
|
; else if last-rhs != null, send it, else skip
|
|
[else
|
|
(let ([top-called-fn (caar highlight-stack)]
|
|
[lhs-thunk (cdar highlight-stack)])
|
|
(if (and (eq? (find-top-called-fn mark-list) top-called-fn)
|
|
(eq? break-kind 'result-value-break))
|
|
(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))
|
|
(when (not (null? last-rhs-exps))
|
|
(send-it))))])]
|
|
; 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
|
|
(define (step=? lhs rhs)
|
|
(equal? (map syntax->datum lhs)
|
|
(map syntax->datum rhs)))
|
|
(define (step-and-highlight=? lhs rhs)
|
|
(equal? (map syntax->hilite-datum lhs)
|
|
(map syntax->hilite-datum rhs)))
|
|
|
|
#;(>>> break-kind)
|
|
#;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind)
|
|
(if (r:skip-step? break-kind mark-list render-settings)
|
|
(begin
|
|
(when DEBUG (printf "skipped step\n"))
|
|
(when (or (eq? break-kind 'normal-break)
|
|
;; not sure about this...
|
|
(eq? break-kind 'nomal-break/values))
|
|
(set! held-exp-list the-skipped-step)))
|
|
|
|
(begin
|
|
(case break-kind
|
|
; CASE: normal-break or normal-break/values -------------------
|
|
[(normal-break normal-break/values)
|
|
(begin
|
|
(when (and (eq? break-kind 'normal-break)
|
|
returned-value-list)
|
|
(error 'break
|
|
"broken invariant: normal-break can't have returned values"))
|
|
(let*
|
|
([lhs-reconstructed
|
|
(r:reconstruct-left-side
|
|
mark-list returned-value-list render-settings)]
|
|
[print-lhs-recon
|
|
(when DEBUG
|
|
(printf "LHS (pre-unwound):\n ~a\n"
|
|
(syntax->hilite-datum lhs-reconstructed)))]
|
|
[lhs-unwound
|
|
(map (λ (exp) (unwind exp render-settings))
|
|
(maybe-lift lhs-reconstructed #f))]
|
|
[print-lhs-unwound
|
|
(when DEBUG
|
|
(for-each
|
|
(λ (x) (printf "LHS (unwound): ~a\n"
|
|
(syntax->hilite-datum x)))
|
|
lhs-unwound))]
|
|
[lhs-finished-exps (reconstruct-all-completed)])
|
|
(set! held-finished-list lhs-finished-exps)
|
|
(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
|
|
mark-list
|
|
returned-value-list
|
|
render-settings)
|
|
#f))))))]
|
|
|
|
; CASE: result-exp-break or result-value-break ----------------
|
|
[(result-exp-break result-value-break)
|
|
(let ([reconstruct
|
|
(lambda ()
|
|
(let* ([rhs-reconstructed
|
|
(r:reconstruct-right-side
|
|
mark-list returned-value-list render-settings)]
|
|
[print-rhs-recon
|
|
(when DEBUG
|
|
(printf "RHS (pre-unwound):\n ~a\n"
|
|
(syntax->hilite-datum rhs-reconstructed)))]
|
|
[rhs-unwound
|
|
(map (λ (exp) (unwind exp render-settings))
|
|
(maybe-lift rhs-reconstructed #f))]
|
|
[print-rhs-unwound
|
|
(when DEBUG
|
|
(for-each
|
|
(λ (x) (printf "RHS (unwound): ~a\n"
|
|
(syntax->hilite-datum x)))
|
|
rhs-unwound))])
|
|
rhs-unwound))])
|
|
(match held-exp-list
|
|
[(struct skipped-step ())
|
|
(when DEBUG (printf "LHS = skipped, so skipping RHS\n"))
|
|
;; don't render if before step was a skipped-step
|
|
(reset-held-exp-list)]
|
|
[(struct no-sexp ())
|
|
(when DEBUG (printf "LHS = none\n"))
|
|
;; in this case, there was no "before" step, due
|
|
;; to unannotated code. In this case, we make the
|
|
;; optimistic guess that none of the finished
|
|
;; expressions were mutated. It would be somewhat
|
|
;; painful to do a better job, and the stepper
|
|
;; makes no guarantees in this case.
|
|
(send-step (list #'(... ...)) '() ; lhs
|
|
(reconstruct) (reconstruct-all-completed) ; rhs
|
|
'normal #f #f)
|
|
(reset-held-exp-list)]
|
|
[(struct held (held-exps held-step-was-app? held-posn-info))
|
|
(send-step held-exps held-finished-list
|
|
(reconstruct) (reconstruct-all-completed)
|
|
(compute-step-kind held-step-was-app?)
|
|
held-posn-info (compute-posn-info))
|
|
(reset-held-exp-list)]))]
|
|
|
|
; CASE: double-break ------------------------------------------
|
|
[(double-break)
|
|
;; a double-break occurs at the beginning of a let's
|
|
;; evaluation.
|
|
(when (not (eq? held-exp-list the-no-sexp))
|
|
(error
|
|
'break-reconstruction
|
|
"held-exp-list not empty when a double-break occurred"))
|
|
(let* ([new-finished-list (reconstruct-all-completed)]
|
|
[reconstruct-result
|
|
(r:reconstruct-double-break mark-list render-settings)]
|
|
[print-recon
|
|
(when DEBUG
|
|
(printf "LHS (pre-unwound):\n ~a\n"
|
|
(syntax->hilite-datum (car reconstruct-result)))
|
|
(printf "RHS (pre-unwound):\n ~a\n"
|
|
(syntax->hilite-datum (cadr reconstruct-result))))]
|
|
[lhs-unwound (map (lambda (exp) (unwind exp render-settings))
|
|
(maybe-lift (car reconstruct-result) #f))]
|
|
[rhs-unwound (map (lambda (exp) (unwind exp render-settings))
|
|
(maybe-lift (cadr reconstruct-result) #t))]
|
|
[print-unwound
|
|
(when DEBUG
|
|
(for-each (λ (x) (printf "LHS (unwound):\n ~a\n"
|
|
(syntax->hilite-datum x)))
|
|
lhs-unwound)
|
|
(for-each (λ (x) (printf "right side (unwound):\n ~a\n"
|
|
(syntax->hilite-datum x)))
|
|
rhs-unwound))])
|
|
(send-step lhs-unwound new-finished-list
|
|
rhs-unwound new-finished-list
|
|
'normal
|
|
(compute-posn-info) (compute-posn-info)))]
|
|
|
|
; CASE: expr-finished-break -----------------------------------
|
|
[(expr-finished-break)
|
|
(unless (not mark-list)
|
|
(error 'break
|
|
"expected no mark-list with expr-finished-break"))
|
|
;; in an expr-finished-break, the returned-vals hold (listof
|
|
;; (list/c source lifting-index getter)) this will now include
|
|
;; define-struct breaks, for which the source is the source
|
|
;; and the getter causes an error.
|
|
(when DEBUG
|
|
(for-each
|
|
(λ (x)
|
|
(printf "add to finished:\n")
|
|
(printf " source: ~a\n" (syntax->hilite-datum ((car x))))
|
|
(printf " index: ~a\n" (second x))
|
|
(printf " getter: ")
|
|
(if (stepper-syntax-property ((car x)) 'stepper-define-struct-hint)
|
|
(printf "no getter for term with stepper-define-struct-hint property\n")
|
|
(printf "~a\n" ((third x)))))
|
|
returned-value-list))
|
|
(for-each (lambda (source/index/getter)
|
|
(apply add-to-finished source/index/getter))
|
|
returned-value-list)]
|
|
|
|
[else (error 'break "unknown label on break")]))))))
|
|
|
|
(define maybe-lift
|
|
(if (render-settings-lifting? render-settings)
|
|
lift
|
|
;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off.
|
|
(lambda (stx dont-care) (list stx))))
|
|
|
|
(define (step-through-expression expanded expand-next-expression)
|
|
(define show-lambdas-as-lambdas?
|
|
(render-settings-show-lambdas-as-lambdas? render-settings))
|
|
(let* ([annotated (a:annotate expanded break
|
|
show-lambdas-as-lambdas?)])
|
|
(parameterize ([test-engine:test-silence #t])
|
|
(eval-syntax annotated))
|
|
(expand-next-expression)))
|
|
|
|
(define (err-display-handler message exn)
|
|
(match held-exp-list
|
|
[(struct no-sexp ())
|
|
(receive-result (make-error-result message))]
|
|
[(struct held (exps dc posn-info))
|
|
(begin
|
|
(receive-result
|
|
(make-before-error-result (append held-finished-list exps)
|
|
message
|
|
posn-info))
|
|
(set! held-exp-list the-no-sexp))]))
|
|
|
|
(program-expander
|
|
(lambda ()
|
|
(unless disable-error-handling?
|
|
(error-display-handler err-display-handler)))
|
|
(lambda (expanded continue-thunk) ; iter
|
|
(r:reset-special-values)
|
|
(if (eof-object? expanded)
|
|
(begin
|
|
(receive-result (make-finished-stepping)))
|
|
(step-through-expression expanded continue-thunk)))))
|
|
|
|
|
|
; no-sexp is used to indicate no sexpression for display.
|
|
; e.g., on an error message, there's no sexp.
|
|
(define-struct no-sexp ())
|
|
(define the-no-sexp (make-no-sexp))
|
|
|
|
; skipped-step is used to indicate that the "before" step was skipped.
|
|
(define-struct skipped-step ())
|
|
(define the-skipped-step (make-skipped-step))
|
|
|
|
;; produce a posn-info structure or false based on the information in a mark-list
|
|
;; mark-list->posn-info : (listof mark) -> (or/c posn-info? false?)
|
|
(define (mark-list->posn-info mark-list)
|
|
(let* ([first-mark-source (mark-source (car mark-list))]
|
|
[posn (syntax-position first-mark-source)]
|
|
[span (syntax-span first-mark-source)])
|
|
(if posn
|
|
(make-posn-info posn span)
|
|
#f)))
|