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

added language-based let-lifting choice parameter

Browse Source 
svn: r4369
This commit is contained in:
John Clements 2006-09-18 21:04:13 +00:00
parent 800a810dfd
commit 52afe35a48
6 changed files with 351 additions and 330 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)])])

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

@ -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))))
)

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

@ -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)))

10
collects/stepper/private/shared.ss
View File

@ -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

7
collects/stepper/stepper-language-interface.ss Normal file
View File

@ -0,0 +1,7 @@
(module stepper-language-interface mzscheme
(require (lib "class.ss"))
(provide stepper-language<%>)
(define stepper-language<%>
(interface () stepper:enable-let-lifting?)))

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

@ -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)
)))