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

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)

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 */

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)

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))