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

...

Browse Source 
svn: r7276
This commit is contained in:
John Clements 2007-09-05 00:23:34 +00:00
parent ffe26decff
commit ba7441b3a5
2 changed files with 47 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/stepper/internal-docs.txt
View File

@ -86,6 +86,7 @@ stepper-hint :
[ 'from-splice-box ] : expression was expanded from a scheme splice
box (inside an xml box)
[ 'comes-from-recur ] : expression was expanded from a 'recur'
[ 'comes-from-check-expect ] : expression was expanded from a 'check-expect'
stepper-define-type:
this is attached to the right-hand sides of defines to indicate what

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

@ -1,4 +1,4 @@
(module macro-unwind mzscheme
(module macro-unwind mzscheme
(require (prefix kernel: (lib "kerncase.ss" "syntax"))
(lib "etc.ss")
(lib "contract.ss")
@ -117,44 +117,51 @@
(error 'reconstruct
"reconstruct fails on multiple-values define: ~v\n"
(syntax-object->datum stx)))
(let* ([printed-name
(or (stepper-syntax-property #`name 'stepper-lifted-name)
(stepper-syntax-property #'name 'stepper-orig-name)
#'name)]
[unwound-body (unwind #'body settings)]
;; see notes in internal-docs.txt
[define-type (stepper-syntax-property
unwound-body '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
(stepper-syntax-property
unwound-body
'stepper-proc-define-name)])
(if (or (module-identifier=? proc-define-name
#'name)
(and (stepper-syntax-property #'name
'stepper-orig-name)
(module-identifier=?
proc-define-name
(stepper-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 '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))))]
(if (eq? (stepper-syntax-property #`body 'stepper-hint) 'comes-from-check-expect)
(kernel:kernel-syntax-case
(unwind #`body settings) #f
[(c-e (lambda () a1) a2 a3)
#`(check-expect a1 a2)]
[else #`(c-e body)])
(let* ([printed-name
(or (stepper-syntax-property #`name 'stepper-lifted-name)
(stepper-syntax-property #'name 'stepper-orig-name)
#'name)]
[unwound-body (unwind #'body settings)]
;; see notes in internal-docs.txt
[define-type (stepper-syntax-property
unwound-body '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
(stepper-syntax-property
unwound-body
'stepper-proc-define-name)])
(if (or (module-identifier=? proc-define-name
#'name)
(and (stepper-syntax-property #'name
'stepper-orig-name)
(module-identifier=?
proc-define-name
(stepper-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 '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))]))