closer to working with v4
svn: r8499
This commit is contained in:
John Clements
parent
b9cb7f31c9
commit
4124a601ed
|
|
@ -1,14 +1,15 @@
|
|||
(module annotate scheme/base
|
||||
#lang scheme/base
|
||||
|
||||
(require (prefix-in kernel: (lib "kerncase.ss" "syntax"))
|
||||
(lib "contract.ss")
|
||||
(lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "match.ss")
|
||||
scheme/match
|
||||
"marks.ss"
|
||||
"shared.ss"
|
||||
"my-macros.ss"
|
||||
#;"xml-box.ss"
|
||||
#;(file "~/clements/scheme-scraps/eli-debug.ss")
|
||||
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
|
||||
(prefix-in beginner-defined: "beginner-defined.ss")
|
||||
(for-syntax scheme/base))
|
||||
|
||||
|
|
@ -272,7 +273,8 @@
|
|||
|
||||
|
||||
(define ((annotate/master input-is-top-level?) main-exp break show-lambdas-as-lambdas? language-level)
|
||||
#;(define _ (>>> (syntax-object->datum main-exp)))
|
||||
|
||||
#;(define _ (>>> main-exp #;(syntax->datum main-exp)))
|
||||
|
||||
(define binding-indexer
|
||||
(let ([binding-index 0])
|
||||
|
|
@ -368,16 +370,16 @@
|
|||
|
||||
|
||||
|
||||
; ;
|
||||
; ; ;
|
||||
;;; ; ;; ; ;; ;;; ;;;; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;;
|
||||
; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;; ; ; ; ; ; ; ;;;;; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
;;;;; ; ; ; ; ;;; ;; ;;;;; ;; ;;;; ; ; ; ; ; ; ;;;; ;
|
||||
;
|
||||
; ; ; ;
|
||||
; ;;; ; ;; ; ;; ;;; ;;;; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;;
|
||||
; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;; ; ; ; ; ; ; ;;;;; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;;;; ; ; ; ; ;;; ;; ;;;;; ;; ;;;; ; ; ; ; ; ; ;;;; ;
|
||||
; ;
|
||||
;
|
||||
|
||||
(define annotate/inner
|
||||
|
|
@ -751,16 +753,17 @@
|
|||
((non-lexical) ;; is it from this module or not?
|
||||
(match (identifier-binding var)
|
||||
(#f (top-level-varref-break-wrap))
|
||||
[`(,path-index-or-symbol ,dc1 ,dc2 ,dc3 ,dc4)
|
||||
(if (module-path-index? path-index-or-symbol)
|
||||
(let-values ([(module-path dc5) (module-path-index-split path-index-or-symbol)])
|
||||
['lexical
|
||||
;; my reading of the docs suggest that this should not occur in v4...
|
||||
(error 'varref-abstraction "identifier-binding should not be 'lexical")]
|
||||
[(list-rest (? module-path-index? path-index) dontcare)
|
||||
(let-values ([(module-path dc5) (module-path-index-split path-index)])
|
||||
(if module-path
|
||||
;; not a module-local variable:
|
||||
(top-level-varref-break-wrap)
|
||||
;; a module-local-variable:
|
||||
(varref-break-wrap)))
|
||||
(top-level-varref-break-wrap))]
|
||||
[else (error 'annotate "unexpected value for identifier-binding: ~v" identifier-binding)])))
|
||||
(varref-break-wrap)))]
|
||||
[other (error 'annotate "unexpected value for identifier-binding: ~v" other)])))
|
||||
free-varrefs)))]
|
||||
|
||||
[recertifier
|
||||
|
|
@ -1088,18 +1091,22 @@
|
|||
(define/contract annotate/top-level
|
||||
(syntax? . -> . syntax?)
|
||||
(lambda (exp)
|
||||
(syntax-case exp (module #%plain-module-begin let-values dynamic-wind lambda)
|
||||
(syntax-case exp (module #%plain-module-begin let-values dynamic-wind #%plain-lambda #%plain-app)
|
||||
[(module name lang
|
||||
(#%plain-module-begin . bodies))
|
||||
#`(module name lang (#%plain-module-begin #,@(map annotate/module-top-level (syntax->list #`bodies))))]
|
||||
; the 'require' form is used for the test harness
|
||||
[(require module-name) exp]
|
||||
; the 'dynamic-require' form is used by the actual expander
|
||||
|
||||
;; RIGHT HERE, basically: the test harness breaks because of multiple definitions of identifiers. Probably we want
|
||||
;; to mangle the output of run-teaching-program so that the module is required with some kind of temporary prefix?
|
||||
|
||||
[(let-values ([(done-already?) . rest1])
|
||||
(#%app dynamic-wind
|
||||
(#%plain-app dynamic-wind
|
||||
void
|
||||
(lambda () . rest2)
|
||||
(lambda () . rest3)))
|
||||
(#%plain-lambda () . rest2)
|
||||
(#%plain-lambda () . rest3)))
|
||||
exp]
|
||||
[else
|
||||
#;
|
||||
|
|
@ -1137,9 +1144,7 @@
|
|||
|
||||
|
||||
|
||||
(define/contract annotate/module-top-level
|
||||
(syntax? . -> . syntax?)
|
||||
(lambda (exp)
|
||||
(define (annotate/module-top-level exp)
|
||||
(cond [(stepper-syntax-property exp 'stepper-skip-completely) exp]
|
||||
[(stepper-syntax-property exp 'stepper-define-struct-hint)
|
||||
#`(begin #,exp
|
||||
|
|
@ -1147,8 +1152,8 @@
|
|||
[(stepper-syntax-property exp 'stepper-skipto)
|
||||
(skipto/auto exp 'rebuild annotate/module-top-level)]
|
||||
[else
|
||||
(syntax-case exp (#%plain-app call-with-values define-values define-syntaxes
|
||||
#%require #%provide begin lambda)
|
||||
(syntax-case exp (#%app #%plain-app call-with-values define-values define-syntaxes
|
||||
#%require #%provide begin #%plain-lambda lambda)
|
||||
[(define-values (new-var ...) e)
|
||||
(let* ([name-list (syntax->list #`(new-var ...))]
|
||||
[defined-name (if (and (pair? name-list) (null? (cdr name-list)))
|
||||
|
|
@ -1167,7 +1172,7 @@
|
|||
exp]
|
||||
[(begin . bodies)
|
||||
#`(begin #,@(map annotate/module-top-level (syntax->list #`bodies)))]
|
||||
[(#%plain-app call-with-values (lambda () body) print-values)
|
||||
[(#%plain-app call-with-values (#%plain-lambda () body) print-values)
|
||||
#`(call-with-values
|
||||
(lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) exp #f))
|
||||
(lambda vals
|
||||
|
|
@ -1182,7 +1187,7 @@
|
|||
(top-level-annotate/inner (top-level-rewrite exp) exp #f)
|
||||
;; the following check can't be permitted in the presence of things like test-suite cases
|
||||
;; which produce arbitrary expressions at the top level.
|
||||
#;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax->datum exp))])])))
|
||||
#;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax->datum exp))])]))
|
||||
|
||||
; body of local
|
||||
(if input-is-top-level?
|
||||
|
|
@ -1200,7 +1205,3 @@
|
|||
;; !@#$ defs have to appear after annotate/master.
|
||||
(define annotate (annotate/master #t))
|
||||
(define annotate/not-top-level (annotate/master #f))
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -59,10 +59,16 @@
|
|||
(unwind-define stx settings)]
|
||||
[(#%plain-app exp ...)
|
||||
(recur-on-pieces #'(exp ...) settings)]
|
||||
[(quote datum)
|
||||
(if (symbol? #'datum)
|
||||
stx
|
||||
#'datum)]
|
||||
[(let-values . rest)
|
||||
(unwind-mz-let stx settings)]
|
||||
[(letrec-values . rest)
|
||||
(unwind-mz-let stx settings)]
|
||||
[(#%plain-lambda . rest)
|
||||
(recur-on-pieces #'(lambda . rest) settings)]
|
||||
[(set! var rhs)
|
||||
(with-syntax ([unwound-var (or (stepper-syntax-property
|
||||
#`var 'stepper-lifted-name)
|
||||
|
|
|
|||
|
|
@ -312,8 +312,8 @@
|
|||
(program-expander
|
||||
(lambda ()
|
||||
;; swap these to allow errors to escape (e.g., when debugging)
|
||||
(error-display-handler err-display-handler)
|
||||
#;(void)
|
||||
#;(error-display-handler err-display-handler)
|
||||
(void)
|
||||
)
|
||||
(lambda (expanded continue-thunk) ; iter
|
||||
(r:reset-special-values)
|
||||
|
|
|
|||
|
|
@ -107,7 +107,7 @@
|
|||
(define recon-value
|
||||
(opt-lambda (val render-settings [assigned-name #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))])
|
||||
(if closure-record
|
||||
(let* ([mark (closure-record-mark closure-record)]
|
||||
|
|
@ -124,7 +124,7 @@
|
|||
(let* ([rendered ((render-settings-render-to-sexp render-settings) val)])
|
||||
(if (symbol? rendered)
|
||||
#`#,rendered
|
||||
#`(#%datum . #,rendered))))))))
|
||||
#`(quote #,rendered))))))))
|
||||
|
||||
(define (final-mark-list? mark-list)
|
||||
(and (not (null? mark-list)) (eq? (mark-label (car mark-list)) 'final)))
|
||||
|
|
|
|||
|
|
@ -592,11 +592,13 @@
|
|||
(send stepper-window original-program-changed))))))
|
||||
|
||||
(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))
|
||||
|
||||
(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))
|
||||
|
||||
(define/augment (after-set-next-settings s)
|
||||
|
|
@ -605,6 +607,18 @@
|
|||
(send tlw check-current-language-for-stepper)))
|
||||
(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)))
|
||||
|
||||
;; apply the mixins dynamically to the drscheme unit frame and
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user