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

Handle 0 and 1 cases better.

Browse Source 
Use sync to avoid sleeping.

svn: r9407
This commit is contained in:
Sam Tobin-Hochstadt 2008-04-22 22:05:33 +00:00
parent 2ecee0968c
commit 3d020b33fd
1 changed files with 13 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/typed-scheme/private/tc-utils.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(provide (all-defined-out)) (provide (all-defined-out))
(require "syntax-traversal.ss" (for-syntax scheme/base)) (require "syntax-traversal.ss" (for-syntax scheme/base) scheme/match)
;; a parameter representing the original location of the syntax being currently checked ;; a parameter representing the original location of the syntax being currently checked
(define current-orig-stx (make-parameter #'here)) (define current-orig-stx (make-parameter #'here))
@ -43,13 +43,17 @@
(define-struct err (msg stx) #:prefab) (define-struct err (msg stx) #:prefab)
(define (report-all-errors) (define (report-all-errors)
(define stxs (match (reverse delayed-errors)
[(list) (void)]
[(list (struct err (msg stx)))
(raise-typecheck-error msg stx)]
[l
(let ([stxs
(for/list ([e (reverse delayed-errors)]) (for/list ([e (reverse delayed-errors)])
(thread (lambda () (raise-typecheck-error (err-msg e) (err-stx e)))) (sync (thread (lambda () (raise-typecheck-error (err-msg e) (err-stx e)))))
(sleep .01) (err-stx e))])
(err-stx e)))
(unless (null? stxs) (unless (null? stxs)
(raise-typecheck-error "Errors encountered" (apply append stxs)))) (raise-typecheck-error "Errors encountered" (apply append stxs))))]))
(define (tc-error/delayed msg #:stx [stx (current-orig-stx)] . rest) (define (tc-error/delayed msg #:stx [stx (current-orig-stx)] . rest)
(set! delayed-errors (cons (make-err (apply format msg rest) (list (locate-stx stx))) delayed-errors))) (set! delayed-errors (cons (make-err (apply format msg rest) (list (locate-stx stx))) delayed-errors)))