From 98488a89efcc5aa2a0e401a7bbf4664a8b2352cb Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 22 Oct 2009 18:45:02 +0000 Subject: [PATCH] DrDr bugs and spurious errors svn: r16412 --- .../raw-problems/build-solution-sets.ss | 24 +++++----- collects/readline/mzrl.ss | 6 +-- collects/tests/mred/testing.ss | 6 +-- .../tests/mzscheme/cache-image-snip-test.ss | 48 +++++++++---------- collects/wxme/xml.ss | 15 +++--- 5 files changed, 49 insertions(+), 50 deletions(-) diff --git a/collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss b/collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss index 3de1fa9f5a..5522bc2075 100644 --- a/collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss +++ b/collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss @@ -28,8 +28,8 @@ The col and row type specs are in sig.ss and the solution type is: (prefix solve: "../solve.ss")) (if (equal? (vector) argv) - (fprintf (current-error-port) "pass any command line argument to skip the solver~n~n") - (fprintf (current-error-port) "skipping the solver~n")) + (printf "pass any command line argument to skip the solver~n~n") + (printf "skipping the solver~n")) (define memory-limit (* 1024 1024 400)) ;; in bytes (500 megs) @@ -156,12 +156,12 @@ The col and row type specs are in sig.ss and the solution type is: (let loop ([n (- progress-bar-max dots-printed)]) (cond [(zero? n) (void)] - [else (display "." (current-error-port)) + [else (display ".") (loop (- n 1))])) - (newline (current-error-port))] + (newline)] [else (let ([dots-to-print (floor (- (* progress-bar-max (/ counter (- max 1))) dots-printed))]) - '(fprintf (current-error-port) "~spercentage: ~a ~a ~a ~a~n" + '(printf "~spercentage: ~a ~a ~a ~a~n" cleanup dots-to-print counter @@ -172,19 +172,19 @@ The col and row type specs are in sig.ss and the solution type is: (cond [(zero? n) (void)] [else - (display "." (current-error-port)) + (display ".") (loop (- n 1))])) - (flush-output (current-error-port)))])))) + (flush-output))])))) (define (setup-progress max cleanup) - (display guide-string (current-error-port)) - (newline (current-error-port)) + (display guide-string) + (newline) (build-progress-outputer max cleanup)) (define (solve name rows cols) (cond [(equal? argv (vector)) - (fprintf (current-error-port) "Solving ~s; memory limit ~a~n" + (printf "Solving ~s; memory limit ~a~n" name (format-memory-txt memory-limit)) (let ([row-count (length rows)] [col-count (length cols)]) @@ -240,8 +240,8 @@ The col and row type specs are in sig.ss and the solution type is: (update-memory-display) (semaphore-post done)))]) (semaphore-wait done) - (newline (current-error-port)) - (newline (current-error-port)) + (newline) + (newline) (if sucessful? board #f))] diff --git a/collects/readline/mzrl.ss b/collects/readline/mzrl.ss index 7bc9af192b..1c29813f58 100644 --- a/collects/readline/mzrl.ss +++ b/collects/readline/mzrl.ss @@ -110,11 +110,9 @@ ;; need to capture the real input port below (define real-input-port (current-input-port)) (unless (eq? 'stdin (object-name real-input-port)) - (fprintf (current-error-port) - "mzrl warning: could not capture the real input port\n")) + (log-warning "mzrl warning: could not capture the real input port\n")) (unless (terminal-port? real-input-port) - (fprintf (current-error-port) - "mzrl warning: input port is not a terminal\n")) + (log-warning "mzrl warning: input port is not a terminal\n")) ;; make it possible to run Scheme threads while waiting for input (set-ffi-obj! "rl_event_hook" libreadline (_fun -> _int) diff --git a/collects/tests/mred/testing.ss b/collects/tests/mred/testing.ss index d5e562273a..4c951546eb 100644 --- a/collects/tests/mred/testing.ss +++ b/collects/tests/mred/testing.ss @@ -12,7 +12,7 @@ (set! test-count (add1 test-count)) (unless (equal? expect got) (let ([s (format "~a: expected ~e; got ~e" name expect got)]) - (printf "ERROR: ~a~n" s) + (fprintf (current-error-port) "ERROR: ~a~n" s) (set! errs (cons s errs))))) (define-syntax mismatch @@ -53,9 +53,9 @@ (if (null? errs) (printf "Passed all ~a tests~n" test-count) (begin - (printf "~a Error(s) in ~a tests~n" (length errs) test-count) + (fprintf (current-error-port) "~a Error(s) in ~a tests~n" (length errs) test-count) (for-each (lambda (s) - (printf "~a~n" s)) + (fprintf (current-error-port) "~a~n" s)) (reverse errs))))) diff --git a/collects/tests/mzscheme/cache-image-snip-test.ss b/collects/tests/mzscheme/cache-image-snip-test.ss index 3e74efb040..88606410bf 100644 --- a/collects/tests/mzscheme/cache-image-snip-test.ss +++ b/collects/tests/mzscheme/cache-image-snip-test.ss @@ -12,11 +12,11 @@ (overlay-bitmap argb dx dy b1 b2) (argb-vector argb)) - (let ([argb (make-argb (vector 100 10 20 30) 1)] + (let ([argb (make-argb (vector 100 10 20 30) 1 1)] [bm (build-bitmap void 1 1)]) (test #(100 10 20 30) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 4 0) 1)] + (let ([argb (make-argb (make-vector 4 0) 1 1)] [bm (build-bitmap (lambda (dc) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -24,7 +24,7 @@ 1 1)]) (test #4(0) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 4 100) 1)] + (let ([argb (make-argb (make-vector 4 100) 1 1)] [bm (build-bitmap (lambda (dc) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -32,11 +32,11 @@ 1 1)]) (test #4(0) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 8 254) 1)] + (let ([argb (make-argb (make-vector 8 254) 1 1)] [bm (build-bitmap void 1 2)]) (test #8(254) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 8 0) 1)] + (let ([argb (make-argb (make-vector 8 0) 1 1)] [bm (build-bitmap (lambda (dc) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -44,7 +44,7 @@ 1 2)]) (test #8(0) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 16 100) 2)] + (let ([argb (make-argb (make-vector 16 100) 2 2)] [bm (build-bitmap (lambda (dc) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -56,7 +56,7 @@ 100 100 100 100) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 16 100) 2)] + (let ([argb (make-argb (make-vector 16 100) 2 2)] [bm (build-bitmap (lambda (dc) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -68,7 +68,7 @@ 100 100 100 100) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 16 100) 2)] + (let ([argb (make-argb (make-vector 16 100) 2 2)] [bm (build-bitmap (lambda (dc) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -80,7 +80,7 @@ 100 100 100 100) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 16 100) 2)] + (let ([argb (make-argb (make-vector 16 100) 2 2)] [bm (build-bitmap (lambda (dc) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -92,7 +92,7 @@ 0 0 0 0) overlay-bitmap/ret argb 0 0 bm bm)) - (let ([argb (make-argb (make-vector 4 200) 1)] + (let ([argb (make-argb (make-vector 4 200) 1 1)] [c (build-bitmap (lambda (dc) (send dc set-pen @@ -106,7 +106,7 @@ 1 1)]) (test #4(0 0 0 100) overlay-bitmap/ret argb 0 0 c m)) - (let ([argb (make-argb (make-vector 4 200) 1)] + (let ([argb (make-argb (make-vector 4 200) 1 1)] [c (build-bitmap (lambda (dc) (send dc set-pen @@ -120,7 +120,7 @@ 1 1)]) (test #4(0 0 100 0) overlay-bitmap/ret argb 0 0 c m)) - (let ([argb (make-argb (make-vector 4 200) 1)] + (let ([argb (make-argb (make-vector 4 200) 1 1)] [c (build-bitmap (lambda (dc) (send dc set-pen @@ -134,7 +134,7 @@ 1 1)]) (test #4(0 100 0 0) overlay-bitmap/ret argb 0 0 c m)) - (let ([argb (make-argb (make-vector (* 2 2 4) 200) 2)] + (let ([argb (make-argb (make-vector (* 2 2 4) 200) 2 2)] [bm (build-bitmap (lambda (dc) (send dc set-pen @@ -148,7 +148,7 @@ 1 0 bm bm)) - (let ([argb (make-argb (make-vector (* 2 2 4) 200) 2)] + (let ([argb (make-argb (make-vector (* 2 2 4) 200) 2 2)] [bm (build-bitmap (lambda (dc) (send dc set-pen @@ -173,7 +173,7 @@ [get-one (lambda (bm) (let ([dc (make-object bitmap-dc% bm)] - [str (make-string (* 4 w h) #\000)]) + [str (make-bytes (* 4 w h) 0)]) (send dc get-argb-pixels 0 0 w h str) (send dc set-bitmap #f) str))]) @@ -181,17 +181,17 @@ (get-one (send main-bm get-loaded-mask))) (get-one main-bm)))) - (test '("\377\377\377\377" "\377\377\377\377") argb->bitmap->string (make-argb #(255 255 255 255) 1)) - (test '("\377\377\377\377" "\377\0\0\0") argb->bitmap->string (make-argb #(255 0 0 0) 1)) - (test '("\377\1\1\1" "\377\100\100\100") argb->bitmap->string (make-argb #(1 64 64 64) 1)) - (test '("\377\001\001\001\377\010\010\010\377\377\377\377\377\000\000\000" - "\377\100\100\100\377\001\010\100\377\377\377\377\377\000\000\000") + (test '(#"\377\377\377\377" #"\377\377\377\377") argb->bitmap->string (make-argb #(255 255 255 255) 1 1)) + (test '(#"\377\377\377\377" #"\377\0\0\0") argb->bitmap->string (make-argb #(255 0 0 0) 1 1)) + (test '(#"\377\1\1\1" #"\377\100\100\100") argb->bitmap->string (make-argb #(1 64 64 64) 1 1)) + (test '(#"\377\001\001\001\377\010\010\010\377\377\377\377\377\000\000\000" + #"\377\100\100\100\377\001\010\100\377\377\377\377\377\000\000\000") argb->bitmap->string (make-argb #(1 64 64 64 8 1 8 64 255 255 255 255 0 0 0 0) - 2)) + 2 2)) (define (show-bitmap bm mask title) (define f (new frame% (label title) (width 200) (height 200))) @@ -212,7 +212,7 @@ [w 100] [h 30] [argb-vector (make-vector (* w h 4) 0)] - [argb (make-argb argb-vector w)] + [argb (make-argb argb-vector w h)] [c1 (build-bitmap (lambda (dc) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -280,8 +280,8 @@ (show-bitmap new-bitmap #f "difference")) (let* ([argb-bitmap (flatten-bitmap (argb->bitmap argb))] - [argb-ents (map char->integer (string->list (cadr (bitmap->string argb-bitmap))))] - [bitmap-ents (map char->integer (string->list (cadr (bitmap->string final))))]) + [argb-ents (bytes->list (cadr (bitmap->string argb-bitmap)))] + [bitmap-ents (bytes->list (cadr (bitmap->string final)))]) (test #t (lambda (x) x) (andmap (lambda (x y) (<= (abs (- x y)) 3)) argb-ents bitmap-ents)))) diff --git a/collects/wxme/xml.ss b/collects/wxme/xml.ss index ddb2547e29..c1218b36ae 100644 --- a/collects/wxme/xml.ss +++ b/collects/wxme/xml.ss @@ -20,13 +20,14 @@ (read-editor-snip text? vers stream elim-whitespace? xml-editor%))) (define/override (generate-special editor src line col pos) - (let* ([port (send editor get-content-port)] - [xml (read-xml port)] - [xexpr (xml->xexpr (document-element xml))] - [clean-xexpr (if (send editor get-data) - (eliminate-whitespace-in-empty-tags xexpr) - xexpr)]) - (list 'quasiquote clean-xexpr))) + (parameterize ([permissive-xexprs #t]) + (let* ([port (send editor get-content-port)] + [xml (read-xml port)] + [xexpr (xml->xexpr (document-element xml))] + [clean-xexpr (if (send editor get-data) + (eliminate-whitespace-in-empty-tags xexpr) + xexpr)]) + (list 'quasiquote clean-xexpr)))) (super-new))))