From 00ce8904c7fe246971c924e22778ff27605d55db Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 23 Jan 2021 09:08:57 -0700 Subject: [PATCH] repair `prop:exn:srcloc` handling For CS, the default error display handler was not using `prop:exn:srcloc`. For BC, a bad `prop:exn:srcloc` that returned a value other than a list of srclocs coudl cause a crash. Related to #3645 --- .../racket-test-core/tests/racket/srcloc.rktl | 30 ++++++++++++++++ racket/src/bc/src/error.c | 10 ++++-- racket/src/cs/io.sls | 4 ++- racket/src/cs/rumble/error.ss | 35 +++++++++++++++++-- 4 files changed, 74 insertions(+), 5 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/srcloc.rktl b/pkgs/racket-test-core/tests/racket/srcloc.rktl index 539e57212b..a79f6618df 100644 --- a/pkgs/racket-test-core/tests/racket/srcloc.rktl +++ b/pkgs/racket-test-core/tests/racket/srcloc.rktl @@ -308,4 +308,34 @@ (test (srcloc 'm 1 2 3 0) build-source-location (srcloc 'm #f #f #f 0) (srcloc 'm 1 2 3 0)) +(err/rt-test (let () + (struct a () #:property prop:exn:srclocs 'no) + 'not-ok)) + +;; Check that the error display handler uses `prop:exn:srclocs`: +(let () + (struct a exn:fail (srclocs) + #:property prop:exn:srclocs (lambda (a) (a-srclocs a))) + (define (go a #:catch? [catch? #f]) + (define o (open-output-bytes)) + ((if catch? + (lambda (thunk) + (let/ec k + (parameterize ([error-escape-handler (lambda () (k))]) + (thunk)))) + (lambda (thunk) (thunk))) + (lambda () + (parameterize ([current-error-port o]) + ((error-display-handler) "fail" a)))) + (get-output-bytes o)) + (test #t regexp-match? #rx"here:1:2" (go (a "msg" (current-continuation-marks) + (list (srcloc "here" 1 2 3 4))))) + (test #t regexp-match? #rx"there:10:20" (go (a "msg" (current-continuation-marks) + (list (srcloc "here" 1 2 3 4) + (srcloc "there" 10 20 30 40))))) + (test #t regexp-match? #rx"listof srcloc[?]" (go (a "msg" (current-continuation-marks) + 'oops) + #:catch? #t)) + (void)) + (report-errs) diff --git a/racket/src/bc/src/error.c b/racket/src/bc/src/error.c index 64e0bcea20..ce0c245a4f 100644 --- a/racket/src/bc/src/error.c +++ b/racket/src/bc/src/error.c @@ -3177,9 +3177,15 @@ def_error_display_proc(int argc, Scheme_Object *argv[]) /* Print srcloc(s) if present */ l = scheme_struct_type_property_ref(scheme_source_property, argv[1]); - if (l) + if (l) { l = _scheme_apply(l, 1, &(argv[1])); - + for (w = l; SCHEME_PAIRP(w); w = SCHEME_CDR(w)) { + if (!scheme_is_location(SCHEME_CAR(w))) + break; + } + if (!SCHEME_NULLP(w)) + scheme_wrong_contract("prop:exn:srclocs procedure", "(listof srcloc?)", -1, 1, &l); + } if (l && !SCHEME_NULLP(l)) { /* Some exns include srcloc in the msg, so skip the first srcloc of those when needed */ diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index a368a46df6..93d27afa29 100644 --- a/racket/src/cs/io.sls +++ b/racket/src/cs/io.sls @@ -582,7 +582,9 @@ (set-log-system-message! (lambda (level str) (1/log-message (|#%app| 1/current-logger) level str #f))) (set-error-display-eprintf! (lambda (fmt . args) - (apply 1/fprintf (|#%app| 1/current-error-port) fmt args))) + (apply 1/fprintf (|#%app| 1/current-error-port) fmt args)) + 1/srcloc->string + 1/error-print-source-location) (set-ffi-get-lib-and-obj! ffi-get-lib ffi-get-obj ffi-unload-lib ptr->address) (set-make-async-callback-poll-wakeup! unsafe-make-signal-received) (set-get-machine-info! get-machine-info) diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index 2bf488ac4c..5a952bf1e7 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -701,12 +701,32 @@ (and (exn? v) (not (exn:fail:user? v)))) (let* ([n (|#%app| error-print-context-length)] + [locs (if (exn:srclocs? v) + ((exn:srclocs-accessor* v) v) + null)] [l (if (zero? n) '() (traces->context (if (exn? v) (continuation-mark-set-traces (exn-continuation-marks v)) (list (continuation->trace (condition-continuation v))))))]) + (unless (null? locs) + (unless (and (list? locs) + (andmap srcloc? locs)) + (raise-result-error '|prop:exn:srclocs procedure| "(listof srcloc?)" locs)) + (let ([locs + ;; Some exns are expected to include srcloc in the msg, + ;; so skip the first srcloc of those + (if (and (or (exn:fail:read? v) + (exn:fail:contract:variable? v)) + (error-print-source-location)) + (cdr locs) + locs)]) + (unless (null? locs) + (eprintf "\n location...:") + (#%for-each (lambda (sl) + (eprintf (string-append "\n " (srcloc->string sl)))) + locs)))) (unless (null? l) (eprintf "\n context...:") (let loop ([l l] @@ -743,11 +763,22 @@ (lambda (fmt . args) (apply fprintf (current-error-port) fmt args))) +(define srcloc->string + (lambda (srcloc) + (#%format "~s" srcloc))) + +(define error-print-source-location + (lambda () #f)) + (define (emergency-error-display-handler msg v) (log-system-message 'error msg)) -(define (set-error-display-eprintf! proc) - (set! eprintf proc)) +(define (set-error-display-eprintf! proc + srcloc->string-proc + error-print-source-location-proc) + (set! eprintf proc) + (set! srcloc->string srcloc->string-proc) + (set! error-print-source-location error-print-source-location-proc)) (define (default-error-escape-handler) (abort-current-continuation (default-continuation-prompt-tag) void))