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

closer to working with v4

Browse Source 
svn: r8499
This commit is contained in:
John Clements 2008-02-02 00:37:02 +00:00
parent b9cb7f31c9
commit 4124a601ed
5 changed files with 1132 additions and 1111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2211
collects/stepper/private/annotate.ss
View File

File diff suppressed because it is too large Load Diff

6
collects/stepper/private/macro-unwind.ss
View File

@ -59,10 +59,16 @@
(unwind-define stx settings)] (unwind-define stx settings)]
[(#%plain-app exp ...) [(#%plain-app exp ...)
(recur-on-pieces #'(exp ...) settings)] (recur-on-pieces #'(exp ...) settings)]
[(quote datum)
(if (symbol? #'datum)
stx
#'datum)]
[(let-values . rest) [(let-values . rest)
(unwind-mz-let stx settings)] (unwind-mz-let stx settings)]
[(letrec-values . rest) [(letrec-values . rest)
(unwind-mz-let stx settings)] (unwind-mz-let stx settings)]
[(#%plain-lambda . rest)
(recur-on-pieces #'(lambda . rest) settings)]
[(set! var rhs) [(set! var rhs)
(with-syntax ([unwound-var (or (stepper-syntax-property (with-syntax ([unwound-var (or (stepper-syntax-property
#`var 'stepper-lifted-name) #`var 'stepper-lifted-name)

4
collects/stepper/private/model.ss
View File

@ -312,8 +312,8 @@
(program-expander (program-expander
(lambda () (lambda ()
;; swap these to allow errors to escape (e.g., when debugging) ;; swap these to allow errors to escape (e.g., when debugging)
(error-display-handler err-display-handler) #;(error-display-handler err-display-handler)
#;(void) (void)
) )
(lambda (expanded continue-thunk) ; iter (lambda (expanded continue-thunk) ; iter
(r:reset-special-values) (r:reset-special-values)

4
collects/stepper/private/reconstruct.ss
View File

@ -107,7 +107,7 @@
(define recon-value (define recon-value
(opt-lambda (val render-settings [assigned-name #f]) (opt-lambda (val render-settings [assigned-name #f])
(if (hash-table-get finished-xml-box-table val (lambda () #f)) (if (hash-table-get finished-xml-box-table val (lambda () #f))
(stepper-syntax-property #`(#%datum . #,val) 'stepper-xml-value-hint 'from-xml-box) (stepper-syntax-property #`(quote #,val) 'stepper-xml-value-hint 'from-xml-box)
(let ([closure-record (closure-table-lookup val (lambda () #f))]) (let ([closure-record (closure-table-lookup val (lambda () #f))])
(if closure-record (if closure-record
(let* ([mark (closure-record-mark closure-record)] (let* ([mark (closure-record-mark closure-record)]
@ -124,7 +124,7 @@
(let* ([rendered ((render-settings-render-to-sexp render-settings) val)]) (let* ([rendered ((render-settings-render-to-sexp render-settings) val)])
(if (symbol? rendered) (if (symbol? rendered)
#`#,rendered #`#,rendered
#`(#%datum . #,rendered)))))))) #`(quote #,rendered))))))))
(define (final-mark-list? mark-list) (define (final-mark-list? mark-list)
(and (not (null? mark-list)) (eq? (mark-label (car mark-list)) 'final))) (and (not (null? mark-list)) (eq? (mark-label (car mark-list)) 'final)))

18
collects/stepper/stepper-tool.ss
View File

@ -592,11 +592,13 @@
(send stepper-window original-program-changed)))))) (send stepper-window original-program-changed))))))
(define/augment (on-insert x y) (define/augment (on-insert x y)
(notify-stepper-frame-of-change) (unless metadata-changing-now?
(notify-stepper-frame-of-change))
(inner (void) on-insert x y)) (inner (void) on-insert x y))
(define/augment (on-delete x y) (define/augment (on-delete x y)
(notify-stepper-frame-of-change) (unless metadata-changing-now?
(notify-stepper-frame-of-change))
(inner (void) on-delete x y)) (inner (void) on-delete x y))
(define/augment (after-set-next-settings s) (define/augment (after-set-next-settings s)
@ -604,6 +606,18 @@
(when tlw (when tlw
(send tlw check-current-language-for-stepper))) (send tlw check-current-language-for-stepper)))
(inner (void) after-set-next-settings s)) (inner (void) after-set-next-settings s))
(define metadata-changing-now? #f)
;; don't pay attention to changes that occur on metadata.
;; this assumes that metadata changes cannot be nested.
(define/augment (begin-metadata-changes)
(set! metadata-changing-now? #t)
(inner (void) begin-metadata-changes))
(define/augment (end-metadata-changes)
(set! metadata-changing-now? #f)
(inner (void) end-metadata-changes))
(super-new))) (super-new)))