retabbing only
This commit is contained in:
John Clements
parent
ba82f46a07
commit
53db721ee9
|
|
@ -3,8 +3,9 @@
|
||||||
; a varref at the top of the mark-list must either be a top-level-variable
|
; 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).
|
; or have a value in some mark somewhere (or both).
|
||||||
|
|
||||||
(module reconstruct scheme/base
|
#lang scheme/base
|
||||||
(require (prefix-in kernel: syntax/kerncase)
|
|
||||||
|
(require (prefix-in kernel: syntax/kerncase)
|
||||||
mzlib/list
|
mzlib/list
|
||||||
mzlib/etc
|
mzlib/etc
|
||||||
mzlib/contract
|
mzlib/contract
|
||||||
|
|
@ -16,7 +17,7 @@
|
||||||
(for-syntax scheme/base)
|
(for-syntax scheme/base)
|
||||||
racket/private/promise)
|
racket/private/promise)
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[reconstruct-completed (syntax?
|
[reconstruct-completed (syntax?
|
||||||
(or/c (listof natural-number/c) false/c)
|
(or/c (listof natural-number/c) false/c)
|
||||||
(-> (listof any/c))
|
(-> (listof any/c))
|
||||||
|
|
@ -46,21 +47,21 @@
|
||||||
|
|
||||||
[reset-special-values (-> any)])
|
[reset-special-values (-> any)])
|
||||||
|
|
||||||
(define nothing-so-far (gensym "nothing-so-far-"))
|
(define nothing-so-far (gensym "nothing-so-far-"))
|
||||||
|
|
||||||
; the let-glump is a structure that contains the reconstruct-time data about
|
; 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
|
; a let-binding; that is, the names on the left-hand-side, the expression on
|
||||||
; the right-hand side, and the values computed.
|
; the right-hand side, and the values computed.
|
||||||
|
|
||||||
(define-struct let-glump (name-set exp val-set))
|
(define-struct let-glump (name-set exp val-set))
|
||||||
|
|
||||||
; split-list : ('a -> boolean) (listof 'a) -> (vector (listof 'a) (listof 'a))
|
; split-list : ('a -> boolean) (listof 'a) -> (vector (listof 'a) (listof 'a))
|
||||||
; split-list splits a list into two lists at the first element s.t. (fn element) => true).
|
; 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
|
; 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
|
; list, and (fn element) => false for all elements in A, and B is either empty or
|
||||||
; (fn (car B)) => true
|
; (fn (car B)) => true
|
||||||
|
|
||||||
(define (split-list fn lst)
|
(define (split-list fn lst)
|
||||||
(let loop ([remaining lst] [so-far null])
|
(let loop ([remaining lst] [so-far null])
|
||||||
(cond [(null? remaining)
|
(cond [(null? remaining)
|
||||||
(vector (reverse so-far) null)]
|
(vector (reverse so-far) null)]
|
||||||
|
|
@ -69,15 +70,15 @@
|
||||||
(vector (reverse so-far) remaining)
|
(vector (reverse so-far) remaining)
|
||||||
(loop (cdr remaining) (cons (car remaining) so-far)))])))
|
(loop (cdr remaining) (cons (car remaining) so-far)))])))
|
||||||
|
|
||||||
; test cases
|
; test cases
|
||||||
; (test (vector '(93 4 2) '(0 2 1)) split-list (lambda (x) (= x 0)) '(93 4 2 0 2 1))
|
; (test (vector '(93 4 2) '(0 2 1)) split-list (lambda (x) (= x 0)) '(93 4 2 0 2 1))
|
||||||
; (test (vector '(3 4 5) '()) split-list (lambda (x) (= x 0)) '(3 4 5))
|
; (test (vector '(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 : 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
|
; 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.
|
; first n elements of A, and C contains the rest.
|
||||||
|
|
||||||
(define (n-split-list num lst)
|
(define (n-split-list num lst)
|
||||||
(when (> num (length lst))
|
(when (> num (length lst))
|
||||||
(error 'n-split-list "can't split list ~a after ~ath element; not long enough" lst num))
|
(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])
|
(let loop ([count num] [remaining lst] [so-far null])
|
||||||
|
|
@ -85,28 +86,28 @@
|
||||||
(vector (reverse so-far) remaining)
|
(vector (reverse so-far) remaining)
|
||||||
(loop (- count 1) (cdr remaining) (cons (car remaining) so-far)))))
|
(loop (- count 1) (cdr remaining) (cons (car remaining) so-far)))))
|
||||||
|
|
||||||
; test cases
|
; test cases
|
||||||
; (test (vector '(a b c) '(d e f)) n-split-list 3 '(a b c d e f))
|
; (test (vector '(a b c) '(d e f)) n-split-list 3 '(a b c d e f))
|
||||||
|
|
||||||
|
|
||||||
(define (mark-as-highlight stx)
|
(define (mark-as-highlight stx)
|
||||||
(stepper-syntax-property stx 'stepper-highlight #t))
|
(stepper-syntax-property stx 'stepper-highlight #t))
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
; ;; ;;; ;;; ;;; ; ;; ; ; ;;; ; ; ; ;;;
|
; ;; ;;; ;;; ;;; ; ;; ; ; ;;; ; ; ; ;;;
|
||||||
;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;
|
;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ;;;;; ; ; ; ; ; ;;;;; ; ; ;;;; ; ; ; ;;;;;
|
; ;;;;; ; ; ; ; ; ;;;;; ; ; ;;;; ; ; ; ;;;;;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ;; ; ; ; ; ;; ;
|
; ; ; ; ; ; ; ;; ; ; ; ; ;; ;
|
||||||
; ;;;; ;;; ;;; ; ; ; ;;;;; ; ;; ; ;;;;
|
; ;;;; ;;; ;;; ; ; ; ;;;;; ; ;; ; ;;;;
|
||||||
|
|
||||||
|
|
||||||
; recon-value print-converts a value. If the value is a closure, recon-value
|
; 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
|
; prints the name attached to the procedure, unless we're on the right-hand-side
|
||||||
; of a let, or unless there _is_ no name.
|
; of a let, or unless there _is_ no name.
|
||||||
|
|
||||||
(define recon-value
|
(define recon-value
|
||||||
(opt-lambda (val render-settings [assigned-name #f]
|
(opt-lambda (val render-settings [assigned-name #f]
|
||||||
[current-so-far nothing-so-far] [seen-promises null])
|
[current-so-far nothing-so-far] [seen-promises null])
|
||||||
(if (hash-ref finished-xml-box-table val (lambda () #f))
|
(if (hash-ref finished-xml-box-table val (lambda () #f))
|
||||||
|
|
@ -200,26 +201,26 @@
|
||||||
#`(quote #,rendered)))])))))
|
#`(quote #,rendered)))])))))
|
||||||
|
|
||||||
; STC: helper fns for recon-value, to reconstruct promises
|
; STC: helper fns for recon-value, to reconstruct promises
|
||||||
; extract-proc-if-struct : any -> procedure? or any
|
; extract-proc-if-struct : any -> procedure? or any
|
||||||
; Purpose: extracts closure from struct procedure, ie lazy-proc in lazy racket
|
; Purpose: extracts closure from struct procedure, ie lazy-proc in lazy racket
|
||||||
(define (extract-proc-if-struct f)
|
(define (extract-proc-if-struct f)
|
||||||
(if (and (procedure? f) (not (annotated-proc? f)))
|
(if (and (procedure? f) (not (annotated-proc? f)))
|
||||||
(or (procedure-extract-target f)
|
(or (procedure-extract-target f)
|
||||||
f)
|
f)
|
||||||
f))
|
f))
|
||||||
; extract-proc-if-promise : any -> thunk or any
|
; extract-proc-if-promise : any -> thunk or any
|
||||||
(define (extract-proc-if-promise p)
|
(define (extract-proc-if-promise p)
|
||||||
(if (promise? p)
|
(if (promise? p)
|
||||||
(extract-proc-if-promise (pref p))
|
(extract-proc-if-promise (pref p))
|
||||||
p))
|
p))
|
||||||
; unwraps struct or promise around procedure
|
; unwraps struct or promise around procedure
|
||||||
(define (unwrap-proc f)
|
(define (unwrap-proc f)
|
||||||
(extract-proc-if-promise (extract-proc-if-struct f)))
|
(extract-proc-if-promise (extract-proc-if-struct f)))
|
||||||
|
|
||||||
; nested-promise-running? : Indicates whether a promise is in the "running"
|
; nested-promise-running? : Indicates whether a promise is in the "running"
|
||||||
; state. promise-running? in racket/private/promise.rkt only looks down
|
; state. promise-running? in racket/private/promise.rkt only looks down
|
||||||
; one level for a running promise
|
; one level for a running promise
|
||||||
(define (nested-promise-running? p)
|
(define (nested-promise-running? p)
|
||||||
(if (promise? p)
|
(if (promise? p)
|
||||||
(let ([v (pref p)])
|
(let ([v (pref p)])
|
||||||
(or (running? v)
|
(or (running? v)
|
||||||
|
|
@ -227,48 +228,48 @@
|
||||||
(nested-promise-running? v))))
|
(nested-promise-running? v))))
|
||||||
(raise-type-error 'nested-promise-running? "promise" p)))
|
(raise-type-error 'nested-promise-running? "promise" p)))
|
||||||
|
|
||||||
; weak hash table to keep track of partially evaluated promises
|
; weak hash table to keep track of partially evaluated promises
|
||||||
; where keys = promises, values = syntax
|
; where keys = promises, values = syntax
|
||||||
; - initialized on each call to reconstruct-current
|
; - initialized on each call to reconstruct-current
|
||||||
; (ie - each half-step reconstruction)
|
; (ie - each half-step reconstruction)
|
||||||
; - populated on each call to recon-inner
|
; - populated on each call to recon-inner
|
||||||
(define partially-evaluated-promises-table null)
|
(define partially-evaluated-promises-table null)
|
||||||
|
|
||||||
; unknown-promises-table : keep track of unknown promises
|
; unknown-promises-table : keep track of unknown promises
|
||||||
; ie, promises created from lib fns
|
; ie, promises created from lib fns
|
||||||
(define unknown-promises-table null)
|
(define unknown-promises-table null)
|
||||||
(define next-unknown-promise 0)
|
(define next-unknown-promise 0)
|
||||||
|
|
||||||
;; NaturalNumber -> syntax
|
;; NaturalNumber -> syntax
|
||||||
(define (render-unknown-promise x)
|
(define (render-unknown-promise x)
|
||||||
#`(quote #,(string->symbol
|
#`(quote #,(string->symbol
|
||||||
(string-append "<DelayedEvaluation#" (number->string x) ">"))))
|
(string-append "<DelayedEvaluation#" (number->string x) ">"))))
|
||||||
|
|
||||||
; This is used when we need the exp associated with a running promise, but the promise is at top-level,
|
; This is used when we need the exp associated with a running promise, but the promise is at top-level,
|
||||||
; so it never gets added to partially-evaluated-promises-table
|
; so it never gets added to partially-evaluated-promises-table
|
||||||
; This is a huge hack and I dont know if it the assumptions I'm making always hold
|
; This is a huge hack and I dont know if it the assumptions I'm making always hold
|
||||||
; (ie - that the exp associated with any running promise not in partially-evaluated-promises-table is the last so-far),
|
; (ie - that the exp associated with any running promise not in partially-evaluated-promises-table is the last so-far),
|
||||||
; but it's working for all test cases so far 10/29/2010.
|
; but it's working for all test cases so far 10/29/2010.
|
||||||
; Another solution is to wrap all lazy programs in a dummy top-level expression???
|
; Another solution is to wrap all lazy programs in a dummy top-level expression???
|
||||||
; Update 11/1/2010: needed to add the following guards in the code to make the assumptions hold
|
; Update 11/1/2010: needed to add the following guards in the code to make the assumptions hold
|
||||||
; (guards are mainly triggered when there are infinite lists)
|
; (guards are mainly triggered when there are infinite lists)
|
||||||
; - in recon-inner, dont add running promise to partially-evaluated-promises-table if so-far = nothing-so-far
|
; - in recon-inner, dont add running promise to partially-evaluated-promises-table if so-far = nothing-so-far
|
||||||
; - in recon, dont set last-so-far when so-far = nothing-so-far
|
; - in recon, dont set last-so-far when so-far = nothing-so-far
|
||||||
; - in recon-value, dont use last-so-far if it hasnt been set (ie - if it's still null)
|
; - in recon-value, dont use last-so-far if it hasnt been set (ie - if it's still null)
|
||||||
(define last-so-far null)
|
(define last-so-far null)
|
||||||
; ; ;;;
|
; ; ;;;
|
||||||
; ; ;
|
; ; ;
|
||||||
;;; ; ; ; ; ;;; ; ; ; ; ; ; ;;; ;;;; ;;; ; ;;; ;
|
;;; ; ; ; ; ;;; ; ; ; ; ; ; ;;; ;;;; ;;; ; ;;; ;
|
||||||
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
|
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
|
||||||
; ; ; ; ; ; ;; ;; ;; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ;; ;; ;; ; ; ; ; ; ; ;
|
||||||
;; ;; ; ; ; ;;;;; ;; ;; ;; ;;;;; ;; ; ;;;;; ; ; ;
|
;; ;; ; ; ; ;;;;; ;; ;; ;; ;;;;; ;; ; ;;;;; ; ; ;
|
||||||
; ; ; ; ; ; ;; ;; ;; ; ; ; ; ; ;
|
; ; ; ; ; ; ;; ;; ;; ; ; ; ; ; ;
|
||||||
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ;
|
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ;
|
||||||
;;; ; ; ; ; ;;; ; ; ; ; ; ; ;;; ;; ;;;; ; ;;; ;
|
;;; ; ; ; ; ;;; ; ; ; ; ; ; ;;; ;; ;;;; ; ;;; ;
|
||||||
; ;
|
; ;
|
||||||
; ;
|
; ;
|
||||||
|
|
||||||
(define (skip-step? break-kind mark-list render-settings)
|
(define (skip-step? break-kind mark-list render-settings)
|
||||||
(case break-kind
|
(case break-kind
|
||||||
[(result-value-break)
|
[(result-value-break)
|
||||||
(and (pair? mark-list)
|
(and (pair? mark-list)
|
||||||
|
|
@ -289,8 +290,8 @@
|
||||||
(not (render-settings-lifting? render-settings)))]
|
(not (render-settings-lifting? render-settings)))]
|
||||||
[(expr-finished-break define-struct-break late-let-break) #f]))
|
[(expr-finished-break define-struct-break late-let-break) #f]))
|
||||||
|
|
||||||
;; skip-redex-step : mark-list? render-settings? -> boolean?
|
;; skip-redex-step : mark-list? render-settings? -> boolean?
|
||||||
(define (skip-redex-step? mark-list render-settings)
|
(define (skip-redex-step? mark-list render-settings)
|
||||||
|
|
||||||
(define (varref-skip-step? varref)
|
(define (varref-skip-step? varref)
|
||||||
(with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
|
(with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
|
||||||
|
|
@ -341,10 +342,10 @@
|
||||||
(struct-constructor-procedure? fun-val))))]
|
(struct-constructor-procedure? fun-val))))]
|
||||||
[else #f])))))
|
[else #f])))))
|
||||||
|
|
||||||
;; find-special-value finds the value associated with the given name. Applications of functions
|
;; find-special-value finds the value associated with the given name. Applications of functions
|
||||||
;; like 'list' should not be shown as steps, because the before and after steps will be the same.
|
;; like 'list' should not be shown as steps, because the before and after steps will be the same.
|
||||||
;; it might be easier simply to discover and discard these at display time.
|
;; it might be easier simply to discover and discard these at display time.
|
||||||
(define (find-special-value name valid-args)
|
(define (find-special-value name valid-args)
|
||||||
(let* ([expanded-application (expand (cons name valid-args))]
|
(let* ([expanded-application (expand (cons name valid-args))]
|
||||||
[stepper-safe-expanded (skipto/auto expanded-application 'discard (lambda (x) x))]
|
[stepper-safe-expanded (skipto/auto expanded-application 'discard (lambda (x) x))]
|
||||||
[just-the-fn
|
[just-the-fn
|
||||||
|
|
@ -362,18 +363,18 @@
|
||||||
[else (error 'find-special-name "couldn't find expanded name for ~a" name)])])
|
[else (error 'find-special-name "couldn't find expanded name for ~a" name)])])
|
||||||
(eval just-the-fn)))
|
(eval just-the-fn)))
|
||||||
|
|
||||||
;; these are delayed so that they use the userspace expander. I'm sure
|
;; these are delayed so that they use the userspace expander. I'm sure
|
||||||
;; there's a more robust & elegant way to do this.
|
;; there's a more robust & elegant way to do this.
|
||||||
(define special-list-value #f)
|
(define special-list-value #f)
|
||||||
(define special-cons-value #f)
|
(define special-cons-value #f)
|
||||||
|
|
||||||
(define (reset-special-values)
|
(define (reset-special-values)
|
||||||
(set! special-list-value (find-special-value 'list '(3)))
|
(set! special-list-value (find-special-value 'list '(3)))
|
||||||
(set! special-cons-value (find-special-value 'cons '(3 empty)))
|
(set! special-cons-value (find-special-value 'cons '(3 empty)))
|
||||||
(set! unknown-promises-table (make-weak-hash))
|
(set! unknown-promises-table (make-weak-hash))
|
||||||
(set! next-unknown-promise 0))
|
(set! next-unknown-promise 0))
|
||||||
|
|
||||||
(define (second-arg-is-list? mark-list)
|
(define (second-arg-is-list? mark-list)
|
||||||
(let ([arg-val (lookup-binding mark-list (get-arg-var 2))])
|
(let ([arg-val (lookup-binding mark-list (get-arg-var 2))])
|
||||||
(list? arg-val)))
|
(list? arg-val)))
|
||||||
|
|
||||||
|
|
@ -392,25 +393,25 @@
|
||||||
; (hash-table-put! binding-number-table binding new-index)
|
; (hash-table-put! binding-number-table binding new-index)
|
||||||
; new-index)]))))
|
; new-index)]))))
|
||||||
|
|
||||||
; construct-lifted-name
|
; construct-lifted-name
|
||||||
; (-> syntax? (or/c num? false/c) symbol?)
|
; (-> syntax? (or/c num? false/c) symbol?)
|
||||||
|
|
||||||
(define/contract construct-lifted-name
|
(define/contract construct-lifted-name
|
||||||
(-> syntax? number? syntax?)
|
(-> syntax? number? syntax?)
|
||||||
(lambda (binding dynamic-index)
|
(lambda (binding dynamic-index)
|
||||||
#`#,(string->symbol
|
#`#,(string->symbol
|
||||||
(string-append (symbol->string (syntax-e binding)) "_"
|
(string-append (symbol->string (syntax-e binding)) "_"
|
||||||
(number->string dynamic-index)))))
|
(number->string dynamic-index)))))
|
||||||
|
|
||||||
; binding-lifted-name
|
; binding-lifted-name
|
||||||
|
|
||||||
(define/contract binding-lifted-name
|
(define/contract binding-lifted-name
|
||||||
(-> mark-list? syntax? syntax?)
|
(-> mark-list? syntax? syntax?)
|
||||||
(lambda (mark-list binding)
|
(lambda (mark-list binding)
|
||||||
(construct-lifted-name binding (lookup-binding mark-list (get-lifted-var binding)))))
|
(construct-lifted-name binding (lookup-binding mark-list (get-lifted-var binding)))))
|
||||||
|
|
||||||
|
|
||||||
(define (step-was-app? mark-list)
|
(define (step-was-app? mark-list)
|
||||||
(and (not (null? mark-list))
|
(and (not (null? mark-list))
|
||||||
(syntax-case (mark-source (car mark-list)) (#%plain-app)
|
(syntax-case (mark-source (car mark-list)) (#%plain-app)
|
||||||
[(#%plain-app . rest)
|
[(#%plain-app . rest)
|
||||||
|
|
@ -422,30 +423,30 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
; ;; ;;; ;;; ;;; ; ;; ;;; ;;; ; ; ; ;; ;;; ;;; ;;; ; ; ; ;;; ; ;;
|
; ;; ;;; ;;; ;;; ; ;; ;;; ;;; ; ; ; ;; ;;; ;;; ;;; ; ; ; ;;; ; ;;
|
||||||
;; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;;
|
;; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
||||||
; ;;;;; ; ; ; ; ; ;;;;; ;; ; ; ; ; ; ; ;;;;; ;;;;; ;;;;; ;; ; ; ;
|
; ;;;;; ; ; ; ; ; ;;;;; ;; ; ; ; ; ; ; ;;;;; ;;;;; ;;;;; ;; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ;
|
||||||
; ;;;; ;;; ;;; ; ; ;;; ;;; ;; ; ; ;;; ;;;; ;;;; ; ; ; ;;; ;
|
; ;;;; ;;; ;;; ; ; ;;; ;;; ;; ; ; ;;; ;;;; ;;;; ; ; ; ;;; ;
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
||||||
|
|
||||||
; recon-source-expr
|
; recon-source-expr
|
||||||
|
|
||||||
; recon-source-expr produces the reconstructed version of a given source epxression, using the binding
|
; 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
|
; information contained in the binding-list. This happens during reconstruction whenever we come upon
|
||||||
; expressions that we haven't yet evaluated.
|
; expressions that we haven't yet evaluated.
|
||||||
|
|
||||||
; NB: the variable 'dont-lookup' contains a list of variables whose bindings occur INSIDE the expression
|
; 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.
|
; 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
|
; 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.
|
; rendering the lifting of a let or local to show the 'after' step, which should show the lifted names.
|
||||||
|
|
||||||
(define/contract recon-source-expr
|
(define/contract recon-source-expr
|
||||||
(-> syntax? mark-list? binding-set? binding-set? render-settings? syntax?)
|
(-> syntax? mark-list? binding-set? binding-set? render-settings? syntax?)
|
||||||
(lambda (expr mark-list dont-lookup use-lifted-names render-settings)
|
(lambda (expr mark-list dont-lookup use-lifted-names render-settings)
|
||||||
(skipto/auto
|
(skipto/auto
|
||||||
|
|
@ -493,7 +494,8 @@
|
||||||
[bodies (map (lambda (body) (let-recur body arglist))
|
[bodies (map (lambda (body) (let-recur body arglist))
|
||||||
(filter-skipped (syntax->list (syntax bodies-stx))))])
|
(filter-skipped (syntax->list (syntax bodies-stx))))])
|
||||||
(cons (syntax args) bodies))))]
|
(cons (syntax args) bodies))))]
|
||||||
[recon (kernel:kernel-syntax-case expr #f
|
[recon (kernel:kernel-syntax-case
|
||||||
|
expr #f
|
||||||
|
|
||||||
; lambda
|
; lambda
|
||||||
[(#%plain-lambda . clause-stx)
|
[(#%plain-lambda . clause-stx)
|
||||||
|
|
@ -594,9 +596,9 @@
|
||||||
expr))])])
|
expr))])])
|
||||||
(attach-info recon expr)))))))
|
(attach-info recon expr)))))))
|
||||||
|
|
||||||
;; reconstruct-set!-var
|
;; reconstruct-set!-var
|
||||||
|
|
||||||
(define (reconstruct-set!-var mark-list var)
|
(define (reconstruct-set!-var mark-list var)
|
||||||
(case (stepper-syntax-property var 'stepper-binding-type)
|
(case (stepper-syntax-property var 'stepper-binding-type)
|
||||||
((lambda-bound)
|
((lambda-bound)
|
||||||
(error 'reconstruct-inner "lambda-bound variables can't be mutated"))
|
(error 'reconstruct-inner "lambda-bound variables can't be mutated"))
|
||||||
|
|
@ -614,56 +616,56 @@
|
||||||
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a"
|
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a"
|
||||||
(stepper-syntax-property var 'stepper-binding-type)))))
|
(stepper-syntax-property var 'stepper-binding-type)))))
|
||||||
|
|
||||||
;; filter-skipped : (listof syntax?) -> (listof syntax?)
|
;; 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).
|
;; filter out any elements of the list with 'stepper-skip-completely set, except those with stepper-prim-name set. (HACK).
|
||||||
(define (filter-skipped los)
|
(define (filter-skipped los)
|
||||||
(filter (lambda (stx)
|
(filter (lambda (stx)
|
||||||
(or (stepper-syntax-property stx 'stepper-prim-name)
|
(or (stepper-syntax-property stx 'stepper-prim-name)
|
||||||
(not (stepper-syntax-property stx 'stepper-skip-completely))))
|
(not (stepper-syntax-property stx 'stepper-skip-completely))))
|
||||||
los))
|
los))
|
||||||
|
|
||||||
|
|
||||||
;; mflatt: MAJOR HACK - work around the prefix on
|
;; mflatt: MAJOR HACK - work around the prefix on
|
||||||
;; beginner name definitions
|
;; beginner name definitions
|
||||||
(define (fixup-name s)
|
(define (fixup-name s)
|
||||||
(let ([m (regexp-match re:beginner: (symbol->string (syntax-e s)))])
|
(let ([m (regexp-match re:beginner: (symbol->string (syntax-e s)))])
|
||||||
(if m
|
(if m
|
||||||
(datum->syntax s (string->symbol (cadr m)) s s)
|
(datum->syntax s (string->symbol (cadr m)) s s)
|
||||||
s)))
|
s)))
|
||||||
(define re:beginner: (regexp "^beginner:(.*)$"))
|
(define re:beginner: (regexp "^beginner:(.*)$"))
|
||||||
|
|
||||||
|
|
||||||
;; eval-quoted : take a syntax that is an application of quote, and evaluate it (for display)
|
;; eval-quoted : take a syntax that is an application of quote, and evaluate it (for display)
|
||||||
;; Frankly, I'm worried by the fact that this isn't done at expansion time.
|
;; Frankly, I'm worried by the fact that this isn't done at expansion time.
|
||||||
|
|
||||||
(define (eval-quoted stx)
|
(define (eval-quoted stx)
|
||||||
(syntax-case stx (quote)
|
(syntax-case stx (quote)
|
||||||
[(quote . dont-care) (eval stx)]
|
[(quote . dont-care) (eval stx)]
|
||||||
[else (error 'eval-quoted "eval-quoted called with syntax that is not a quote: ~v" stx)]))
|
[else (error 'eval-quoted "eval-quoted called with syntax that is not a quote: ~v" stx)]))
|
||||||
|
|
||||||
|
|
||||||
; ;
|
; ;
|
||||||
; ; ; ; ;
|
; ; ; ; ;
|
||||||
; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ;;; ; ;;; ;; ; ;;; ; ;;; ;;;; ;;; ;;; ;
|
; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ;;; ; ;;; ;; ; ;;; ; ;;; ;;;; ;;; ;;; ;
|
||||||
;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ; ; ; ; ; ; ;;
|
;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ; ; ; ; ; ; ;;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ;;;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ;;;;; ; ;;;;; ; ;
|
; ;;;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ;;;;; ; ;;;;; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;;
|
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;;
|
||||||
; ;;;; ;;; ;;; ; ; ;;; ;; ; ;; ; ;;; ;; ;;; ;;; ; ; ; ; ;;; ; ;;;; ;; ;;;; ;;; ;
|
; ;;;; ;;; ;;; ; ; ;;; ;; ; ;; ; ;;; ;; ;;; ;;; ; ; ; ; ;;; ; ;;;; ;; ;;;; ;;; ;
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
||||||
|
|
||||||
; reconstruct-completed : reconstructs a completed expression or definition.
|
; reconstruct-completed : reconstructs a completed expression or definition.
|
||||||
; Accepts the source expression, a lifting-index which is either a number (indicating
|
; 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
|
; 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.
|
; currently bound to the bindings, and the language level's render-settings.
|
||||||
;; returns a vector containing a reconstructed expression and a boolean indicating
|
;; returns a vector containing a reconstructed expression and a boolean indicating
|
||||||
;; whether this should not be unwound (e.g., is source syntax
|
;; whether this should not be unwound (e.g., is source syntax
|
||||||
;; from a define-struct).
|
;; from a define-struct).
|
||||||
|
|
||||||
(define (reconstruct-completed exp lifting-indices vals-getter render-settings)
|
(define (reconstruct-completed exp lifting-indices vals-getter render-settings)
|
||||||
(if lifting-indices
|
(if lifting-indices
|
||||||
(syntax-case exp ()
|
(syntax-case exp ()
|
||||||
[(vars-stx rhs ...)
|
[(vars-stx rhs ...)
|
||||||
|
|
@ -693,8 +695,8 @@
|
||||||
(attach-info #`(values #,@recon-vals) exp)))])
|
(attach-info #`(values #,@recon-vals) exp)))])
|
||||||
#f)]))))
|
#f)]))))
|
||||||
|
|
||||||
;; an abstraction lifted from reconstruct-completed
|
;; an abstraction lifted from reconstruct-completed
|
||||||
(define (reconstruct-completed-define exp vars vals render-settings)
|
(define (reconstruct-completed-define exp vars vals render-settings)
|
||||||
(let* ([_ (unless (equal? (length vars) (length vals))
|
(let* ([_ (unless (equal? (length vars) (length vals))
|
||||||
(error "length of var list and val list unequal: ~v ~v" (map syntax->list vars) vals))]
|
(error "length of var list and val list unequal: ~v ~v" (map syntax->list vars) vals))]
|
||||||
[recon-vals (map (lambda (val var)
|
[recon-vals (map (lambda (val var)
|
||||||
|
|
@ -707,13 +709,14 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
; : (-> syntax? syntax? syntax?)
|
; : (-> syntax? syntax? syntax?)
|
||||||
(define (reconstruct-top-level source reconstructed)
|
(define (reconstruct-top-level source reconstructed)
|
||||||
(skipto/auto
|
(skipto/auto
|
||||||
source
|
source
|
||||||
'discard
|
'discard
|
||||||
(lambda (source)
|
(lambda (source)
|
||||||
(kernel:kernel-syntax-case source #f
|
(kernel:kernel-syntax-case
|
||||||
|
source #f
|
||||||
[(define-values vars-stx body)
|
[(define-values vars-stx body)
|
||||||
(attach-info #`(define-values vars-stx #,reconstructed)
|
(attach-info #`(define-values vars-stx #,reconstructed)
|
||||||
source)]
|
source)]
|
||||||
|
|
@ -721,44 +724,44 @@
|
||||||
reconstructed]))))
|
reconstructed]))))
|
||||||
|
|
||||||
|
|
||||||
;; hide-completed? : syntax? -> boolean?
|
;; hide-completed? : syntax? -> boolean?
|
||||||
(define (hide-completed? stx)
|
(define (hide-completed? stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(define-values (v) rhs)
|
[(define-values (v) rhs)
|
||||||
(stepper-syntax-property #'v 'stepper-hide-completed)]
|
(stepper-syntax-property #'v 'stepper-hide-completed)]
|
||||||
[else #f]))
|
[else #f]))
|
||||||
|
|
||||||
|
|
||||||
; ; ;
|
; ; ;
|
||||||
; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;; ;;;;
|
; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;; ;;;;
|
||||||
;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; ; ;; ; ;
|
;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; ; ;; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ;;;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ;
|
; ;;;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;
|
||||||
; ;;;; ;;; ;;; ; ; ;;; ;; ; ;; ; ;;; ;; ;;; ;; ; ; ; ;;;; ; ; ;;
|
; ;;;; ;;; ;;; ; ; ;;; ;; ; ;; ; ;;; ;; ;;; ;; ; ; ; ;;;; ; ; ;;
|
||||||
|
|
||||||
|
|
||||||
;; front ends for reconstruct-current:
|
;; front ends for reconstruct-current:
|
||||||
|
|
||||||
(define (reconstruct-left-side mark-list returned-value-list render-settings)
|
(define (reconstruct-left-side mark-list returned-value-list render-settings)
|
||||||
(reconstruct-current mark-list 'left-side returned-value-list render-settings))
|
(reconstruct-current mark-list 'left-side returned-value-list render-settings))
|
||||||
|
|
||||||
|
|
||||||
(define (reconstruct-right-side mark-list returned-value-list render-settings)
|
(define (reconstruct-right-side mark-list returned-value-list render-settings)
|
||||||
(reconstruct-current mark-list 'right-side returned-value-list render-settings))
|
(reconstruct-current mark-list 'right-side returned-value-list render-settings))
|
||||||
|
|
||||||
|
|
||||||
(define (reconstruct-double-break mark-list render-settings)
|
(define (reconstruct-double-break mark-list render-settings)
|
||||||
(reconstruct-current mark-list 'double-break null render-settings))
|
(reconstruct-current mark-list 'double-break null render-settings))
|
||||||
|
|
||||||
|
|
||||||
; reconstruct-current : takes a list of marks, the kind of break, and
|
; 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
|
; 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
|
; (the result of reconstruction) --- which may contain holes, indicated by the
|
||||||
; highlight-placeholder --- and a list of sexps which go in the holes
|
; highlight-placeholder --- and a list of sexps which go in the holes
|
||||||
|
|
||||||
(define (reconstruct-current mark-list break-kind returned-value-list render-settings)
|
(define (reconstruct-current mark-list break-kind returned-value-list render-settings)
|
||||||
(local
|
(local
|
||||||
(
|
(
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user