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

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

@ -1,27 +1,28 @@
(module annotate scheme/base #lang scheme/base
(require (prefix-in kernel: (lib "kerncase.ss" "syntax"))
(require (prefix-in kernel: (lib "kerncase.ss" "syntax"))
(lib "contract.ss") (lib "contract.ss")
(lib "list.ss") (lib "list.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "match.ss") scheme/match
"marks.ss" "marks.ss"
"shared.ss" "shared.ss"
"my-macros.ss" "my-macros.ss"
#;"xml-box.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") (prefix-in beginner-defined: "beginner-defined.ss")
(for-syntax scheme/base)) (for-syntax scheme/base))
(define-syntax (where stx) (define-syntax (where stx)
(syntax-case stx () (syntax-case stx ()
[(_ body bindings) [(_ body bindings)
(syntax/loc stx (letrec bindings body))])) (syntax/loc stx (letrec bindings body))]))
; CONTRACTS ; CONTRACTS
; PROVIDE ; PROVIDE
(provide/contract (provide/contract
[annotate [annotate
(syntax? ; syntax to annotate (syntax? ; syntax to annotate
(((or/c continuation-mark-set? false/c) (((or/c continuation-mark-set? false/c)
@ -60,7 +61,7 @@
; ; ; ; ; ;
; ; ; ; ; ;
; ;
; wrap-struct-form ; wrap-struct-form
; (define (wrap-struct-form names annotated) ; (define (wrap-struct-form names annotated)
; (let* ([arg-temps (build-list (length names) get-arg-var)] ; (let* ([arg-temps (build-list (length names) get-arg-var)]
@ -81,21 +82,21 @@
; test exps: ; test exps:
; (andmap (lambda (arg-list) ; (andmap (lambda (arg-list)
; (let* ([stx (car arg-list)] ; (let* ([stx (car arg-list)]
; [elaborated (cadr arg-list)] ; [elaborated (cadr arg-list)]
; [eval-result (caddr arg-list)] ; [eval-result (caddr arg-list)]
; [collapsed (collapse-let-values (expand stx))]) ; [collapsed (collapse-let-values (expand stx))])
; (printf "~a~n~a~n~a~n~a~n" (syntax->datum collapsed) ; (printf "~a~n~a~n~a~n~a~n" (syntax->datum collapsed)
; elaborated ; elaborated
; (eval collapsed) ; (eval collapsed)
; eval-result) ; eval-result)
; (and (equal? (syntax->datum collapsed) elaborated) ; (and (equal? (syntax->datum collapsed) elaborated)
; (equal? (eval collapsed) eval-result)))) ; (equal? (eval collapsed) eval-result))))
; (list (list #'(let ([a 3] [b 9]) (+ a b)) '(let-values ([(a) (#%datum . 3)] [(b) (#%datum . 9)]) (#%app (#%top . +) a b)) 12) ; (list (list #'(let ([a 3] [b 9]) (+ a b)) '(let-values ([(a) (#%datum . 3)] [(b) (#%datum . 9)]) (#%app (#%top . +) a b)) 12)
; (list #'(let* ([a 9] [b a] [c b]) c) '(let*-values ([(a) (#%datum . 9)] [(b) a] [(c) b]) c) 9) ; (list #'(let* ([a 9] [b a] [c b]) c) '(let*-values ([(a) (#%datum . 9)] [(b) a] [(c) b]) c) 9)
; (list #'(let ([a 3] [b 9]) (let ([b 14]) b)) '(let*-values ([(a) (#%datum . 3)] [(b) (#%datum . 9)] [(b) (#%datum . 14)]) b) 14))) ; (list #'(let ([a 3] [b 9]) (let ([b 14]) b)) '(let*-values ([(a) (#%datum . 3)] [(b) (#%datum . 9)] [(b) (#%datum . 14)]) b) 14)))
; ;
; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;
@ -111,15 +112,15 @@
; ;
; top-level-rewrite : (SYNTAX-OBJECT -> SYNTAX-OBJECT) ; top-level-rewrite : (SYNTAX-OBJECT -> SYNTAX-OBJECT)
; top-level-rewrite performs several tasks; it labels variables with their types (let-bound, lambda-bound, or non-lexical), ; top-level-rewrite performs several tasks; it labels variables with their types (let-bound, lambda-bound, or non-lexical),
; it flags if's which could come from cond's, it labels the begins in conds with 'stepper-skip annotations ; it flags if's which could come from cond's, it labels the begins in conds with 'stepper-skip annotations
; label-var-types returns a syntax object which is identical to the original except that the variable references are labeled ; label-var-types returns a syntax object which is identical to the original except that the variable references are labeled
; with the stepper-syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical. ; with the stepper-syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical.
(define (top-level-rewrite stx) (define (top-level-rewrite stx)
(let loop ([stx stx] (let loop ([stx stx]
[let-bound-bindings null] [let-bound-bindings null]
[cond-test (lx #f)]) [cond-test (lx #f)])
@ -229,13 +230,13 @@
(syntax-recertify rewritten stx (current-code-inspector) #f)))))) (syntax-recertify rewritten stx (current-code-inspector) #f))))))
; ;
; ; ; ; ; ; ; ;
; ; ; ;; ; ;; ;;; ;;;; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ;;;; ;;; ;;;; ;;;
; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;; ;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;;; ;; ;;;;; ;; ;;;; ; ; ; ; ; ; ;;; ;; ;;;;; ;; ;;;;
@ -271,8 +272,9 @@
(define ((annotate/master input-is-top-level?) main-exp break show-lambdas-as-lambdas? language-level) (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 (define binding-indexer
(let ([binding-index 0]) (let ([binding-index 0])
@ -368,16 +370,16 @@
; ;
; ; ; ; ; ;
;;; ; ;; ; ;; ;;; ;;;; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;; ; ; ; ;
; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ;;; ; ;; ; ;; ;;; ;;;; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;;
;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;; ; ; ; ; ; ; ;;;;; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
;;;;; ; ; ; ; ;;; ;; ;;;;; ;; ;;;; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;;;;; ; ; ; ; ;;; ;; ;;;;; ;; ;;;; ; ; ; ; ; ; ;;;; ;
; ;
; ;
(define annotate/inner (define annotate/inner
@ -751,16 +753,17 @@
((non-lexical) ;; is it from this module or not? ((non-lexical) ;; is it from this module or not?
(match (identifier-binding var) (match (identifier-binding var)
(#f (top-level-varref-break-wrap)) (#f (top-level-varref-break-wrap))
[`(,path-index-or-symbol ,dc1 ,dc2 ,dc3 ,dc4) ['lexical
(if (module-path-index? path-index-or-symbol) ;; my reading of the docs suggest that this should not occur in v4...
(let-values ([(module-path dc5) (module-path-index-split path-index-or-symbol)]) (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 (if module-path
;; not a module-local variable: ;; not a module-local variable:
(top-level-varref-break-wrap) (top-level-varref-break-wrap)
;; a module-local-variable: ;; a module-local-variable:
(varref-break-wrap))) (varref-break-wrap)))]
(top-level-varref-break-wrap))] [other (error 'annotate "unexpected value for identifier-binding: ~v" other)])))
[else (error 'annotate "unexpected value for identifier-binding: ~v" identifier-binding)])))
free-varrefs)))] free-varrefs)))]
[recertifier [recertifier
@ -1088,18 +1091,22 @@
(define/contract annotate/top-level (define/contract annotate/top-level
(syntax? . -> . syntax?) (syntax? . -> . syntax?)
(lambda (exp) (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 [(module name lang
(#%plain-module-begin . bodies)) (#%plain-module-begin . bodies))
#`(module name lang (#%plain-module-begin #,@(map annotate/module-top-level (syntax->list #`bodies))))] #`(module name lang (#%plain-module-begin #,@(map annotate/module-top-level (syntax->list #`bodies))))]
; the 'require' form is used for the test harness ; the 'require' form is used for the test harness
[(require module-name) exp] [(require module-name) exp]
; the 'dynamic-require' form is used by the actual expander ; 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]) [(let-values ([(done-already?) . rest1])
(#%app dynamic-wind (#%plain-app dynamic-wind
void void
(lambda () . rest2) (#%plain-lambda () . rest2)
(lambda () . rest3))) (#%plain-lambda () . rest3)))
exp] exp]
[else [else
#; #;
@ -1137,9 +1144,7 @@
(define/contract annotate/module-top-level (define (annotate/module-top-level exp)
(syntax? . -> . syntax?)
(lambda (exp)
(cond [(stepper-syntax-property exp 'stepper-skip-completely) exp] (cond [(stepper-syntax-property exp 'stepper-skip-completely) exp]
[(stepper-syntax-property exp 'stepper-define-struct-hint) [(stepper-syntax-property exp 'stepper-define-struct-hint)
#`(begin #,exp #`(begin #,exp
@ -1147,8 +1152,8 @@
[(stepper-syntax-property exp 'stepper-skipto) [(stepper-syntax-property exp 'stepper-skipto)
(skipto/auto exp 'rebuild annotate/module-top-level)] (skipto/auto exp 'rebuild annotate/module-top-level)]
[else [else
(syntax-case exp (#%plain-app call-with-values define-values define-syntaxes (syntax-case exp (#%app #%plain-app call-with-values define-values define-syntaxes
#%require #%provide begin lambda) #%require #%provide begin #%plain-lambda lambda)
[(define-values (new-var ...) e) [(define-values (new-var ...) e)
(let* ([name-list (syntax->list #`(new-var ...))] (let* ([name-list (syntax->list #`(new-var ...))]
[defined-name (if (and (pair? name-list) (null? (cdr name-list))) [defined-name (if (and (pair? name-list) (null? (cdr name-list)))
@ -1167,7 +1172,7 @@
exp] exp]
[(begin . bodies) [(begin . bodies)
#`(begin #,@(map annotate/module-top-level (syntax->list #`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 #`(call-with-values
(lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) exp #f)) (lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) exp #f))
(lambda vals (lambda vals
@ -1182,7 +1187,7 @@
(top-level-annotate/inner (top-level-rewrite exp) exp #f) (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 ;; the following check can't be permitted in the presence of things like test-suite cases
;; which produce arbitrary expressions at the top level. ;; 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 ; body of local
(if input-is-top-level? (if input-is-top-level?
@ -1197,10 +1202,6 @@
(annotate/inner (top-level-rewrite main-exp) 'all #f #f)]) (annotate/inner (top-level-rewrite main-exp) 'all #f #f)])
annotated))) annotated)))
;; !@#$ defs have to appear after annotate/master. ;; !@#$ defs have to appear after annotate/master.
(define annotate (annotate/master #t)) (define annotate (annotate/master #t))
(define annotate/not-top-level (annotate/master #f)) (define annotate/not-top-level (annotate/master #f))
)

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)
@ -605,6 +607,18 @@
(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)))
;; apply the mixins dynamically to the drscheme unit frame and ;; apply the mixins dynamically to the drscheme unit frame and