suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactoring, no semantic changes

Browse Source
This commit is contained in:
John Clements 2011-07-09 13:59:10 -07:00
parent 2cebd8f4cb
commit 592f28382b
1 changed files with 185 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
collects/stepper/private/reconstruct.rkt
View File

@ -245,29 +245,32 @@
#`(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
; so it never gets added to partially-evaluated-promises-table ; 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 ; 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
@ -277,7 +280,8 @@
(stepper-syntax-property expr 'stepper-hide-reduction)))] (stepper-syntax-property expr 'stepper-hide-reduction)))]
[(result-exp-break) [(result-exp-break)
;; skip if clauses that are the result of and/or reductions ;; skip if clauses that are the result of and/or reductions
(let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)]) (let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list))
'stepper-and/or-clauses-consumed)])
(and and/or-clauses-consumed (and and/or-clauses-consumed
(> and/or-clauses-consumed 0)))] (> and/or-clauses-consumed 0)))]
[(normal-break normal-break/values) [(normal-break normal-break/values)
@ -342,9 +346,9 @@
(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
;; like 'list' should not be shown as steps, because the before and after steps will be the same. ;; functions like 'list' should not be shown as steps, because the before and after steps will
;; it might be easier simply to discover and discard these at display time. ;; be the same. 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))]
@ -436,35 +440,36 @@
; 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
; information contained in the binding-list. This happens during reconstruction whenever we come upon ; binding information contained in the binding-list. This happens during reconstruction
; expressions that we haven't yet evaluated. ; 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 ; NB: the variable 'dont-lookup' contains a list of variables whose bindings occur INSIDE the
; being evaluated, and hence do NOT yet have values. ; 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 ; the 'use-lifted-names' vars are those bound by a let which does have lifted names. it is
; rendering the lifting of a let or local to show the 'after' step, which should show the lifted names. ; 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?) (-> 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)
(define (recur expr) (recon-source-expr expr mark-list dont-lookup
use-lifted-names render-settings))
(define (let-recur expr bindings)
(recon-source-expr expr mark-list (append bindings dont-lookup)
use-lifted-names render-settings))
(skipto/auto (skipto/auto
expr expr
'discard 'discard
(lambda (expr) (lambda (expr)
(if (stepper-syntax-property expr 'stepper-prim-name)
(stepper-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 (define (recon-basic)
(lambda ()
(with-syntax ([(label . bodies) expr]) (with-syntax ([(label . bodies) expr])
#`(label #,@(map recur (filter-skipped (syntax->list (syntax bodies)))))))] #`(label #,@(map recur (filter-skipped (syntax->list (syntax bodies)))))))
[recon-let/rec (define (recon-let/rec rec?)
(lambda (rec?)
(with-syntax ([(label ((vars val) ...) body ...) expr]) (with-syntax ([(label ((vars val) ...) body ...) expr])
(let* ([bindings (map syntax->list (syntax->list (syntax (vars ...))))] (let* ([bindings (map syntax->list (syntax->list (syntax (vars ...))))]
@ -475,26 +480,32 @@
[right-sides (map recur-fn (syntax->list (syntax (val ...))))] [right-sides (map recur-fn (syntax->list (syntax (val ...))))]
[recon-bodies (map (lambda (x) (let-recur x binding-list)) [recon-bodies (map (lambda (x) (let-recur x binding-list))
(syntax->list #`(body ...)))]) (syntax->list #`(body ...)))])
(with-syntax ([(recon-val ...) right-sides] (with-syntax
([(recon-val ...) right-sides]
[(recon-body ...) recon-bodies] [(recon-body ...) recon-bodies]
[(new-vars ...) (map (lx (map (lx (if (ormap (lambda (binding) [(new-vars ...)
(map (lx (map (lx (if (ormap (lambda (binding)
(bound-identifier=? binding _)) (bound-identifier=? binding _))
use-lifted-names) use-lifted-names)
(stepper-syntax-property _ (stepper-syntax-property
_
'stepper-lifted-name 'stepper-lifted-name
(binding-lifted-name mark-list _)) (binding-lifted-name mark-list _))
_)) _))
_)) _))
bindings)]) bindings)])
(syntax (label ((new-vars recon-val) ...) recon-body ...))))))] (syntax (label ((new-vars recon-val) ...) recon-body ...))))))
[recon-lambda-clause
(lambda (clause) (define (recon-lambda-clause clause)
(with-syntax ([(args . bodies-stx) clause]) (with-syntax ([(args . bodies-stx) clause])
(let* ([arglist (arglist-flatten #'args)] (let* ([arglist (arglist-flatten #'args)]
[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
(define (recon)
(kernel:kernel-syntax-case
expr #f expr #f
; lambda ; lambda
@ -580,10 +591,14 @@
((stepper-temp) ((stepper-temp)
(error 'recon-source-expr "stepper-temp showed up in source?!?")) (error 'recon-source-expr "stepper-temp showed up in source?!?"))
((non-lexical) ((non-lexical)
(error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical")) (error
'recon-source-expr
"can't get here: lexical identifier labeled as non-lexical"))
(else (else
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a on var: ~a" (error 'recon-source-expr
(stepper-syntax-property var 'stepper-binding-type) (syntax->datum var)))))] "unknown 'stepper-binding-type property: ~a on var: ~a"
(stepper-syntax-property var 'stepper-binding-type)
(syntax->datum var)))))]
[else ; top-level-varref [else ; top-level-varref
(fixup-name (fixup-name
var)])))] var)])))]
@ -593,8 +608,11 @@
[else [else
(error 'recon-source "no matching clause for syntax: ~a" (if (syntax? expr) (error 'recon-source "no matching clause for syntax: ~a" (if (syntax? expr)
(syntax->datum expr) (syntax->datum expr)
expr))])]) expr))]))
(attach-info recon expr))))))) (if (stepper-syntax-property expr 'stepper-prim-name)
(stepper-syntax-property expr 'stepper-prim-name)
(let* ()
(attach-info (recon) expr)))))))
;; reconstruct-set!-var ;; reconstruct-set!-var