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
|
||||
; or have a value in some mark somewhere (or both).
|
||||
|
||||
(module reconstruct scheme/base
|
||||
(require (prefix-in kernel: syntax/kerncase)
|
||||
#lang scheme/base
|
||||
|
||||
(require (prefix-in kernel: syntax/kerncase)
|
||||
mzlib/list
|
||||
mzlib/etc
|
||||
mzlib/contract
|
||||
|
|
@ -16,7 +17,7 @@
|
|||
(for-syntax scheme/base)
|
||||
racket/private/promise)
|
||||
|
||||
(provide/contract
|
||||
(provide/contract
|
||||
[reconstruct-completed (syntax?
|
||||
(or/c (listof natural-number/c) false/c)
|
||||
(-> (listof any/c))
|
||||
|
|
@ -46,21 +47,21 @@
|
|||
|
||||
[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
|
||||
; a let-binding; that is, the names on the left-hand-side, the expression on
|
||||
; the right-hand side, and the values computed.
|
||||
; 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))
|
||||
(define-struct let-glump (name-set exp val-set))
|
||||
|
||||
; 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).
|
||||
; 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
|
||||
; 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).
|
||||
; 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)
|
||||
(define (split-list fn lst)
|
||||
(let loop ([remaining lst] [so-far null])
|
||||
(cond [(null? remaining)
|
||||
(vector (reverse so-far) null)]
|
||||
|
|
@ -69,15 +70,15 @@
|
|||
(vector (reverse so-far) remaining)
|
||||
(loop (cdr remaining) (cons (car remaining) so-far)))])))
|
||||
|
||||
; test cases
|
||||
; (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 cases
|
||||
; (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))
|
||||
|
||||
; 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.
|
||||
; 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)
|
||||
(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])
|
||||
|
|
@ -85,28 +86,28 @@
|
|||
(vector (reverse so-far) remaining)
|
||||
(loop (- count 1) (cdr remaining) (cons (car remaining) so-far)))))
|
||||
|
||||
; test cases
|
||||
; (test (vector '(a b c) '(d e f)) n-split-list 3 '(a b c d e f))
|
||||
; test cases
|
||||
; (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))
|
||||
;
|
||||
;
|
||||
; ;; ;;; ;;; ;;; ; ;; ; ; ;;; ; ; ; ;;;
|
||||
;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;;;; ; ; ; ; ; ;;;;; ; ; ;;;; ; ; ; ;;;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;; ; ; ; ; ;; ;
|
||||
; ;;;; ;;; ;;; ; ; ; ;;;;; ; ;; ; ;;;;
|
||||
;
|
||||
;
|
||||
; ;; ;;; ;;; ;;; ; ;; ; ; ;;; ; ; ; ;;;
|
||||
;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;;;; ; ; ; ; ; ;;;;; ; ; ;;;; ; ; ; ;;;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;; ; ; ; ; ;; ;
|
||||
; ;;;; ;;; ;;; ; ; ; ;;;;; ; ;; ; ;;;;
|
||||
|
||||
|
||||
; 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.
|
||||
; 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
|
||||
(define recon-value
|
||||
(opt-lambda (val render-settings [assigned-name #f]
|
||||
[current-so-far nothing-so-far] [seen-promises null])
|
||||
(if (hash-ref finished-xml-box-table val (lambda () #f))
|
||||
|
|
@ -200,26 +201,26 @@
|
|||
#`(quote #,rendered)))])))))
|
||||
|
||||
; STC: helper fns for recon-value, to reconstruct promises
|
||||
; extract-proc-if-struct : any -> procedure? or any
|
||||
; Purpose: extracts closure from struct procedure, ie lazy-proc in lazy racket
|
||||
(define (extract-proc-if-struct f)
|
||||
; extract-proc-if-struct : any -> procedure? or any
|
||||
; Purpose: extracts closure from struct procedure, ie lazy-proc in lazy racket
|
||||
(define (extract-proc-if-struct f)
|
||||
(if (and (procedure? f) (not (annotated-proc? f)))
|
||||
(or (procedure-extract-target f)
|
||||
f)
|
||||
f))
|
||||
; extract-proc-if-promise : any -> thunk or any
|
||||
(define (extract-proc-if-promise p)
|
||||
; extract-proc-if-promise : any -> thunk or any
|
||||
(define (extract-proc-if-promise p)
|
||||
(if (promise? p)
|
||||
(extract-proc-if-promise (pref p))
|
||||
p))
|
||||
; unwraps struct or promise around procedure
|
||||
(define (unwrap-proc f)
|
||||
; unwraps struct or promise around procedure
|
||||
(define (unwrap-proc f)
|
||||
(extract-proc-if-promise (extract-proc-if-struct f)))
|
||||
|
||||
; nested-promise-running? : Indicates whether a promise is in the "running"
|
||||
; state. promise-running? in racket/private/promise.rkt only looks down
|
||||
; one level for a running promise
|
||||
(define (nested-promise-running? p)
|
||||
; nested-promise-running? : Indicates whether a promise is in the "running"
|
||||
; state. promise-running? in racket/private/promise.rkt only looks down
|
||||
; one level for a running promise
|
||||
(define (nested-promise-running? p)
|
||||
(if (promise? p)
|
||||
(let ([v (pref p)])
|
||||
(or (running? v)
|
||||
|
|
@ -227,48 +228,48 @@
|
|||
(nested-promise-running? v))))
|
||||
(raise-type-error 'nested-promise-running? "promise" p)))
|
||||
|
||||
; weak hash table to keep track of partially evaluated promises
|
||||
; where keys = promises, values = syntax
|
||||
; - initialized on each call to reconstruct-current
|
||||
; (ie - each half-step reconstruction)
|
||||
; - populated on each call to recon-inner
|
||||
(define partially-evaluated-promises-table null)
|
||||
; weak hash table to keep track of partially evaluated promises
|
||||
; where keys = promises, values = syntax
|
||||
; - initialized on each call to reconstruct-current
|
||||
; (ie - each half-step reconstruction)
|
||||
; - populated on each call to recon-inner
|
||||
(define partially-evaluated-promises-table null)
|
||||
|
||||
; unknown-promises-table : keep track of unknown promises
|
||||
; ie, promises created from lib fns
|
||||
(define unknown-promises-table null)
|
||||
(define next-unknown-promise 0)
|
||||
; unknown-promises-table : keep track of unknown promises
|
||||
; ie, promises created from lib fns
|
||||
(define unknown-promises-table null)
|
||||
(define next-unknown-promise 0)
|
||||
|
||||
;; NaturalNumber -> syntax
|
||||
(define (render-unknown-promise x)
|
||||
;; NaturalNumber -> syntax
|
||||
(define (render-unknown-promise x)
|
||||
#`(quote #,(string->symbol
|
||||
(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,
|
||||
; 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
|
||||
; (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.
|
||||
; 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
|
||||
; (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, 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)
|
||||
(define last-so-far null)
|
||||
; ; ;;;
|
||||
; ; ;
|
||||
;;; ; ; ; ; ;;; ; ; ; ; ; ; ;;; ;;;; ;;; ; ;;; ;
|
||||
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
|
||||
; ; ; ; ; ; ;; ;; ;; ; ; ; ; ; ; ;
|
||||
;; ;; ; ; ; ;;;;; ;; ;; ;; ;;;;; ;; ; ;;;;; ; ; ;
|
||||
; ; ; ; ; ; ;; ;; ;; ; ; ; ; ; ;
|
||||
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ;
|
||||
;;; ; ; ; ; ;;; ; ; ; ; ; ; ;;; ;; ;;;; ; ;;; ;
|
||||
; ;
|
||||
; ;
|
||||
; 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
|
||||
; 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),
|
||||
; 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???
|
||||
; 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)
|
||||
; - 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-value, dont use last-so-far if it hasnt been set (ie - if it's still 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
|
||||
[(result-value-break)
|
||||
(and (pair? mark-list)
|
||||
|
|
@ -289,8 +290,8 @@
|
|||
(not (render-settings-lifting? render-settings)))]
|
||||
[(expr-finished-break define-struct-break late-let-break) #f]))
|
||||
|
||||
;; skip-redex-step : mark-list? render-settings? -> boolean?
|
||||
(define (skip-redex-step? mark-list render-settings)
|
||||
;; skip-redex-step : mark-list? render-settings? -> boolean?
|
||||
(define (skip-redex-step? mark-list render-settings)
|
||||
|
||||
(define (varref-skip-step? varref)
|
||||
(with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
|
||||
|
|
@ -341,10 +342,10 @@
|
|||
(struct-constructor-procedure? fun-val))))]
|
||||
[else #f])))))
|
||||
|
||||
;; 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.
|
||||
;; it might be easier simply to discover and discard these at display time.
|
||||
(define (find-special-value name valid-args)
|
||||
;; 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.
|
||||
;; it might be easier simply to discover and discard these at display time.
|
||||
(define (find-special-value name valid-args)
|
||||
(let* ([expanded-application (expand (cons name valid-args))]
|
||||
[stepper-safe-expanded (skipto/auto expanded-application 'discard (lambda (x) x))]
|
||||
[just-the-fn
|
||||
|
|
@ -362,18 +363,18 @@
|
|||
[else (error 'find-special-name "couldn't find expanded name for ~a" name)])])
|
||||
(eval just-the-fn)))
|
||||
|
||||
;; these are delayed so that they use the userspace expander. I'm sure
|
||||
;; there's a more robust & elegant way to do this.
|
||||
(define special-list-value #f)
|
||||
(define special-cons-value #f)
|
||||
;; these are delayed so that they use the userspace expander. I'm sure
|
||||
;; there's a more robust & elegant way to do this.
|
||||
(define special-list-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-cons-value (find-special-value 'cons '(3 empty)))
|
||||
(set! unknown-promises-table (make-weak-hash))
|
||||
(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))])
|
||||
(list? arg-val)))
|
||||
|
||||
|
|
@ -392,25 +393,25 @@
|
|||
; (hash-table-put! binding-number-table binding new-index)
|
||||
; new-index)]))))
|
||||
|
||||
; construct-lifted-name
|
||||
; (-> syntax? (or/c num? false/c) symbol?)
|
||||
; construct-lifted-name
|
||||
; (-> syntax? (or/c num? false/c) symbol?)
|
||||
|
||||
(define/contract construct-lifted-name
|
||||
(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
|
||||
; binding-lifted-name
|
||||
|
||||
(define/contract 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)
|
||||
(define (step-was-app? mark-list)
|
||||
(and (not (null? mark-list))
|
||||
(syntax-case (mark-source (car mark-list)) (#%plain-app)
|
||||
[(#%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
|
||||
; information contained in the binding-list. This happens during reconstruction whenever we come upon
|
||||
; expressions that we haven't yet evaluated.
|
||||
; 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.
|
||||
; 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.
|
||||
; 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
|
||||
(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)
|
||||
(skipto/auto
|
||||
|
|
@ -493,7 +494,8 @@
|
|||
[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
|
||||
[recon (kernel:kernel-syntax-case
|
||||
expr #f
|
||||
|
||||
; lambda
|
||||
[(#%plain-lambda . clause-stx)
|
||||
|
|
@ -594,9 +596,9 @@
|
|||
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)
|
||||
((lambda-bound)
|
||||
(error 'reconstruct-inner "lambda-bound variables can't be mutated"))
|
||||
|
|
@ -614,56 +616,56 @@
|
|||
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a"
|
||||
(stepper-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-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 (stepper-syntax-property stx 'stepper-prim-name)
|
||||
(not (stepper-syntax-property stx 'stepper-skip-completely))))
|
||||
los))
|
||||
|
||||
|
||||
;; mflatt: MAJOR HACK - work around the prefix on
|
||||
;; beginner name definitions
|
||||
(define (fixup-name s)
|
||||
;; 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 s (string->symbol (cadr m)) 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)
|
||||
;; Frankly, I'm worried by the fact that this isn't done at expansion time.
|
||||
;; 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.
|
||||
|
||||
(define (eval-quoted stx)
|
||||
(define (eval-quoted stx)
|
||||
(syntax-case stx (quote)
|
||||
[(quote . dont-care) (eval 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.
|
||||
; 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.
|
||||
;; returns a vector containing a reconstructed expression and a boolean indicating
|
||||
;; whether this should not be unwound (e.g., is source syntax
|
||||
;; from a define-struct).
|
||||
; 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.
|
||||
;; returns a vector containing a reconstructed expression and a boolean indicating
|
||||
;; whether this should not be unwound (e.g., is source syntax
|
||||
;; 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
|
||||
(syntax-case exp ()
|
||||
[(vars-stx rhs ...)
|
||||
|
|
@ -693,8 +695,8 @@
|
|||
(attach-info #`(values #,@recon-vals) exp)))])
|
||||
#f)]))))
|
||||
|
||||
;; an abstraction lifted from reconstruct-completed
|
||||
(define (reconstruct-completed-define exp vars vals render-settings)
|
||||
;; 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)
|
||||
|
|
@ -707,13 +709,14 @@
|
|||
|
||||
|
||||
|
||||
; : (-> syntax? syntax? syntax?)
|
||||
(define (reconstruct-top-level source reconstructed)
|
||||
; : (-> syntax? syntax? syntax?)
|
||||
(define (reconstruct-top-level source reconstructed)
|
||||
(skipto/auto
|
||||
source
|
||||
'discard
|
||||
(lambda (source)
|
||||
(kernel:kernel-syntax-case source #f
|
||||
(kernel:kernel-syntax-case
|
||||
source #f
|
||||
[(define-values vars-stx body)
|
||||
(attach-info #`(define-values vars-stx #,reconstructed)
|
||||
source)]
|
||||
|
|
@ -721,44 +724,44 @@
|
|||
reconstructed]))))
|
||||
|
||||
|
||||
;; hide-completed? : syntax? -> boolean?
|
||||
(define (hide-completed? stx)
|
||||
;; hide-completed? : syntax? -> boolean?
|
||||
(define (hide-completed? stx)
|
||||
(syntax-case stx ()
|
||||
[(define-values (v) rhs)
|
||||
(stepper-syntax-property #'v 'stepper-hide-completed)]
|
||||
[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))
|
||||
|
||||
|
||||
(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))
|
||||
|
||||
|
||||
(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 : 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
|
||||
; 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)
|
||||
(define (reconstruct-current mark-list break-kind returned-value-list render-settings)
|
||||
(local
|
||||
(
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user