#lang racket/base
(require ffi/unsafe/try-atomic
         "queue.rkt")

(provide 
 call-as-nonatomic-retry-point
 (protect-out constrained-reply))

(define (internal-error str)
  (log-error
   (apply string-append
          (format "internal error: ~a" str)
          (append
           (for/list ([c (continuation-mark-set->context (current-continuation-marks))])
             (let ([name (car c)]
                   [loc (cdr c)])
               (cond
                [loc
                 (string-append
                  "\n"
                  (cond 
                   [(srcloc-line loc)
                    (format "~a:~a:~a" 
                            (srcloc-source loc)
                            (srcloc-line loc)
                            (srcloc-column loc))]
                   [else
                    (format "~a::~a" 
                            (srcloc-source loc)
                            (srcloc-position loc))])
                  (if name (format " ~a" name) ""))]
                [else (format "\n ~a" name)])))
           '("\n")))))

  FIXME : waiting 200msec is not a good enough rule .
(define (constrained-reply es thunk default 
                           #:fail-result [fail-result default])
  (cond
   [(not (can-try-atomic?))
    ;; Ideally, this would count as an error that we can fix. It seems that we
    ;; don't always have enough control to use the right eventspace with a
    ;; retry point, though, so just bail out with the default.
    #;(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk))
    fail-result]
   [(not (eq? (current-thread) (eventspace-handler-thread es)))
  Some events do n't get dispatched where expected on Mac OS . For example ,
    ;; a char-down and char-up event might be dequeued where the char-down event
    ;; closed a window, and then the char-up event can be dispatched to
    ;; a different window. So, don't complain in this case, either.
    #;(internal-error "wrong eventspace for constrained event handling\n")
    fail-result]
   [else
    (try-atomic thunk default)]))

 Ideally, this would count as an error that we can fix. It seems that we
 don't always have enough control to use the right eventspace with a
 retry point, though, so just bail out with the default.
(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk))
 a char-down and char-up event might be dequeued where the char-down event
 closed a window, and then the char-up event can be dispatched to
 a different window. So, don't complain in this case, either.
(internal-error "wrong eventspace for constrained event handling\n")
#lang racket/base
(require ffi/unsafe/try-atomic
         "queue.rkt")

(provide 
 call-as-nonatomic-retry-point
 (protect-out constrained-reply))

(define (internal-error str)
  (log-error
   (apply string-append
          (format "internal error: ~a" str)
          (append
           (for/list ([c (continuation-mark-set->context (current-continuation-marks))])
             (let ([name (car c)]
                   [loc (cdr c)])
               (cond
                [loc
                 (string-append
                  "\n"
                  (cond 
                   [(srcloc-line loc)
                    (format "~a:~a:~a" 
                            (srcloc-source loc)
                            (srcloc-line loc)
                            (srcloc-column loc))]
                   [else
                    (format "~a::~a" 
                            (srcloc-source loc)
                            (srcloc-position loc))])
                  (if name (format " ~a" name) ""))]
                [else (format "\n ~a" name)])))
           '("\n")))))

  FIXME : waiting 200msec is not a good enough rule .
(define (constrained-reply es thunk default 
                           #:fail-result [fail-result default])
  (cond
   [(not (can-try-atomic?))
    fail-result]
   [(not (eq? (current-thread) (eventspace-handler-thread es)))
  Some events do n't get dispatched where expected on Mac OS . For example ,
    fail-result]
   [else
    (try-atomic thunk default)]))
