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

introduced stepper-ignore-checker abstraction

Browse Source 
svn: r1529
This commit is contained in:
John Clements 2005-12-05 21:15:34 +00:00
parent 4f8054f125
commit e6c79bf796
1 changed files with 17 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/lang/private/teach.ss
View File

@ -93,6 +93,10 @@
;; that's allocated once) ;; that's allocated once)
(define make-lambda-generative 5) (define make-lambda-generative 5)
;; A consistent pattern for stepper-skipto:
(define-for-syntax (stepper-ignore-checker stx)
(syntax-property stx 'stepper-skipto (list syntax-e cdr syntax-e cdr car)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax implementations ;; syntax implementations
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -232,13 +236,12 @@
(syntax/loc stx (syntax/loc stx
(check-top-level-not-defined 'who #'name)))) (check-top-level-not-defined 'who #'name))))
(stx->list names))]) (stx->list names))])
(syntax-property ;; this use of stepper-ignore-checker will behave badly on multiple-name defines:
(stepper-ignore-checker
(syntax/loc stx (syntax/loc stx
(begin (begin
check ... check ...
defn)) defn)))))]
'stepper-skipto
(list syntax-e cdr syntax-e cdr car))))]
[(eq? (syntax-local-context) 'module) [(eq? (syntax-local-context) 'module)
(for-each (lambda (name) (for-each (lambda (name)
(let ([b (identifier-binding name)]) (let ([b (identifier-binding name)])
@ -276,9 +279,7 @@
(define (ensure-expression stx k) (define (ensure-expression stx k)
(if (memq (syntax-local-context) '(expression)) (if (memq (syntax-local-context) '(expression))
(k) (k)
(syntax-property #`(values #,stx) (stepper-ignore-checker #`(values #,stx))))
'stepper-skipto
(list syntax-e cdr syntax-e cdr car))))
;; Use to generate nicer error messages than direct pattern ;; Use to generate nicer error messages than direct pattern
;; matching. The `where' argument is an English description ;; matching. The `where' argument is an English description
@ -852,8 +853,8 @@
(syntax-source-module #'id)) (syntax-source-module #'id))
;; ... but it might be defined later in the module, so ;; ... but it might be defined later in the module, so
;; delay the check. ;; delay the check.
(let ([tc (syntax/loc stx (beginner-top-continue id))]) (stepper-ignore-checker
(ensure-expression tc (lambda () tc))) (syntax/loc stx (#%app values (beginner-top-continue id))))
(syntax/loc stx (#%top . id)))])) (syntax/loc stx (#%top . id)))]))
(define (beginner-top-continue/proc stx) (define (beginner-top-continue/proc stx)
@ -917,9 +918,7 @@
(with-syntax ([new-test (syntax-property (syntax #t) 'stepper-else #t)]) (with-syntax ([new-test (syntax-property (syntax #t) 'stepper-else #t)])
(syntax/loc clause (new-test answer))))] (syntax/loc clause (new-test answer))))]
[(question answer) [(question answer)
(with-syntax ([verified (syntax-property (syntax (verify-boolean question 'cond)) (with-syntax ([verified (stepper-ignore-checker (syntax (verify-boolean question 'cond)))])
'stepper-skipto
(list syntax-e cdr syntax-e cdr car))])
(syntax/loc clause (verified answer)))] (syntax/loc clause (verified answer)))]
[() [()
(check-preceding-exprs clause) (check-preceding-exprs clause)
@ -993,9 +992,7 @@
(lambda () (lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ test then else) [(_ test then else)
(with-syntax ([new-test (syntax-property (syntax (verify-boolean test 'if)) (with-syntax ([new-test (stepper-ignore-checker (syntax (verify-boolean test 'if)))])
'stepper-skipto
(list syntax-e cdr syntax-e cdr car))])
(syntax/loc stx (syntax/loc stx
(if new-test (if new-test
then then
@ -1047,9 +1044,7 @@
(syntax-property (syntax-property
(quasisyntax/loc (quasisyntax/loc
stx stx
(if #,(syntax-property (quasisyntax/loc stx (verify-boolean #,(car remaining) 'swhere)) (if #,(stepper-ignore-checker (quasisyntax/loc stx (verify-boolean #,(car remaining) 'swhere)))
`stepper-skipto
(list syntax-e cdr syntax-e cdr car))
#,@(case where #,@(case where
[(or) #`(#t [(or) #`(#t
#,(loop (+ clauses-consumed 1) (cdr remaining)))] #,(loop (+ clauses-consumed 1) (cdr remaining)))]
@ -1837,10 +1832,7 @@
(syntax/loc stx (begin (set! id expr ...) set!-result)) (syntax/loc stx (begin (set! id expr ...) set!-result))
'stepper-skipto 'stepper-skipto
(list syntax-e cdr syntax-e car)) (list syntax-e cdr syntax-e car))
(syntax-property (stepper-ignore-checker (syntax/loc stx (#%app values (advanced-set!-continue id expr ...))))))]
(syntax/loc stx (#%app values (advanced-set!-continue id expr ...)))
'stepper-skipto
(list syntax-e cdr syntax-e cdr car))))]
[(_ id . __) [(_ id . __)
(teach-syntax-error (teach-syntax-error
'set! 'set!
@ -1938,7 +1930,9 @@
#f #f
"expected a sequence of expressions after `begin', but nothing's there")] "expected a sequence of expressions after `begin', but nothing's there")]
[(_ e ...) [(_ e ...)
(syntax/loc stx (let () e ...))] (syntax-property (syntax/loc stx (let () e ...))
'stepper-hint
'comes-from-begin)]
[_else [_else
(bad-use-error 'begin stx)])) (bad-use-error 'begin stx)]))