misc changes: flush io in make.ss, remove unused require in world.ss, improved test suite, made drscheme use new built-in srcloc debugging info provided by mzscheme

svn: r1708

collects/drscheme/private/debug.ss

@@ -227,14 +227,7 @@ profile todo:
                (orig-error-display-handler msg exn)])))
         debug-error-display-handler)
       
-      (define (show-error-and-highlight msg exn highlight-errors)
+      (define (print-bug-to-stderr msg cms)
-        (let* ([cms (and (exn? exn) 
-                         (continuation-mark-set? (exn-continuation-marks exn))
-                         (continuation-mark-set->list 
-                          (exn-continuation-marks exn)
-                          cm-key))])
-          (when (and cms
-                     (pair? cms))
         (let ([note% (if (mf-bday?) mf-note% bug-note%)])
           (when note%
             (let ([note (new note%)])
@@ -242,6 +235,17 @@ profile todo:
               (write-special note (current-error-port))
               (display #\space (current-error-port))))))
       
+      (define (show-error-and-highlight msg exn highlight-errors)
+        (let ([cms
+               (and (exn? exn) 
+                    (continuation-mark-set? (exn-continuation-marks exn))
+                    (continuation-mark-set->list 
+                     (exn-continuation-marks exn)
+                     cm-key))])
+          (when (and cms
+                     (pair? cms))
+            (print-bug-to-stderr msg cms))
+          
           (let ([srcs-to-display (find-src-to-display exn cms)])
             (for-each display-srcloc-in-error srcs-to-display)
             

collects/drscheme/private/drsig.ss

@@ -46,6 +46,7 @@
      make-debug-error-display-handler/text
      make-debug-eval-handler
      hide-backtrace-window
+     print-bug-to-stderr
      
      profile-definitions-text-mixin
      profile-tab-mixin

collects/drscheme/private/rep.ss

@@ -172,9 +172,25 @@ TODO
       ;; the highlight must be set after the error message, because inserting into the text resets
       ;;     the highlighting.
       (define (drscheme-error-display-handler msg exn)
-        (let ([src-locs (if (exn:srclocs? exn)
+        (let* ([srclocs-stack 
+                (filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn))))]
+               [stack 
+                (filter
+                 values
+                 (map (λ (srcloc)
+                        (let ([source (srcloc-source srcloc)]
+                              [pos (srcloc-position srcloc)]
+                              [span (srcloc-span srcloc)])
+                          (and source pos span
+                               (cons source (cons pos span)))))
+                      srclocs-stack))]
+               [src-locs (if (exn:srclocs? exn)
                              ((exn:srclocs-accessor exn) exn)
-                            '())])
+                             (if (null? stack)
+                                 '()
+                                 (list (car srclocs-stack))))])
+          (unless (null? stack)
+            (drscheme:debug:print-bug-to-stderr msg stack))
           (for-each drscheme:debug:display-srcloc-in-error src-locs)
           (display msg (current-error-port))
           (when (exn:fail:syntax? exn)
@@ -187,7 +203,9 @@ TODO
               (parameterize ([current-eventspace drscheme:init:system-eventspace])
                 (queue-callback
                  (λ ()
-                   (send rep highlight-errors/exn exn))))))))
+                   (send rep highlight-errors
+                         src-locs 
+                         (filter (λ (x) (is-a? (car x) text%)) stack)))))))))
       
       ;; drscheme-error-value->string-handler : TST number -> string
       (define (drscheme-error-value->string-handler x n)

collects/htdp/world.ss

@@ -2,8 +2,7 @@
 ;; Fri Dec  9 21:39:03 EST 2005: remoevd (update ... produce ...); added on-redraw 
 ;; Thu Dec  1 17:03:03 EST 2005: fixed place-image; all coordinates okay now
 (module world mzscheme
-  (require				; (lib "unitsig.ss")
+  (require
-   (lib "etc.ss")
    (lib "class.ss")
    (lib "mred.ss" "mred")
    (lib "error.ss" "htdp")

collects/make/make-unit.ss

@@ -99,7 +99,8 @@
 		      (when (and (make-print-checking)
 				 (or line
 				     (make-print-dep-no-line)))
-			(printf "make: ~achecking ~a~n" indent s))
+			(printf "make: ~achecking ~a~n" indent s)
+                        (flush-output))
 
 		      (if line
 			  (let ([deps (cadr line)])
@@ -134,6 +135,7 @@
 						   (format " because (reason: ~a date: ~a)" 
 							   reason date))])
 						""))
+                                    (flush-output)
 				    (with-handlers ([exn:fail?
 						     (lambda (exn)
 						       (raise (make-exn:fail:make 
@@ -161,7 +163,8 @@
 
 	  (for-each (lambda (item)
 		      (printf "make: made ~a~n" (path-string->string item)))
-		    (reverse made))))
+		    (reverse made))
+          (flush-output)))
 
       (define make/proc
 	(case-lambda

collects/tests/drscheme/io.ss

@@ -29,14 +29,16 @@ add this test:
         (clear-definitions drs-frame)
         (type-in-definitions drs-frame expression)
         (do-execute drs-frame)
-        (let* ([got (get-annotated-output)])
+        (let ([got (get-annotated-output)])
-          (unless (andmap (λ (exp got)
+          (unless (and (= (length expected)
+                          (length got))
+                       (andmap (λ (exp got)
                                  (and (string=? (car exp) (car got))
                                       (or (equal? (cadr exp) (cadr got))
                                           (and (procedure? (cadr exp))
                                                ((cadr exp) (cadr got))))))
                                expected 
-                          got)
+                               got))
             (fprintf (current-error-port)
                      "expected ~s, got ~s for ~s\n\n"
                      expected

collects/tests/drscheme/language-test.ss

@@ -1183,14 +1183,17 @@ the settings above should match r5rs
              (printf (make-err-msg defs-expected) 
                      'definitions (language) expression defs-expected got)))
          
+         (let ([s (make-semaphore 0)])
+           (queue-callback
+            (λ ()
               (send definitions-text select-all)
               (send definitions-text copy)
-         
               (send interactions-text set-position
                     (send interactions-text last-position)
                     (send interactions-text last-position))
-         
               (send interactions-text paste)
+              (semaphore-post s)))
+           (semaphore-wait s))
          
          (let ([last-para (send interactions-text last-paragraph)])
            (type-in-interactions drs (string #\newline))
@@ -1220,11 +1223,11 @@ the settings above should match r5rs
     (let ([drs (wait-for-drscheme-frame)])
       (fw:test:menu-select "Language" "Clear All Teachpacks"))
 
+    (go mred)
+    (go mzscheme)
     (go beginner)
     (go beginner/abbrev)
     (go intermediate)
     (go intermediate/lambda)
     (go advanced)
-    (go r5rs)
+    (go r5rs)))
-    (go mred)
-    (go mzscheme)))

collects/tests/drscheme/teachpack.ss

@@ -193,9 +193,9 @@
     (let* ([test-teachpack
             (lambda (dir)
               (lambda (teachpack)
-                (when (or (equal? "ss" (filename-extension teachpack))
+                (when (or (equal? #"ss" (filename-extension teachpack))
-                          (equal? "scm" (filename-extension teachpack)))
+                          (equal? #"scm" (filename-extension teachpack)))
-                  (unless (equal? "graphing.ss" teachpack)
+                  (unless (equal? "graphing.ss" (path->string teachpack))
                     (printf "  testing ~a~n" (build-path dir teachpack))
                     (let ([filename (normal-case-path (build-path dir teachpack))])
                       (fw:test:menu-select "Language" "Clear All Teachpacks")
@@ -212,7 +212,8 @@
                           (printf "       got: ~s~n  expected: ~s~n" got expected))))))))]
            [test-teachpacks
             (lambda (dir)
-              (for-each (test-teachpack dir) (directory-list dir)))]
+              (for-each (test-teachpack dir) 
+                        (directory-list dir)))]
            [teachpack-dir (normalize-path (build-path (collection-path "mzlib") 'up 'up "teachpack"))])
       (set-language-level! '("How to Design Programs" "Advanced Student"))
       (test-teachpacks teachpack-dir)