From f858b8bb5cb840e02684b16f46428100b9dbd047 Mon Sep 17 00:00:00 2001 From: Guillaume Marceau Date: Thu, 2 Jun 2011 17:34:46 -0400 Subject: [PATCH] Htdp no longer throws exceptions that have no source information --- collects/drracket/private/rep.rkt | 15 ----------- collects/lang/private/teach.rkt | 35 ++++++++++++++----------- collects/tests/htdp-lang/htdp-test.rktl | 9 ++++++- 3 files changed, 27 insertions(+), 32 deletions(-) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index f808d8da3a..146004bdad 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -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? diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index fa963858bd..baf0f7ca0c 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -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)]) diff --git a/collects/tests/htdp-lang/htdp-test.rktl b/collects/tests/htdp-lang/htdp-test.rktl index 9c665b49ec..e6e6008f11 100644 --- a/collects/tests/htdp-lang/htdp-test.rktl +++ b/collects/tests/htdp-lang/htdp-test.rktl @@ -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]