c0f8f1cdb2
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
186 lines
6.2 KiB
Racket
186 lines
6.2 KiB
Racket
#lang scheme/base
|
|
|
|
(require mzlib/list
|
|
mzlib/contract
|
|
"my-macros.ss"
|
|
"shared.ss"
|
|
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
|
|
|
|
(define-struct full-mark-struct (source label bindings values))
|
|
|
|
; CONTRACTS
|
|
(define mark? (-> ; no args
|
|
full-mark-struct?))
|
|
(define mark-list? (listof procedure?))
|
|
|
|
(provide/contract
|
|
;[make-debug-info (any/c binding-set? varref-set? any/c boolean? . -> . syntax?)] ; (location tail-bound free label lifting? -> mark-stx)
|
|
[expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))]
|
|
[make-top-level-mark (syntax? . -> . syntax?)]
|
|
[lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))]
|
|
[lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any/c)]
|
|
[lookup-binding (mark-list? identifier? . -> . any)])
|
|
|
|
(provide
|
|
make-debug-info
|
|
wcm-wrap
|
|
skipto-mark?
|
|
skipto-mark
|
|
strip-skiptos
|
|
mark-list?
|
|
mark-source
|
|
mark-bindings
|
|
mark-label
|
|
mark-binding-value
|
|
mark-binding-binding
|
|
display-mark
|
|
all-bindings
|
|
#;lookup-binding-list
|
|
debug-key
|
|
extract-mark-list
|
|
(struct-out normal-breakpoint-info)
|
|
(struct-out error-breakpoint-info)
|
|
(struct-out breakpoint-halt)
|
|
(struct-out expression-finished))
|
|
|
|
; BREAKPOINT STRUCTURES
|
|
|
|
(define-struct normal-breakpoint-info (mark-list kind))
|
|
(define-struct error-breakpoint-info (message))
|
|
(define-struct breakpoint-halt ())
|
|
(define-struct expression-finished (returned-value-list))
|
|
|
|
(define-struct skipto-mark-struct ())
|
|
(define skipto-mark? skipto-mark-struct?)
|
|
(define skipto-mark (make-skipto-mark-struct))
|
|
(define (strip-skiptos mark-list)
|
|
(filter (lx (not (skipto-mark? _))) mark-list))
|
|
|
|
|
|
; debug-key: this key will be used as a key for the continuation marks.
|
|
(define-struct debug-key-struct ())
|
|
(define debug-key (make-debug-key-struct))
|
|
|
|
(define (extract-mark-list mark-set)
|
|
(strip-skiptos (continuation-mark-set->list mark-set debug-key)))
|
|
|
|
|
|
; the 'varargs' creator is used to avoid an extra cons cell in every mark:
|
|
(define (make-make-full-mark-varargs source label bindings)
|
|
(lambda values
|
|
(make-full-mark-struct source label bindings values)))
|
|
|
|
; see module top for type
|
|
(define (make-full-mark location label bindings)
|
|
(datum->syntax #'here `(#%plain-lambda () (#%plain-app ,(make-make-full-mark-varargs location label bindings)
|
|
,@(map make-mark-binding-stx bindings)))))
|
|
|
|
(define (mark-source mark)
|
|
(full-mark-struct-source (mark)))
|
|
|
|
(define (make-mark-binding-stx id)
|
|
#`(#%plain-lambda () #,id))
|
|
|
|
(define (mark-bindings mark)
|
|
(map list
|
|
(full-mark-struct-bindings (mark))
|
|
(full-mark-struct-values (mark))))
|
|
|
|
(define (mark-label mark)
|
|
(full-mark-struct-label (mark)))
|
|
|
|
(define (mark-binding-value mark-binding)
|
|
(with-handlers ([(λ (e) #t) (λ (e) "--- undefined ---")])
|
|
((cadr mark-binding))))
|
|
|
|
(define (mark-binding-binding mark-binding)
|
|
(car mark-binding))
|
|
|
|
(define (expose-mark mark)
|
|
(let ([source (mark-source mark)]
|
|
[label (mark-label mark)]
|
|
[bindings (mark-bindings mark)])
|
|
(list source
|
|
label
|
|
(map (lambda (binding)
|
|
(list (mark-binding-binding binding)
|
|
(mark-binding-value binding)))
|
|
bindings))))
|
|
|
|
(define (display-mark mark)
|
|
(apply
|
|
string-append
|
|
(format "source: ~a\n" (syntax->datum (mark-source mark)))
|
|
(format "label: ~a\n" (mark-label mark))
|
|
(format "bindings:\n")
|
|
(map (lambda (binding)
|
|
(format " ~a : ~a\n" (syntax-e (mark-binding-binding binding))
|
|
(mark-binding-value binding)))
|
|
(mark-bindings mark))))
|
|
|
|
|
|
; possible optimization: rig the mark-maker to guarantee statically that a
|
|
; variable can occur at most once in a mark.
|
|
|
|
(define (binding-matches matcher mark)
|
|
(filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark)))
|
|
|
|
(define (lookup-all-bindings matcher mark-list)
|
|
(apply append (map (lambda (m) (binding-matches matcher m)) mark-list)))
|
|
|
|
(define (lookup-first-binding matcher mark-list fail-thunk)
|
|
(let ([all-bindings (lookup-all-bindings matcher mark-list)])
|
|
(if (null? all-bindings)
|
|
(fail-thunk)
|
|
(car all-bindings))))
|
|
|
|
(define (lookup-binding mark-list id)
|
|
(mark-binding-value
|
|
(lookup-first-binding (lambda (id2) (free-identifier=? id id2))
|
|
mark-list
|
|
(lambda ()
|
|
(error 'lookup-binding "variable not found in environment: ~a\n" (if (syntax? id)
|
|
(syntax->datum id)
|
|
id))))))
|
|
|
|
(define (all-bindings mark)
|
|
(map mark-binding-binding (mark-bindings mark)))
|
|
|
|
(define (wcm-wrap debug-info expr)
|
|
#`(with-continuation-mark #,debug-key #,debug-info #,expr))
|
|
|
|
|
|
; DEBUG-INFO STRUCTURES
|
|
|
|
;;;;;;;;;;
|
|
;;
|
|
;; make-debug-info builds the thunk which will be the mark at runtime. It contains
|
|
;; a source expression and a set of binding/value pairs.
|
|
;; (syntax-object BINDING-SET VARREF-SET any boolean (union/c false/c integer?)) -> debug-info)
|
|
;;
|
|
;;;;;;;;;;
|
|
|
|
(define (make-debug-info source tail-bound free-vars label lifting?)
|
|
(define kept-vars (binding-set-varref-set-intersect tail-bound free-vars))
|
|
(define (let-binding? var)
|
|
(and
|
|
(not (stepper-syntax-property var 'stepper-no-lifting-info))
|
|
(case (stepper-syntax-property var 'stepper-binding-type)
|
|
((let-bound macro-bound) #t)
|
|
((lambda-bound stepper-temp non-lexical) #f)
|
|
(else (error 'make-debug-info
|
|
"varref ~a's binding-type info was not recognized: ~a"
|
|
(syntax-e var)
|
|
(stepper-syntax-property var 'stepper-binding-type))))))
|
|
(cond [lifting?
|
|
(define let-bindings (filter let-binding? kept-vars))
|
|
(define lifter-syms (map get-lifted-var let-bindings))
|
|
(make-full-mark source label (append kept-vars lifter-syms))]
|
|
[else
|
|
;; I'm not certain that non-lifting is currently tested: 2005-12, JBC
|
|
(make-full-mark source label kept-vars)]))
|
|
|
|
|
|
(define (make-top-level-mark source-expr)
|
|
(make-full-mark source-expr 'top-level null))
|