From 52afe35a485e983c2a1df76743d2d425c671ff77 Mon Sep 17 00:00:00 2001 From: John Clements Date: Mon, 18 Sep 2006 21:04:13 +0000 Subject: [PATCH] added language-based let-lifting choice parameter svn: r4369 --- collects/stepper/private/annotate.ss | 25 +- collects/stepper/private/macro-unwind.ss | 509 +++++++++--------- collects/stepper/private/model.ss | 43 +- collects/stepper/private/shared.ss | 10 +- .../stepper/stepper-language-interface.ss | 7 + collects/stepper/stepper-tool.ss | 87 +-- 6 files changed, 351 insertions(+), 330 deletions(-) create mode 100644 collects/stepper/stepper-language-interface.ss diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 44b4abce14..29e1705129 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -7,7 +7,7 @@ "marks.ss" "shared.ss" "my-macros.ss" - "xml-box.ss" + #;"xml-box.ss" (prefix beginner-defined: "beginner-defined.ss")) (define-syntax (where stx) @@ -21,14 +21,17 @@ ; PROVIDE (provide/contract [annotate - (-> syntax? ; syntax to annotate - (opt->* ((or/c continuation-mark-set? false/c) - break-kind?) - (list?) - (any/c)) ; procedure for runtime break - boolean? ; track-inferred-name? - string? ; language-level-name : not a nice way to abstract. - syntax?)] ; results + (syntax? ; syntax to annotate + (((or/c continuation-mark-set? false/c) + break-kind?) + (list?) + . opt->* . + (any/c)) ; procedure for runtime break + boolean? ; track-inferred-name? + any/c ; language-level + ;;string? ; language-level-name : not a nice way to abstract. + . -> . + syntax?)] ; results #;[top-level-rewrite (-> syntax? syntax?)]) ; ;; ;;;; ; @@ -259,7 +262,7 @@ ; c) a boolean indicating whether to store inferred names. ; - (define (annotate main-exp break track-inferred-names? language-level-name) + (define (annotate main-exp break track-inferred-names? language-level) #;(define _ (fprintf (current-error-port) "input to annotate: ~v\n" (syntax-object->datum main-exp))) (define binding-indexer @@ -1146,7 +1149,7 @@ ; body of local (let* ([annotated-exp (cond - [(string=? language-level-name "ACL2 Beginner (beta 8)") + [(string=? (language-level->name language-level) "ACL2 Beginner (beta 8)") (annotate/top-level/acl2 main-exp)] [else (annotate/top-level main-exp)])]) diff --git a/collects/stepper/private/macro-unwind.ss b/collects/stepper/private/macro-unwind.ss index aa754965ef..a9b65fbae6 100644 --- a/collects/stepper/private/macro-unwind.ss +++ b/collects/stepper/private/macro-unwind.ss @@ -2,13 +2,9 @@ (require (prefix kernel: (lib "kerncase.ss" "syntax")) (lib "etc.ss") (lib "contract.ss") - "shared.ss" - "lifting.ss") + "shared.ss") - (provide/contract [unwind (syntax? boolean? . -> . (listof syntax?))] - [unwind-no-highlight (syntax? . -> . (listof syntax?))]) - - ; ; ; + (provide/contract [unwind (syntax? . -> . syntax?)]) ; ; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ; ;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;; @@ -19,22 +15,10 @@ ; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; + ; unwind takes a syntax object with a single highlight, ; and returns a list of syntax objects - (define (unwind stx lift-at-highlight?) - (macro-unwind (lift stx lift-at-highlight?))) - - ; unwind-no-highlight is really just macro-unwind, but with the 'right' - ; interface that makes it more obvious what it does. - ; [unwind-no-highlight (-> syntax? (listof syntax?))] - - (define (unwind-no-highlight stx) - (macro-unwind (list stx))) - - ; unwind-only-highlight : syntax? -> (listof syntax?) - (define (unwind-only-highlight stx) - (unwind stx #t)) (define (improper-member elt improper-list) (cond [(pair? improper-list) @@ -57,248 +41,245 @@ ;(->* (syntax? (listof syntax?)) ; (syntax? (listof syntax?))) - (define (macro-unwind stxs) - (local - ((define (recur-on-pieces stx) - (if (pair? (syntax-e stx)) - (datum->syntax-object - stx (syntax-pair-map (syntax-e stx) inner) stx stx) - stx)) - - (define (fall-through stx) - (kernel:kernel-syntax-case stx #f - [id - (identifier? stx) - (or (syntax-property stx 'stepper-lifted-name) - stx)] - [(define-values dc ...) - (unwind-define stx)] - [(#%app exp ...) - (recur-on-pieces #'(exp ...))] - [(#%datum . datum) - #'datum] - [(let-values . rest) - (unwind-mz-let stx)] - [(letrec-values . rest) - (unwind-mz-let stx)] - [(set! var rhs) - (with-syntax ([unwound-var (or (syntax-property - #`var 'stepper-lifted-name) - #`var)] - [unwound-body (inner #`rhs)]) - #`(set! unwound-var unwound-body))] - [else (recur-on-pieces stx)])) - - (define (inner stx) - (transfer-info - (let ([hint (syntax-property stx 'user-stepper-hint)]) - (if (procedure? hint) - (hint stx recur-on-pieces) - (let ([process (case hint - [(comes-from-cond) unwind-cond] - [(comes-from-and) (unwind-and/or 'and)] - [(comes-from-or) (unwind-and/or 'or)] - [(comes-from-local) unwind-local] - [(comes-from-recur) unwind-recur] - [(comes-from-begin) unwind-begin] - [else fall-through])]) - (process stx)))) - stx)) - - (define (transfer-highlight from to) - (if (syntax-property from 'stepper-highlight) - (syntax-property to 'stepper-highlight #t) - to)) - - (define (unwind-recur stx) - ;; if you use #%app, it gets captured here - (with-syntax ([(app-keywd letrec-term argval ...) stx]) - (with-syntax ([(new-argval ...) - (map inner (syntax->list #`(argval ...)))]) - (let ([unwound (inner #`letrec-term)]) - (syntax-case unwound (letrec lambda) - [(letrec ([loop-name (lambda (argname ...) . bodies)]) - loop-name-2) - (unless (module-identifier=? #`loop-name #`loop-name-2) - (error "unexpected syntax for 'recur': ~v" stx)) - (transfer-highlight - unwound - #`(recur loop-name ([argname new-argval] ...) . bodies))] - [else #`(#,unwound new-argval ...)]))))) - - (define (unwind-define stx) - (kernel:kernel-syntax-case stx #f - [(define-values (name . others) body) - (begin - (unless (null? (syntax-e #'others)) - (error 'reconstruct - "reconstruct fails on multiple-values define: ~v\n" - (syntax-object->datum stx))) - (let* ([printed-name - (or (syntax-property #`name 'stepper-lifted-name) - (syntax-property #'name 'stepper-orig-name) - #'name)] - [unwound-body (inner #'body)] - ;; see notes in internal-docs.txt - [define-type (syntax-property - unwound-body 'user-stepper-define-type)]) - (if define-type - (kernel:kernel-syntax-case unwound-body #f - [(lambda arglist lam-body ...) - (case define-type - [(shortened-proc-define) - (let ([proc-define-name - (syntax-property - unwound-body - 'user-stepper-proc-define-name)]) - (if (or (module-identifier=? proc-define-name - #'name) - (and (syntax-property #'name - 'stepper-orig-name) - (module-identifier=? - proc-define-name - (syntax-property - #'name 'stepper-orig-name)))) - #`(define (#,printed-name . arglist) - lam-body ...) - #`(define #,printed-name - #,unwound-body)))] - [(lambda-define) - #`(define #,printed-name #,unwound-body)] - [else (error 'unwind-define - "unknown value for syntax property 'user-stepper-define-type: ~e" - define-type)])] - [else (error 'unwind-define - "expr with stepper-define-type is not a lambda: ~e" - (syntax-object->datum unwound-body))]) - #`(define #,printed-name #,unwound-body))))] - [else (error 'unwind-define - "expression is not a define-values: ~e" - (syntax-object->datum stx))])) - - (define (unwind-mz-let stx) - (with-syntax ([(label ([(var) rhs] ...) . bodies) stx]) - (with-syntax ([(rhs2 ...) (map inner (syntax->list #'(rhs ...)))] - [new-label - (if (improper-member 'comes-from-let* - (syntax-property - stx 'user-stepper-hint)) - #`let* - (case (syntax-e #'label) - [(let-values) #'let] - [(letrec-values) #'letrec]))] - [new-bodies (map inner (syntax->list #'bodies))]) - ;; is this let and the nested one part of a let*? - (syntax-case #`new-bodies (let*) - [((let* bindings inner-body ...)) - (and - (improper-member 'comes-from-let* - (syntax-property stx 'user-stepper-hint)) - (eq? (syntax-property stx 'user-stepper-source) - (syntax-property (car (syntax->list #`new-bodies)) - 'user-stepper-source)) - (eq? (syntax-property stx 'user-stepper-position) - (syntax-property (car (syntax->list #`new-bodies)) - 'user-stepper-position))) - #`(let* #,(append (syntax->list #`([var rhs2] ...)) - (syntax->list #`bindings)) - inner-body ...)] - [else - #`(new-label ([var rhs2] ...) . new-bodies)])))) - - (define (unwind-local stx) - (kernel:kernel-syntax-case stx #f - ;; at least through intermediate, define-values may not occur in - ;; local. - [(letrec-values ([vars exp] ...) body) - (with-syntax ([defns (map inner - (syntax->list - #`((define-values vars exp) ...)))]) - #`(local defns #,(inner #'body)))] - [else (error 'unwind-local - "expected a letrec-values, given: ~e" - (syntax-object->datum stx))])) - - ;(define (unwind-quasiquote-the-cons-application stx) - ; (syntax-case (recur-on-pieces stx) () - ; [(#%app the-cons . rest) - ; (syntax (cons . rest))] - ; [else - ; (error 'reconstruct - ; "unexpected result for unwinding the-cons application")])) - - (define (unwind-cond-clause stx test-stx result-stx) - (with-syntax ([new-test (if (syntax-property stx 'user-stepper-else) - #`else - (inner test-stx))] - [result (inner result-stx)]) - #`(new-test result))) - - (define (unwind-cond stx) - (let ([user-source (syntax-property stx 'user-source)] - [user-position (syntax-property stx 'user-position)]) - (with-syntax - ([clauses - (let loop ([stx stx]) - (if (and (eq? user-source - (syntax-property stx 'user-source)) - (eq? user-position - (syntax-property stx 'user-position))) - (syntax-case stx (if begin #%app) - ;; the else clause disappears when it's a - ;; language-inserted else clause - [(if test result) - (list (unwind-cond-clause stx #`test #`result))] - [(if test result else-clause) - (cons (unwind-cond-clause stx #`test #`result) - (loop (syntax else-clause)))] - ;; else clause appears momentarily in 'before,' even - ;; though it's a 'skip-completely' - [(begin . rest) null] - [else-stx - (error 'unwind-cond - "expected an if, got: ~e" - (syntax-object->datum (syntax else-stx)))]) - (error 'unwind-cond - "expected a cond clause expansion, got: ~e" - (syntax-object->datum stx))))]) - (syntax (cond . clauses))))) - - (define (unwind-begin stx) - (syntax-case stx (let-values) - [(let-values () body ...) - (with-syntax ([(new-body ...) - (map inner (syntax->list #`(body ...)))]) - #`(begin new-body ...))])) - - (define ((unwind-and/or label) stx) - (let ([user-source (syntax-property stx 'user-source)] - [user-position (syntax-property stx 'user-position)] - [clause-padder (case label [(and) #`true] [(or) #`false])]) - (with-syntax - ([clauses - (append - (build-list (syntax-property - stx 'user-stepper-and/or-clauses-consumed) - (lambda (dc) clause-padder)) - (let loop ([stx stx]) - (if (and (eq? user-source - (syntax-property stx 'user-source)) - (eq? user-position - (syntax-property stx 'user-position))) - (syntax-case stx (if let-values #%datum) - [(if part-1 part-2 part-3) - (cons (inner (syntax part-1)) - (case label - [(and) (loop (syntax part-2))] - [(or) (loop (syntax part-3))] - [else (error 'unwind-and/or - "unknown label ~a" label)]))] - [else - (error 'unwind-and/or - "syntax: ~a does not match and/or patterns" - (syntax-object->datum stx))]) - null)))]) - #`(#,label . clauses))))) - - (map inner stxs)))) + (define (recur-on-pieces stx) + (if (pair? (syntax-e stx)) + (datum->syntax-object + stx (syntax-pair-map (syntax-e stx) unwind) stx stx) + stx)) + + (define (fall-through stx) + (kernel:kernel-syntax-case stx #f + [id + (identifier? stx) + (or (syntax-property stx 'stepper-lifted-name) + stx)] + [(define-values dc ...) + (unwind-define stx)] + [(#%app exp ...) + (recur-on-pieces #'(exp ...))] + [(#%datum . datum) + #'datum] + [(let-values . rest) + (unwind-mz-let stx)] + [(letrec-values . rest) + (unwind-mz-let stx)] + [(set! var rhs) + (with-syntax ([unwound-var (or (syntax-property + #`var 'stepper-lifted-name) + #`var)] + [unwound-body (unwind #`rhs)]) + #`(set! unwound-var unwound-body))] + [else (recur-on-pieces stx)])) + + (define (unwind stx) + (transfer-info + (let ([hint (syntax-property stx 'user-stepper-hint)]) + (if (procedure? hint) + (hint stx recur-on-pieces) + (let ([process (case hint + [(comes-from-cond) unwind-cond] + [(comes-from-and) (unwind-and/or 'and)] + [(comes-from-or) (unwind-and/or 'or)] + [(comes-from-local) unwind-local] + [(comes-from-recur) unwind-recur] + [(comes-from-begin) unwind-begin] + [else fall-through])]) + (process stx)))) + stx)) + + (define (transfer-highlight from to) + (if (syntax-property from 'stepper-highlight) + (syntax-property to 'stepper-highlight #t) + to)) + + (define (unwind-recur stx) + ;; if you use #%app, it gets captured here + (with-syntax ([(app-keywd letrec-term argval ...) stx]) + (with-syntax ([(new-argval ...) + (map unwind (syntax->list #`(argval ...)))]) + (let ([unwound (unwind #`letrec-term)]) + (syntax-case unwound (letrec lambda) + [(letrec ([loop-name (lambda (argname ...) . bodies)]) + loop-name-2) + (unless (module-identifier=? #`loop-name #`loop-name-2) + (error "unexpected syntax for 'recur': ~v" stx)) + (transfer-highlight + unwound + #`(recur loop-name ([argname new-argval] ...) . bodies))] + [else #`(#,unwound new-argval ...)]))))) + + (define (unwind-define stx) + (kernel:kernel-syntax-case stx #f + [(define-values (name . others) body) + (begin + (unless (null? (syntax-e #'others)) + (error 'reconstruct + "reconstruct fails on multiple-values define: ~v\n" + (syntax-object->datum stx))) + (let* ([printed-name + (or (syntax-property #`name 'stepper-lifted-name) + (syntax-property #'name 'stepper-orig-name) + #'name)] + [unwound-body (unwind #'body)] + ;; see notes in internal-docs.txt + [define-type (syntax-property + unwound-body 'user-stepper-define-type)]) + (if define-type + (kernel:kernel-syntax-case unwound-body #f + [(lambda arglist lam-body ...) + (case define-type + [(shortened-proc-define) + (let ([proc-define-name + (syntax-property + unwound-body + 'user-stepper-proc-define-name)]) + (if (or (module-identifier=? proc-define-name + #'name) + (and (syntax-property #'name + 'stepper-orig-name) + (module-identifier=? + proc-define-name + (syntax-property + #'name 'stepper-orig-name)))) + #`(define (#,printed-name . arglist) + lam-body ...) + #`(define #,printed-name + #,unwound-body)))] + [(lambda-define) + #`(define #,printed-name #,unwound-body)] + [else (error 'unwind-define + "unknown value for syntax property 'user-stepper-define-type: ~e" + define-type)])] + [else (error 'unwind-define + "expr with stepper-define-type is not a lambda: ~e" + (syntax-object->datum unwound-body))]) + #`(define #,printed-name #,unwound-body))))] + [else (error 'unwind-define + "expression is not a define-values: ~e" + (syntax-object->datum stx))])) + + (define (unwind-mz-let stx) + (with-syntax ([(label ([(var) rhs] ...) . bodies) stx]) + (with-syntax ([(rhs2 ...) (map unwind (syntax->list #'(rhs ...)))] + [new-label + (if (improper-member 'comes-from-let* + (syntax-property + stx 'user-stepper-hint)) + #`let* + (case (syntax-e #'label) + [(let-values) #'let] + [(letrec-values) #'letrec]))] + [new-bodies (map unwind (syntax->list #'bodies))]) + ;; is this let and the nested one part of a let*? + (syntax-case #`new-bodies (let*) + [((let* bindings inner-body ...)) + (and + (improper-member 'comes-from-let* + (syntax-property stx 'user-stepper-hint)) + (eq? (syntax-property stx 'user-stepper-source) + (syntax-property (car (syntax->list #`new-bodies)) + 'user-stepper-source)) + (eq? (syntax-property stx 'user-stepper-position) + (syntax-property (car (syntax->list #`new-bodies)) + 'user-stepper-position))) + #`(let* #,(append (syntax->list #`([var rhs2] ...)) + (syntax->list #`bindings)) + inner-body ...)] + [else + #`(new-label ([var rhs2] ...) . new-bodies)])))) + + (define (unwind-local stx) + (kernel:kernel-syntax-case stx #f + ;; at least through intermediate, define-values may not occur in + ;; local. + [(letrec-values ([vars exp] ...) body) + (with-syntax ([defns (map unwind + (syntax->list + #`((define-values vars exp) ...)))]) + #`(local defns #,(unwind #'body)))] + [else (error 'unwind-local + "expected a letrec-values, given: ~e" + (syntax-object->datum stx))])) + + ;(define (unwind-quasiquote-the-cons-application stx) + ; (syntax-case (recur-on-pieces stx) () + ; [(#%app the-cons . rest) + ; (syntax (cons . rest))] + ; [else + ; (error 'reconstruct + ; "unexpected result for unwinding the-cons application")])) + + (define (unwind-cond-clause stx test-stx result-stx) + (with-syntax ([new-test (if (syntax-property stx 'user-stepper-else) + #`else + (unwind test-stx))] + [result (unwind result-stx)]) + #`(new-test result))) + + (define (unwind-cond stx) + (let ([user-source (syntax-property stx 'user-source)] + [user-position (syntax-property stx 'user-position)]) + (with-syntax + ([clauses + (let loop ([stx stx]) + (if (and (eq? user-source + (syntax-property stx 'user-source)) + (eq? user-position + (syntax-property stx 'user-position))) + (syntax-case stx (if begin #%app) + ;; the else clause disappears when it's a + ;; language-inserted else clause + [(if test result) + (list (unwind-cond-clause stx #`test #`result))] + [(if test result else-clause) + (cons (unwind-cond-clause stx #`test #`result) + (loop (syntax else-clause)))] + ;; else clause appears momentarily in 'before,' even + ;; though it's a 'skip-completely' + [(begin . rest) null] + [else-stx + (error 'unwind-cond + "expected an if, got: ~e" + (syntax-object->datum (syntax else-stx)))]) + (error 'unwind-cond + "expected a cond clause expansion, got: ~e" + (syntax-object->datum stx))))]) + (syntax (cond . clauses))))) + + (define (unwind-begin stx) + (syntax-case stx (let-values) + [(let-values () body ...) + (with-syntax ([(new-body ...) + (map unwind (syntax->list #`(body ...)))]) + #`(begin new-body ...))])) + + (define ((unwind-and/or label) stx) + (let ([user-source (syntax-property stx 'user-source)] + [user-position (syntax-property stx 'user-position)] + [clause-padder (case label [(and) #`true] [(or) #`false])]) + (with-syntax + ([clauses + (append + (build-list (syntax-property + stx 'user-stepper-and/or-clauses-consumed) + (lambda (dc) clause-padder)) + (let loop ([stx stx]) + (if (and (eq? user-source + (syntax-property stx 'user-source)) + (eq? user-position + (syntax-property stx 'user-position))) + (syntax-case stx (if let-values #%datum) + [(if part-1 part-2 part-3) + (cons (unwind (syntax part-1)) + (case label + [(and) (loop (syntax part-2))] + [(or) (loop (syntax part-3))] + [else (error 'unwind-and/or + "unknown label ~a" label)]))] + [else + (error 'unwind-and/or + "syntax: ~a does not match and/or patterns" + (syntax-object->datum stx))]) + null)))]) + #`(#,label . clauses)))) +) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index 0d1896a547..edc39fb1e3 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -40,12 +40,14 @@ (require (lib "contract.ss") (lib "etc.ss") (lib "match.ss") + (lib "class.ss") (prefix a: "annotate.ss") (prefix r: "reconstruct.ss") "shared.ss" "marks.ss" "model-settings.ss" "macro-unwind.ss" + "lifting.ss" ;; for breakpoint display "display-break-stuff.ss") @@ -61,7 +63,7 @@ (step-result? . -> . void?) ; receive-result (or/c render-settings? false/c) ; render-settings boolean? ; track-inferred-names? - string? ; language-level-name + object? ;; FIXME: can do better: subclass of language% ; the language level (procedure? . -> . void?) ; run-on-drscheme-side . -> . void?)]) @@ -69,7 +71,7 @@ ; go starts a stepper instance ; see provide stmt for contract (define (go program-expander receive-result render-settings - track-inferred-names? language-level-name run-on-drscheme-side) + track-inferred-names? language-level run-on-drscheme-side) ;; finished-exps: ;; (listof (list/c syntax-object? (or/c number? false?)( -> any))) @@ -184,7 +186,7 @@ (match (r:reconstruct-completed (source-thunk) lifting-indices getter render-settings) - [#(exp #f) (first-of-one (unwind-no-highlight exp))] + [#(exp #f) (unwind exp)] [#(exp #t) exp])]) finished-exps)) @@ -208,10 +210,11 @@ "broken invariant: normal-break can't have returned values")) (set! held-finished-list (reconstruct-all-completed)) (set! held-exp-list - (unwind - (r:reconstruct-left-side - mark-list returned-value-list render-settings) - #f)) + (map unwind + (maybe-lift + (r:reconstruct-left-side + mark-list returned-value-list render-settings) + #f))) (set! held-step-was-app? (r:step-was-app? mark-list)))] [(result-exp-break result-value-break) @@ -221,10 +224,11 @@ (let* ([new-finished-list (reconstruct-all-completed)] [reconstructed - (unwind - (r:reconstruct-right-side - mark-list returned-value-list render-settings) - #f)] + (map unwind + (maybe-lift + (r:reconstruct-right-side + mark-list returned-value-list render-settings) + #f))] [result (if (eq? held-exp-list no-sexp) ;; in this case, there was no "before" step, due @@ -234,6 +238,8 @@ ;; painful to do a better job, and the stepper ;; makes no guarantees in this case. (make-before-after-result + ;; NB: this (... ...) IS UNRELATED TO + ;; THE MACRO IDIOM OF THE SAME NAME (list #`(... ...)) (append new-finished-list reconstructed) 'normal) @@ -269,8 +275,8 @@ (let* ([new-finished-list (reconstruct-all-completed)] [reconstruct-result (r:reconstruct-double-break mark-list render-settings)] - [left-side (unwind (car reconstruct-result) #f)] - [right-side (unwind (cadr reconstruct-result) #t)]) + [left-side (map unwind (maybe-lift (car reconstruct-result) #f))] + [right-side (map unwind (maybe-lift (cadr reconstruct-result) #t))]) ;; add highlighting code as for other cases... (receive-result (make-before-after-result @@ -291,11 +297,16 @@ returned-value-list)] [else (error 'break "unknown label on break")])))))) - - + + (define maybe-lift + (if (send language-level stepper:enable-let-lifting?) + lift + ;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off. + (lambda (stx dont-care) (list stx)))) + (define (step-through-expression expanded expand-next-expression) (let* ([annotated (a:annotate expanded break track-inferred-names? - language-level-name)]) + language-level)]) (eval-syntax annotated) (expand-next-expression))) diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index 933c899fff..572d3207a1 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -5,7 +5,8 @@ (lib "list.ss") (lib "etc.ss") (lib "match.ss") - (lib "26.ss" "srfi")) + (lib "26.ss" "srfi") + (lib "class.ss")) ; CONTRACTS @@ -87,7 +88,7 @@ get-set-pair-union-stats ; profiling info re-intern-identifier finished-xml-box-table - >>>) + language-level->name) ;; eli's debug operator: ;; (I'm sure his version is more elegant.) @@ -671,7 +672,10 @@ [`(xml-box ,@(xmlspec ...)) (send scheme-editor insert (construct-xml-box xmlspec))] [(? string? text) (send scheme-editor insert text)]) spec))))) - + + + (define (language-level->name language) + (car (last-pair (send language get-language-position)))) ) ; test cases diff --git a/collects/stepper/stepper-language-interface.ss b/collects/stepper/stepper-language-interface.ss new file mode 100644 index 0000000000..1cbe998560 --- /dev/null +++ b/collects/stepper/stepper-language-interface.ss @@ -0,0 +1,7 @@ +(module stepper-language-interface mzscheme + + (require (lib "class.ss")) + (provide stepper-language<%>) + + (define stepper-language<%> + (interface () stepper:enable-let-lifting?))) \ No newline at end of file diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index e49f3f350e..0292e41cd3 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -14,7 +14,8 @@ "private/my-macros.ss" (prefix x: "private/mred-extensions.ss") "private/shared.ss" - "private/model-settings.ss") + "private/model-settings.ss" + "stepper-language-interface.ss") ;; hidden invariant: this list should be a sublist of the language-level ;; dialog (i.e., same order): @@ -33,7 +34,17 @@ (import drscheme:tool^ (xml-snip% scheme-snip%)) ;; tool magic here: - (define (phase1) (void)) + (define (phase1) + + ;; experiment with extending the language... parameter-like fields for stepper parameters + (drscheme:language:extend-language-interface + stepper-language<%> + (lambda (superclass) + (class* superclass (stepper-language<%>) + (public stepper:enable-let-lifting?) + (define (stepper:enable-let-lifting?) #f) + (super-instantiate ()))))) + (define (phase2) (void)) ;; this should be a preference @@ -42,14 +53,17 @@ (define drscheme-eventspace (current-eventspace)) - (define (extract-language-level settings) - (let* ([language - (drscheme:language-configuration:language-settings-language - settings)]) - (car (last-pair (send language get-language-position))))) - - (define (stepper-works-for? language-level) - (or (member language-level stepper-works-for) + (define (extract-language-level definitions-text) + (settings->language-level (definitions-text->settings definitions-text))) + + (define (definitions-text->settings definitions-text) + (send definitions-text get-next-settings)) + + (define (settings->language-level settings) + (drscheme:language-configuration:language-settings-language settings)) + + (define (stepper-works-for? language-level-name) + (or (member language-level-name stepper-works-for) (getenv "PLTSTEPPERUNSAFE"))) ;; the stepper's frame: @@ -140,13 +154,11 @@ (define (view-controller-go drscheme-frame program-expander) ;; get the language-level name: - (define language-settings - (send (send drscheme-frame get-definitions-text) get-next-settings)) - (define language - (drscheme:language-configuration:language-settings-language - language-settings)) + (define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text))) + (define language-level + (settings->language-level language-settings)) (define language-level-name - (car (last-pair (send language get-language-position)))) + (language-level->name language-level)) ;; VALUE CONVERSION CODE: @@ -157,7 +169,7 @@ ;; render-to-string : TST -> string (define (render-to-string val) (let ([string-port (open-output-string)]) - (send language render-value val simple-settings string-port) + (send language-level render-value val simple-settings string-port) (get-output-string string-port))) ;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC) @@ -198,7 +210,7 @@ [else (parameterize ([current-print-convert-hook (make-print-convert-hook simple-settings)]) (set-print-settings - language + language-level simple-settings (lambda () (simple-module-based-language-convert-value @@ -295,7 +307,7 @@ ;; is this an application step? (define (application-step? history-entry) (case (cadr history-entry) - [(user-application finished stepping) #t] + [(user-application finished-stepping) #t] [else #f])) ;; build gui object: @@ -475,11 +487,12 @@ ;; START THE MODEL (model:go program-expander-prime receive-result - (get-render-settings render-to-string render-to-sexp #t) + (get-render-settings render-to-string render-to-sexp + (send language-level stepper:enable-let-lifting?)) (not (member language-level-name (list (string-constant intermediate-student/lambda) (string-constant advanced-student)))) - language-level-name + language-level run-on-drscheme-side) (send s-frame show #t) @@ -544,16 +557,16 @@ (lambda (button evt) (if stepper-frame (send stepper-frame show #t) - (let ([language-level - (extract-language-level - (send (get-definitions-text) get-next-settings))]) - (if (stepper-works-for? language-level) + (let ([language-level-name + (language-level->name + (extract-language-level (get-definitions-text)))]) + (if (stepper-works-for? language-level-name) (set! stepper-frame (view-controller-go this program-expander)) (message-box (string-constant stepper-name) (format (string-constant stepper-language-level-message) - language-level + language-level-name (car stepper-works-for) (car (reverse stepper-works-for)))))))))) @@ -576,19 +589,19 @@ (define/public (check-current-language-for-stepper) (if (stepper-works-for? - (extract-language-level - (send (get-definitions-text) get-next-settings))) - (unless (send stepper-button is-shown?) - (send (send stepper-button get-parent) - add-child stepper-button)) - (when (send stepper-button is-shown?) - (send (send stepper-button get-parent) - delete-child stepper-button)))) + (language-level->name + (extract-language-level (get-definitions-text)))) + (unless (send stepper-button is-shown?) + (send (send stepper-button get-parent) + add-child stepper-button)) + (when (send stepper-button is-shown?) + (send (send stepper-button get-parent) + delete-child stepper-button)))) ;; add the stepper button to the button panel: (let ([p (send stepper-button get-parent)]) (send (get-button-panel) change-children (lx (cons p (remq p _))))) - + ;; hide stepper button if it's not supported for the initial language: (check-current-language-for-stepper))) @@ -668,4 +681,6 @@ ;; definitions text: (drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin) (drscheme:get/extend:extend-definitions-text - stepper-definitions-text-mixin)))) + stepper-definitions-text-mixin) + + )))