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

Htdp no longer throws exceptions that have no source information

Browse Source
This commit is contained in:
Guillaume Marceau 2011-06-02 17:34:46 -04:00
parent 79589b9b9f
commit f858b8bb5c
3 changed files with 27 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/drracket/private/rep.rkt
View File

@ -709,21 +709,6 @@ TODO
(set! error-ranges locs)
#|
TODO
send: target is not an object: #f for method: begin-edit-sequence
=== context ===
C:\documents\projects\plt\collects\racket\private\class-internal.rkt:4550:0: obj-error
C:\documents\projects\plt\collects\racket\private\class-internal.rkt:3814:0: find-method/who
C:\documents\projects\plt\collects\drracket\private\rep.rkt:719:20
C:\documents\projects\plt\collects\racket\private\map.rkt:45:11: for-each
C:\documents\projects\plt\collects\drracket\private\rep.rkt:660:6: core
C:\documents\projects\plt\collects\mred\private\wx\common\queue.rkt:430:6
C:\documents\projects\plt\collects\mred\private\wx\common\queue.rkt:470:32
C:\documents\projects\plt\collects\mred\private\wx\common\queue.rkt:607:3
|#
(for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs)
(when color?

35
collects/lang/private/teach.rkt
View File

@ -227,10 +227,7 @@
;; Raise a syntax error:
(define (teach-syntax-error form stx detail msg . args)
(let (#;[form (if (eq? form '|function call|)
form
#f)] ; extract name from stx
[form (or form (first (flatten (syntax->datum stx))))]
(let ([form (or form (first (flatten (syntax->datum stx))))]
[msg (apply format msg args)])
(if detail
(raise-syntax-error form msg stx detail)
@ -329,7 +326,7 @@
(with-syntax ([(name ...) (if (eq? assign #t)
names
assign)]
[make-up (gensym)]
[made-up (gensym)]
[defn defn])
(with-syntax ([made-up-defn (stepper-syntax-property
(syntax (define made-up (lambda () (advanced-set! name 10) ...)))
@ -538,7 +535,7 @@
(teach-syntax-error
'define
stx
names
#f
"expected a name for the function, but nothing's there"))
(let loop ([names names][pos 0])
(unless (null? names)
@ -724,7 +721,7 @@
(teach-syntax-error
'lambda
rhs
(syntax args)
#f
"expected at least one variable (in parentheses) after lambda, but nothing's there")]
[_else 'ok])]
[_else 'ok]))
@ -975,7 +972,7 @@
(teach-syntax-error
'define-struct
stx
(syntax something)
#f
"expected at least one field name (in parentheses) after the structure name, but nothing's there")]
[(_)
(teach-syntax-error
@ -1073,11 +1070,17 @@
(map (lambda (stx)
(datum->syntax stx (string->symbol (format "~a?" (syntax->datum stx)))))
(syntax->list #'(name variant ...)))])
(syntax/loc stx
(begin (advanced-define (name? x)
(or (variant? x) ...))
(advanced-define-struct variant (field ...))
...)))]
;; Here we are using an explicit loop and the "/proc" functions instead of producing a syntax with "..."
;; to preserve the syntax location information.
(with-syntax ([the-definition (advanced-define/proc (syntax/loc stx (define (name? x) (or (variant? x) ...))))]
[(the-struct-definitions ...)
(map
(lambda (v)
(syntax-case v ()
[(variant field ...)
(advanced-define-struct/proc (syntax/loc stx (define-struct variant (field ...))))]))
(syntax->list #'((variant field ...) ...)))])
(syntax/loc stx (begin the-definition the-struct-definitions ...))))]
[(_ name_ (variant field ...) ... something . rest)
(teach-syntax-error
'define-datatype
@ -2384,7 +2387,7 @@
(teach-syntax-error
'set!
stx
(syntax id)
#f
"expected a variable after set!, but nothing's there")]
[_else (bad-use-error 'set! stx)])))))])
(values (proc #f)
@ -2804,7 +2807,7 @@
(teach-syntax-error
'shared
stx
(syntax a)
#f
"expected a variable for a binding, but nothing's there")]
[_else
(teach-syntax-error
@ -2841,7 +2844,7 @@
(teach-syntax-error
'shared
stx
(syntax bad-bind)
#f
"expected at least one binding (in parentheses) after shared, but nothing's there")]
[_else (bad-use-error 'shared stx)])

9
collects/tests/htdp-lang/htdp-test.rktl
View File

@ -64,7 +64,14 @@
#,(strip-context stx))
(lambda (x)
(and (exn:fail:syntax? x)
(regexp-match (if (string? rx) (regexp-quote rx) rx) (exn-message x)))))]))
(regexp-match (if (string? rx) (regexp-quote rx) rx) (exn-message x))
(let ([locs ((exn:srclocs-accessor x) x)])
(and (not (empty? locs))
(andmap (lambda (s) (and (srcloc-source s)
(regexp-match #rx"collects[/\\]tests" (srcloc-source s))
(srcloc-position s) (srcloc-span s)))
locs))))))]))
(require (only-in mzscheme
[let mz-let]