; general assertions about reconstruction: ; a varref can only occur at the top of a mark-list ; a varref at the top of the mark-list must either be a top-level-variable ; or have a value in some mark somewhere (or both). (module reconstruct mzscheme (require (prefix kernel: (lib "kerncase.ss" "syntax")) (lib "list.ss") (lib "etc.ss") (lib "contract.ss") "marks.ss" "model-settings.ss" "shared.ss" "my-macros.ss" "lifting.ss") (provide/contract [reconstruct-completed (syntax? (union (listof natural-number/c) false/c) (-> (listof any/c)) render-settings? . -> . syntax?)] ;; front ends for reconstruct-current [reconstruct-left-side (mark-list? render-settings? . -> . (listof syntax?))] [reconstruct-right-side (mark-list? (listof any/c) render-settings? . -> . (listof syntax?))] [reconstruct-double-break (mark-list? render-settings? . -> . (list/c (listof syntax?) (listof syntax?)))] [final-mark-list? (-> mark-list? boolean?)] [skip-step? (-> break-kind? (union mark-list? false/c) render-settings? boolean?)] [step-was-app? (-> mark-list? boolean?)]) (define nothing-so-far (gensym "nothing-so-far-")) ; the let-glump is a structure that contains the reconstruct-time data about ; a let-binding; that is, the names on the left-hand-side, the expression on ; the right-hand side, and the values computed. (define-struct let-glump (name-set exp val-set)) ; split-list : ('a -> boolean) (listof 'a) -> (2vals (listof 'a) (listof 'a)) ; split-list splits a list into two lists at the first element s.t. (fn element) => true). ; that is, split-list yields the lists A and B such that (append A B) gives the original ; list, and (fn element) => false for all elements in A, and B is either empty or ; (fn (car B)) => true (define (split-list fn lst) (let loop ([remaining lst] [so-far null]) (cond [(null? remaining) (2vals (reverse so-far) null)] [else (if (fn (car remaining)) (2vals (reverse so-far) remaining) (loop (cdr remaining) (cons (car remaining) so-far)))]))) ; test cases ; (test (2vals '(93 4 2) '(0 2 1)) split-list (lambda (x) (= x 0)) '(93 4 2 0 2 1)) ; (test (2vals '(3 4 5) '()) split-list (lambda (x) (= x 0)) '(3 4 5)) ; n-split-list : num ('a list) -> ('a list) ('a list) ; n-split-list splits a given list A into two lists B and C, such that B contains the ; first n elements of A, and C contains the rest. (define (n-split-list num lst) (when (> num (length lst)) (error 'n-split-list "can't split list ~a after ~ath element; not long enough" lst num)) (let loop ([count num] [remaining lst] [so-far null]) (if (= count 0) (2vals (reverse so-far) remaining) (loop (- count 1) (cdr remaining) (cons (car remaining) so-far))))) ; test cases ; (test (2vals '(a b c) '(d e f)) n-split-list 3 '(a b c d e f)) (define (mark-as-highlight stx) (syntax-property stx 'stepper-highlight #t)) ; ; ; ;; ;;; ;;; ;;; ; ;; ; ; ;;; ; ; ; ;;; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ;;;; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ;;;; ;;; ;;; ; ; ; ;;;;; ; ;; ; ;;;; ; recon-value print-converts a value. If the value is a closure, recon-value ; prints the name attached to the procedure, unless we're on the right-hand-side ; of a let, or unless there _is_ no name. (define recon-value (opt-lambda (val render-settings [assigned-name #f]) (if (hash-table-get finished-xml-box-table val (lambda () #f)) (syntax-property #`(#%datum . #,val) 'stepper-xml-value-hint 'from-xml-box) (let ([closure-record (closure-table-lookup val (lambda () #f))]) (if closure-record (let* ([mark (closure-record-mark closure-record)] [base-name (closure-record-name closure-record)]) (if base-name (let* ([lifted-index (closure-record-lifted-index closure-record)] [name (if lifted-index (construct-lifted-name base-name lifted-index) base-name)]) (if (and assigned-name (free-identifier=? base-name assigned-name)) (recon-source-expr (mark-source mark) (list mark) null null render-settings) #`#,name)) (recon-source-expr (mark-source mark) (list mark) null null render-settings))) (let* ([rendered ((render-settings-render-to-sexp render-settings) val)]) (if (symbol? rendered) #`#,rendered #`(#%datum . #,rendered)))))))) (define (final-mark-list? mark-list) (and (not (null? mark-list)) (eq? (mark-label (car mark-list)) 'final))) ; ; ;;; ; ; ; ;;; ; ; ; ; ;;; ; ; ; ; ; ; ;;; ;;;; ;;; ; ;;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ;; ;; ; ; ; ; ; ; ; ;; ;; ; ; ; ;;;;; ;; ;; ;; ;;;;; ;; ; ;;;;; ; ; ; ; ; ; ; ; ; ;; ;; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ;;; ; ; ; ; ;;; ; ; ; ; ; ; ;;; ;; ;;;; ; ;;; ; ; ; ; ; (define (skip-step? break-kind mark-list render-settings) (case break-kind [(result-value-break) #f] [(result-exp-break) ;; skip if clauses that are the result of and/or reductions (let ([and/or-clauses-consumed (syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)]) (and and/or-clauses-consumed (> and/or-clauses-consumed 0)))] [(normal-break) (skip-redex-step? mark-list render-settings)] [(double-break) (not (render-settings-lifting? render-settings))] [(expr-finished-break define-struct-break late-let-break) #f])) (define (skip-redex-step? mark-list render-settings) (define (varref-skip-step? varref) (with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)]) (let ([val (lookup-binding mark-list varref)]) (equal? (syntax-object->interned-datum (recon-value val render-settings)) (syntax-object->interned-datum (case (syntax-property varref 'stepper-binding-type) ([let-bound] (binding-lifted-name mark-list varref)) ([non-lexical] varref) (else (error 'varref-skip-step? "unexpected value for stepper-binding-type: ~e for variable: ~e\n" (syntax-property varref 'stepper-binding-type) varref)))))))) (and (pair? mark-list) (let ([expr (mark-source (car mark-list))]) (or (kernel:kernel-syntax-case expr #f [id (identifier? expr) (case (syntax-property expr 'stepper-binding-type) [(lambda-bound) #t] ; don't halt for lambda-bound vars [(let-bound) (varref-skip-step? expr)] [(non-lexical) (varref-skip-step? expr)])] [(#%top . id-stx) (varref-skip-step? #`id-stx)] [(#%app . terms) ; don't halt for proper applications of constructors (let ([fun-val (lookup-binding mark-list (get-arg-var 0))]) (and (procedure? fun-val) (procedure-arity-includes? fun-val (length (cdr (syntax->list (syntax terms))))) (or (and (render-settings-constructor-style-printing? render-settings) (if (render-settings-abbreviate-cons-as-list? render-settings) (eq? fun-val (find-special-value 'list '(3))) (and (eq? fun-val (find-special-value 'cons '(3 empty))) (second-arg-is-list? mark-list)))) ;(model-settings:special-function? 'vector fun-val) (and (eq? fun-val void) (eq? (cdr (syntax->list (syntax terms))) null)) (struct-constructor-procedure? fun-val))))] [else #f]))))) (define (find-special-value name valid-args) (let ([expanded (kernel:kernel-syntax-case (expand (cons name valid-args)) #f [(#%app fn . rest) #`fn] [else (error 'find-special-name "couldn't find expanded name for ~a" name)])]) (eval expanded))) (define (second-arg-is-list? mark-list) (let ([arg-val (lookup-binding mark-list (get-arg-var 2))]) (list? arg-val))) ; ; static-binding-indexer (z:parsed -> integer) ; ; (define static-binding-indexer ; (let* ([name-number-table (make-hash-table)] ; [binding-number-table (make-hash-table-weak)]) ; (lambda (binding) ; (cond [(hash-table-get binding-number-table binding (lambda () #f)) => ; (lambda (x) x)] ; [else (let* ([orig-name (z:binding-orig-name binding)] ; [old-index (hash-table-get name-number-table orig-name (lambda () -1))] ; [new-index (+ old-index 1)]) ; (hash-table-put! name-number-table orig-name new-index) ; (hash-table-put! binding-number-table binding new-index) ; new-index)])))) ; construct-lifted-name ; (-> syntax? (union num? false/c) symbol?) (define/contract construct-lifted-name (-> syntax? number? syntax?) (lambda (binding dynamic-index) #`#,(string->symbol (string-append (symbol->string (syntax-e binding)) "_" (number->string dynamic-index))))) ; binding-lifted-name (define/contract binding-lifted-name (-> mark-list? syntax? syntax?) (lambda (mark-list binding) (construct-lifted-name binding (lookup-binding mark-list (get-lifted-var binding))))) (define (step-was-app? mark-list) (and (not (null? mark-list)) (syntax-case (mark-source (car mark-list)) (#%app) [(#%app . rest) #t] [else #f]))) ; ; ; ; ; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ; ;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; unwind takes a syntax object with a single highlight, ; and returns a list of syntax objects (define (unwind stx lift-at-highlight?) (macro-unwind (lift stx lift-at-highlight?))) ; unwind-no-highlight is really just macro-unwind, but with the 'right' interface that ; makes it more obvious what it does. ; [unwind-no-highlight (-> syntax? (listof syntax?))] (define (unwind-no-highlight stx) (macro-unwind (list stx))) ; unwind-only-highlight : syntax? -> (listof syntax?) (define (unwind-only-highlight stx) (unwind stx #t)) (define (first-of-one x) (unless (= (length x) 1) (error 'first-of-one "expected a list of length one in: ~v" x)) (car x)) (define (improper-member elt improper-list) (cond [(pair? improper-list) (or (eq? elt (car improper-list)) (improper-member elt (cdr improper-list)))] [else (eq? elt improper-list)])) (define-syntax (noisy-and stx) (syntax-case stx () [(_) #`#t] [(_ a b ...) (with-syntax ([inner (syntax/loc stx (noisy-and b ...))] [error (syntax/loc #`a (error 'noisy-and "and clause failed"))]) (syntax/loc stx (if a inner error)))] [else (error 'noisy-and "bad syntax for noisy-and")])) ;(->* (syntax? (listof syntax?)) ; (syntax? (listof syntax?))) (define (macro-unwind stxs) (local ((define (recur-on-pieces stx) (if (pair? (syntax-e stx)) (datum->syntax-object stx (syntax-pair-map (syntax-e stx) inner) stx stx) stx)) (define (inner stx) (define (fall-through) (kernel:kernel-syntax-case stx #f [id (identifier? stx) (or (syntax-property stx 'stepper-lifted-name) stx)] [(define-values dc ...) (unwind-define stx)] [(#%app exp ...) (recur-on-pieces #'(exp ...))] [(#%datum . datum) #'datum] [(let-values . rest) (unwind-mz-let stx)] [(letrec-values . rest) (unwind-mz-let stx)] [(set! var rhs) (with-syntax ([unwound-var (or (syntax-property #`var 'stepper-lifted-name) #`var)] [unwound-body (inner #`rhs)]) #`(set! unwound-var unwound-body))] [else (recur-on-pieces stx)])) (transfer-info (if (syntax-property stx 'user-stepper-hint) (case (syntax-property stx 'user-stepper-hint) [(comes-from-cond) (unwind-cond stx (syntax-property stx 'user-source) (syntax-property stx 'user-position))] [(comes-from-and) (unwind-and/or stx (syntax-property stx 'user-source) (syntax-property stx 'user-position) 'and)] [(comes-from-or) (unwind-and/or stx (syntax-property stx 'user-source) (syntax-property stx 'user-position) 'or)] [(comes-from-local) (unwind-local stx)] [(comes-from-recur) (unwind-recur stx)] (else (fall-through))) (fall-through)) stx)) (define (transfer-highlight from to) (if (syntax-property from 'stepper-highlight) (syntax-property to 'stepper-highlight #t) to)) (define (unwind-recur stx) (with-syntax ([(app-keywd letrec-term argval ...) stx]) ; if you use #%app, it gets captured here (with-syntax ([(new-argval ...) (map inner (syntax->list #`(argval ...)))]) (let ([unwound (inner #`letrec-term)]) (syntax-case unwound (letrec lambda) [(letrec ([loop-name (lambda (argname ...) . bodies)]) loop-name-2) (unless (module-identifier=? #`loop-name #`loop-name-2) (error "unexpected syntax for 'recur': ~v" stx)) (transfer-highlight unwound #`(recur loop-name ([argname new-argval] ...) . bodies))] [else #`(#,unwound new-argval ...)]))))) (define (unwind-define stx) (kernel:kernel-syntax-case stx #f [(define-values (name . others) body) (begin (unless (null? (syntax-e #'others)) (error 'reconstruct "reconstruct fails on multiple-values define: ~v\n" (syntax-object->datum stx))) (let* ([printed-name (or (syntax-property #`name 'stepper-lifted-name) (syntax-property #'name 'stepper-orig-name) #'name)] [unwound-body (inner #'body)] [define-type (syntax-property unwound-body 'user-stepper-define-type)]) ; see notes in internal-docs.txt (if define-type (kernel:kernel-syntax-case unwound-body #f [(lambda arglist lam-body ...) (case define-type [(shortened-proc-define) (let ([proc-define-name (syntax-property unwound-body 'user-stepper-proc-define-name)]) (if (or (module-identifier=? proc-define-name #'name) (and (syntax-property #'name 'stepper-orig-name) (module-identifier=? proc-define-name (syntax-property #'name 'stepper-orig-name)))) #`(define (#,printed-name . arglist) lam-body ...) #`(define #,printed-name #,unwound-body)))] [(lambda-define) #`(define #,printed-name #,unwound-body)] [else (error 'unwind-define "unknown value for syntax property 'user-stepper-define-type: ~e" define-type)])] [else (error 'unwind-define "expr with stepper-define-type is not a lambda: ~e" (syntax-object->datum unwound-body))]) #`(define #,printed-name #,unwound-body))))] [else (error 'unwind-define "expression is not a define-values: ~e" (syntax-object->datum stx))])) (define (unwind-mz-let stx) (with-syntax ([(label ([(var) rhs] ...) . bodies) stx]) (with-syntax ([(rhs2 ...) (map inner (syntax->list #'(rhs ...)))] [new-label (if (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint)) #`let* (case (syntax-e #'label) [(let-values) #'let] [(letrec-values) #'letrec]))] [new-bodies (map inner (syntax->list #'bodies))]) (syntax-case #`new-bodies (let*) ; is this let and the nested one part of a let*? [((let* bindings inner-body ...)) (and (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint)) (eq? (syntax-property stx 'user-stepper-source) (syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-source)) (eq? (syntax-property stx 'user-stepper-position) (syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-position))) #`(let* #,(append (syntax->list #`([var rhs2] ...)) (syntax->list #`bindings)) inner-body ...)] [else #`(new-label ([var rhs2] ...) . new-bodies)])))) (define (unwind-local stx) (kernel:kernel-syntax-case stx #f [(letrec-values ([vars exp] ...) body) ; at least through intermediate, define-values may not occur in local. (with-syntax ([defns (map inner (syntax->list #`((define-values vars exp) ...)))]) #`(local defns #,(inner #'body)))] [else (error 'unwind-local "expected a letrec-values, given: ~e" (syntax-object->datum stx))])) ;(define (unwind-quasiquote-the-cons-application stx) ; (syntax-case (recur-on-pieces stx) () ; [(#%app the-cons . rest) ; (syntax (cons . rest))] ; [else ; (error 'reconstruct "unexpected result for unwinding the-cons application")])) (define (unwind-cond-clause stx test-stx result-stx) (with-syntax ([new-test (if (syntax-property stx 'user-stepper-else) #`else (inner test-stx))] [result (inner result-stx)]) #`(new-test result))) (define (unwind-cond stx user-source user-position) (with-syntax ([clauses (let loop ([stx stx]) (if (and (eq? user-source (syntax-property stx 'user-source)) (eq? user-position (syntax-property stx 'user-position))) (syntax-case stx (if begin #%app) [(if test result) ; the else clause disappears when it's a language-inserted else clause (list (unwind-cond-clause stx #`test #`result))] [(if test result else-clause) (cons (unwind-cond-clause stx #`test #`result) (loop (syntax else-clause)))] [(begin . rest) ; else clause appears momentarily in 'before,' even though it's a 'skip-completely' null] [else-stx (error 'unwind-cond "expected an if, got: ~e" (syntax-object->datum (syntax else-stx)))]) (error 'unwind-cond "expected a cond clause expansion, got: ~e" (syntax-object->datum stx))))]) (syntax (cond . clauses)))) (define (unwind-and/or stx user-source user-position label) (let ([clause-padder (case label [(and) #`true] [(or) #`false])]) (with-syntax ([clauses (append (build-list (syntax-property stx 'user-stepper-and/or-clauses-consumed) (lambda (dc) clause-padder)) (let loop ([stx stx]) (if (and (eq? user-source (syntax-property stx 'user-source)) (eq? user-position (syntax-property stx 'user-position))) (syntax-case stx (if let-values #%datum) [(if part-1 part-2 part-3) (cons (inner (syntax part-1)) (case label ((and) (loop (syntax part-2))) ((or) (loop (syntax part-3))) (else (error 'unwind-and/or "unknown label ~a" label))))] [else (error 'unwind-and/or "syntax: ~a does not match and/or patterns" (syntax-object->datum stx))]) null)))]) #`(#,label . clauses))))) (map inner stxs))) ; ;; ;;; ;;; ;;; ; ;; ;;; ;;; ; ; ; ;; ;;; ;;; ;;; ; ; ; ;;; ; ;; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ;; ; ; ; ; ; ; ;;;;; ;;;;; ;;;;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;; ; ; ;;; ;;;; ;;;; ; ; ; ;;; ; ; ; ; recon-source-expr ; recon-source-expr produces the reconstructed version of a given source epxression, using the binding ; information contained in the binding-list. This happens during reconstruction whenever we come upon ; expressions that we haven't yet evaluated. ; NB: the variable 'dont-lookup' contains a list of variables whose bindings occur INSIDE the expression ; being evaluated, and hence do NOT yet have values. ; the 'use-lifted-names' vars are those bound by a let which does have lifted names. it is used in ; rendering the lifting of a let or local to show the 'after' step, which should show the lifted names. (define/contract recon-source-expr (-> syntax? mark-list? binding-set? binding-set? render-settings? syntax?) (lambda (expr mark-list dont-lookup use-lifted-names render-settings) (if (syntax-property expr 'stepper-skipto) (skipto-reconstruct (syntax-property expr 'stepper-skipto) expr (lambda (stx) (recon-source-expr stx mark-list dont-lookup use-lifted-names render-settings))) (if (syntax-property expr 'stepper-prim-name) (syntax-property expr 'stepper-prim-name) (let* ([recur (lambda (expr) (recon-source-expr expr mark-list dont-lookup use-lifted-names render-settings))] [let-recur (lambda (expr bindings) (recon-source-expr expr mark-list (append bindings dont-lookup) use-lifted-names render-settings))] [recon-basic (lambda () (with-syntax ([(label . bodies) expr]) #`(label #,@(map recur (filter-skipped (syntax->list (syntax bodies)))))))] [recon-let/rec (lambda (rec?) (with-syntax ([(label ((vars val) ...) body) expr]) (let* ([bindings (map syntax->list (syntax->list (syntax (vars ...))))] [binding-list (apply append bindings)] [recur-fn (if rec? (lambda (expr) (let-recur expr binding-list)) recur)] [right-sides (map recur-fn (syntax->list (syntax (val ...))))] [recon-body (let-recur (syntax body) binding-list)]) (with-syntax ([(recon-val ...) right-sides] [recon-body recon-body] [(new-vars ...) (map (lx (map (lx (if (ormap (lambda (binding) (bound-identifier=? binding _)) use-lifted-names) (syntax-property _ 'stepper-lifted-name (binding-lifted-name mark-list _)) _)) _)) bindings)]) (syntax (label ((new-vars recon-val) ...) recon-body))))))] [recon-lambda-clause (lambda (clause) (with-syntax ([(args . bodies-stx) clause]) (let* ([arglist (arglist-flatten #'args)] [bodies (map (lambda (body) (let-recur body arglist)) (filter-skipped (syntax->list (syntax bodies-stx))))]) (cons (syntax args) bodies))))] [recon (kernel:kernel-syntax-case expr #f ; lambda [(lambda . clause-stx) (let* ([clause (recon-lambda-clause (syntax clause-stx))]) #`(lambda #,@clause))] ; case-lambda [(case-lambda . clauses-stx) (let* ([clauses (map recon-lambda-clause (syntax->list (syntax clauses-stx)))]) #`(case-lambda #,@clauses))] ; if, begin, begin0 [(if test then else) (recon-basic)] [(if test then) (recon-basic)] [(begin . bodies) (recon-basic)] [(begin0 . bodies) (recon-basic)] ; let-values, letrec-values [(let-values . rest) (recon-let/rec #f)] [(letrec-values . rest) (recon-let/rec #t)] ; set! [(set! var rhs) (let ([rendered-var (if (and (ormap (lambda (binding) (bound-identifier=? binding #`var)) dont-lookup) (not (ormap (lambda (binding) (bound-identifier=? binding #`var)) use-lifted-names))) #`var (reconstruct-set!-var mark-list #`var))]) #`(set! #,rendered-var #,(recur #'rhs)))] ; quote [(quote body) (recon-value (syntax-e (syntax body)) render-settings)] ; quote-syntax : like set!, the current stepper cannot handle quote-syntax ; with-continuation-mark [(with-continuation-mark . rest) (recon-basic)] ; application [(#%app . terms) (recon-basic)] ; #%datum [(#%datum . datum) #`#,(recon-value (syntax-e #'datum) render-settings)] ; varref [var-stx (identifier? expr) (let* ([var (syntax var-stx)]) (cond [(eq? (identifier-binding var) 'lexical) ; has this varref's binding not been evaluated yet? ; (and this varref isn't in the list of must-lookups?) (if (and (ormap (lambda (binding) (bound-identifier=? binding var)) dont-lookup) (not (ormap (lambda (binding) (bound-identifier=? binding var)) use-lifted-names))) var (case (syntax-property var 'stepper-binding-type) ((lambda-bound) (recon-value (lookup-binding mark-list var) render-settings)) ((macro-bound) ; for the moment, let-bound vars occur only in and/or : (recon-value (lookup-binding mark-list var) render-settings)) ((let-bound) (syntax-property var 'stepper-lifted-name (binding-lifted-name mark-list var))) ((stepper-temp) (error 'recon-source-expr "stepper-temp showed up in source?!?")) ((non-lexical) (error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical")) (else (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a" (syntax-property var 'stepper-binding-type)))))] [else ; top-level-varref (fixup-name var)]))] [(#%top . var) (syntax var)] [else (error 'recon-source "no matching clause for syntax: ~a" expr)])]) (attach-info recon expr)))))) ;; reconstruct-set!-var (define (reconstruct-set!-var mark-list var) (case (syntax-property var 'stepper-binding-type) ((lambda-bound) (error 'reconstruct-inner "lambda-bound variables can't be mutated")) ((macro-bound) ; for the moment, let-bound vars occur only in and/or : (error 'reconstruct-inner "macro-bound variables can't occur in a set!")) ((non-lexical) var) ((let-bound) (syntax-property var 'stepper-lifted-name (binding-lifted-name mark-list var))) ((stepper-temp) (error 'recon-source-expr "stepper-temp showed up in source?!?")) (else (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a" (syntax-property var 'stepper-binding-type))))) ;; filter-skipped : (listof syntax?) -> (listof syntax?) ;; filter out any elements of the list with 'stepper-skip-completely set, except those with stepper-prim-name set. (HACK). (define (filter-skipped los) (filter (lambda (stx) (or (syntax-property stx 'stepper-prim-name) (not (syntax-property stx 'stepper-skip-completely)))) los)) ;; mflatt: MAJOR HACK - work around the prefix on ;; beginner name definitions (define (fixup-name s) (let ([m (regexp-match re:beginner: (symbol->string (syntax-e s)))]) (if m (datum->syntax-object s (string->symbol (cadr m)) s s) s))) (define re:beginner: (regexp "^beginner:(.*)$")) ; ; ; ; ; ; ; ; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ;;; ; ;;; ;; ; ;;; ; ;;; ;;;; ;;; ;;; ; ;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ;;;;; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ;;;; ;;; ;;; ; ; ;;; ;; ; ;; ; ;;; ;; ;;; ;;; ; ; ; ; ;;; ; ;;;; ;; ;;;; ;;; ; ; ; ; reconstruct-completed : reconstructs a completed expression or definition. ; Accepts the source expression, a lifting-index which is either a number (indicating ; a lifted binding) or false (indicating a top-level expression), a list of values ; currently bound to the bindings, and the language level's render-settings. (define (reconstruct-completed exp lifting-indices vals-getter render-settings) (if lifting-indices (syntax-case exp () [(vars-stx rhs ...) (let* ([vars (map (lambda (var index) (syntax-property var 'stepper-lifted-name (construct-lifted-name var index))) (syntax->list #`vars-stx) lifting-indices)]) (first-of-one (unwind-no-highlight (reconstruct-completed-define exp vars (vals-getter) render-settings))))]) (let skipto-loop ([exp exp]) (cond [(syntax-property exp 'stepper-skipto) => (lambda (skipto) (skipto-reconstruct skipto exp skipto-loop))] [(syntax-property exp 'stepper-define-struct-hint) ;; the hint contains the original syntax (syntax-property exp 'stepper-define-struct-hint)] [else (first-of-one (unwind-no-highlight (kernel:kernel-syntax-case exp #f [(define-values vars-stx body) (reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)] [else (let* ([recon-vals (map (lambda (val) (recon-value val render-settings)) (vals-getter))]) (if (= (length recon-vals) 1) (attach-info (car recon-vals) exp) (attach-info #`(values #,@recon-vals) exp)))])))])))) ;; an abstraction lifted from reconstruct-completed (define (reconstruct-completed-define exp vars vals render-settings) (let* ([_ (unless (equal? (length vars) (length vals)) (error "length of var list and val list unequal: ~v ~v" (map syntax->list vars) vals))] [recon-vals (map (lambda (val var) (recon-value val render-settings var)) vals vars)]) (if (= (length recon-vals) 1) (attach-info #`(define-values #,vars #,(car recon-vals)) exp) (attach-info #'(define-values #,vars (values #,@recon-vals)) exp)))) ; : (-> syntax? syntax? syntax?) (define (reconstruct-top-level source reconstructed) (cond [(syntax-property source 'stepper-skipto) => (lambda (skipto) (skipto-reconstruct skipto source (lambda (expr) (reconstruct-top-level expr reconstructed))))] [else (kernel:kernel-syntax-case source #f [(define-values vars-stx body) (attach-info #`(define-values vars-stx #,reconstructed) source)] [else reconstructed])])) ; ; ; ; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;; ;;;; ;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ;;;; ;;; ;;; ; ; ;;; ;; ; ;; ; ;;; ;; ;;; ;; ; ; ; ;;;; ; ; ;; ;; front ends for reconstruct-current: (define (reconstruct-left-side mark-list render-settings) (reconstruct-current mark-list 'left-side null render-settings)) (define (reconstruct-right-side mark-list returned-value-list render-settings) (reconstruct-current mark-list 'right-side returned-value-list render-settings)) (define (reconstruct-double-break mark-list render-settings) (reconstruct-current mark-list 'double-break null render-settings)) ; reconstruct-current : takes a list of marks, the kind of break, and ; any values that may have been returned at the break point. It produces a list of sexps ; (the result of reconstruction) --- which may contain holes, indicated by the ; highlight-placeholder --- and a list of sexps which go in the holes (define (reconstruct-current mark-list break-kind returned-value-list render-settings) (local ( ; ;; ;;; ;;; ;;; ; ;; ; ; ;; ; ;; ;;; ; ;; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ;;; ;;; ; ; ; ; ; ; ; ;;;; ; (define (recon-inner mark-list so-far) (let* ([recon-source-current-marks (lambda (expr) (recon-source-expr expr mark-list null null render-settings))] [top-mark (car mark-list)] [exp (mark-source top-mark)] [recon-let (lambda () (with-syntax ([(label ((vars rhs) ...) . bodies) exp]) (let*-2vals ([binding-sets (map syntax->list (syntax->list #'(vars ...)))] [binding-list (apply append binding-sets)] [glumps (map (lambda (binding-set rhs) (make-let-glump (map (lambda (binding) (syntax-property binding 'stepper-lifted-name (binding-lifted-name mark-list binding))) binding-set) rhs (map (lambda (arg-binding) (lookup-binding mark-list arg-binding)) binding-set))) binding-sets (syntax->list #`(rhs ...)))] [num-defns-done (lookup-binding mark-list let-counter)] [(done-glumps not-done-glumps) (n-split-list num-defns-done glumps)] [recon-lifted (lambda (names expr) #`(#,names #,expr))] [before-bindings (map (lambda (glump) (let* ([name-set (let-glump-name-set glump)] [rhs-val-set (map (lambda (val) (if (> (length name-set) 0) (recon-value val render-settings (car name-set)) (recon-value val render-settings))) (let-glump-val-set glump))]) (if (= (length rhs-val-set) 1) #`(#,name-set #,@rhs-val-set) #`(#,name-set (values #,rhs-val-set))))) done-glumps)] [reconstruct-remaining-def (lambda (glump) (let ([rhs-source (let-glump-exp glump)] [rhs-name-set (let-glump-name-set glump)]) (recon-lifted rhs-name-set (recon-source-current-marks rhs-source))))] [after-bindings (if (pair? not-done-glumps) (if (eq? so-far nothing-so-far) (map reconstruct-remaining-def not-done-glumps) (cons (recon-lifted (let-glump-name-set (car not-done-glumps)) so-far) (map reconstruct-remaining-def (cdr not-done-glumps)))) null)] [recon-bindings (append before-bindings after-bindings)] [rectified-bodies (map (lambda (body) (recon-source-expr body mark-list binding-list binding-list render-settings)) (syntax->list (syntax bodies)))]) (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) (kernel:kernel-syntax-case exp #f ; variable references [id (identifier? (syntax id)) (if (eq? so-far nothing-so-far) (recon-source-current-marks exp) (error 'recon-inner "variable reference given as context: ~a" exp))] [(#%top . id) (if (eq? so-far nothing-so-far) (recon-source-current-marks exp) (error 'recon-inner "variable reference given as context: ~a" exp))] ; applications [(#%app . terms) (attach-info (let* ([sub-exprs (syntax->list (syntax terms))] [arg-temps (build-list (length sub-exprs) get-arg-var)] [arg-vals (map (lambda (arg-temp) (lookup-binding mark-list arg-temp)) arg-temps)]) (case (mark-label (car mark-list)) ((not-yet-called) (let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*)) (zip sub-exprs arg-vals))] [rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))]) (if (null? unevaluated) #`(#%app . #,rectified-evaluated) #`(#%app #,@rectified-evaluated #,so-far #,@(map recon-source-current-marks (cdr (map car unevaluated))))))) ((called) (if (eq? so-far nothing-so-far) (datum->syntax-object #'here `(,#'#%app ...)) ; in unannotated code (datum->syntax-object #'here `(,#'#%app ... ,so-far ...)))) (else (error "bad label in application mark in expr: ~a" exp)))) exp)] ; define-struct ; ; [(z:struct-form? expr) ; (if (comes-from-define-struct? expr) ; so-far ; (let ([super-expr (z:struct-form-super expr)] ; [raw-type (utils:read->raw (z:struct-form-type expr))] ; [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) ; (if super-expr ; `(struct (,raw-type ,so-far) ; ,raw-fields) ; `(struct ,raw-type ,raw-fields))))] ; if [(if test then else) (attach-info (let ([test-exp (if (eq? so-far nothing-so-far) (recon-value (lookup-binding mark-list if-temp) render-settings) so-far)]) #`(if #,test-exp #,(recon-source-current-marks (syntax then)) #,(recon-source-current-marks (syntax else)))) exp)] ; one-armed if [(if test then) (attach-info (let ([test-exp (if (eq? so-far nothing-so-far) (recon-value (lookup-binding mark-list if-temp) render-settings) so-far)]) #`(if #,test-exp #,(recon-source-current-marks (syntax then)))) exp)] ; quote : there is no break on a quote. ; begin : may not occur directly, but will occur in the expansion of cond, now that I'm no longer ; masking that out with stepper-skipto. Furthermore, exactly one expression can occur inside it. [(begin clause) (attach-info (if (eq? so-far nothing-so-far) #`(begin #,(recon-source-current-marks (syntax clause))) (error 'recon-inner "stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum exp))) exp)] ; begin0 : may not occur directly except in advanced ; let-values [(let-values . rest) (recon-let)] [(letrec-values . rest) (recon-let)] [(set! var rhs) (attach-info (let ([rhs-exp (if (eq? so-far nothing-so-far) (recon-value (lookup-binding mark-list set!-temp) render-settings) so-far)] [rendered-var (reconstruct-set!-var mark-list #`var)]) #`(set! #,rendered-var #,rhs-exp)) exp)] ; lambda : there is no break on a lambda [else (error 'recon-inner "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax-object->datum exp))]))) ; the main recursive reconstruction loop is in recon: ; recon : (syntax-object mark-list boolean -> syntax-object) (define (recon so-far mark-list first) (cond [(null? mark-list) ; now taken to indicate a callback: so-far ;(error `recon "expcted a top-level mark at the end of the mark list.") ] [else (case (mark-label (car mark-list)) [(top-level) (if (null? (cdr mark-list)) (reconstruct-top-level (mark-source (car mark-list)) so-far) (error 'recon "top-level-define mark found at non-end of mark list"))] [else (let ([reconstructed (recon-inner mark-list so-far)]) (recon (if first (mark-as-highlight reconstructed) reconstructed) (cdr mark-list) #f))])])) ; uncomment to see all breaks coming in: #;(define _ (printf "break-kind: ~a\ninnermost source: ~a\n" break-kind (and (pair? mark-list) (syntax-object->datum (mark-source (car mark-list)))))) (define answer (case break-kind ((left-side) (unwind (recon nothing-so-far mark-list #t) #f)) ((right-side) (let* ([innermost (if (null? returned-value-list) ; is it an expr -> expr reduction? (recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings) (recon-value (car returned-value-list) render-settings))]) (unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f))) ((double-break) (let* ([source-expr (mark-source (car mark-list))] [innermost-before (mark-as-highlight (recon-source-expr source-expr mark-list null null render-settings))] [newly-lifted-bindings (syntax-case source-expr (letrec-values) [(letrec-values ([vars . rest] ...) . bodies) (apply append (map syntax->list (syntax->list #`(vars ...))))] [(let-values ([vars . rest] ...) . bodies) (apply append (map syntax->list (syntax->list #`(vars ...))))] [else (error 'reconstruct "expected a let-values as source for a double-break, got: ~e" (syntax-object->datum source-expr))])] [innermost-after (mark-as-highlight (recon-source-expr (mark-source (car mark-list)) mark-list null newly-lifted-bindings render-settings))]) (list (unwind (recon innermost-before (cdr mark-list) #f) #f) (unwind (recon innermost-after (cdr mark-list) #f) #t)))))) ) answer)) )