improved the implementation of error in the teaching languages, added test casees

svn: r17923

collects/lang/private/beginner-funs.ss

@@ -468,7 +468,7 @@
     ("Misc"
       (identity (any -> any)
 	"to return the argument unchanged")
-      ((beginner-error error) (any ... -> void) "to signal an error, turning the given values into an error message ")
+      ((beginner-error error) (any ... -> void) "to signal an error, combining the given values into an error message.\n\nIf any of the values' printed representations is too long, it is truncated and ``...'' is put into the string. If the first value is a symbol, it is treated specially; it is suffixed with a colon and a space (the intention is that the symbol is the name of the function signalling the error).")
       ((beginner-struct? struct?) (any -> boolean)
        "to determine whether some value is a structure")
       ((beginner-equal? equal?) (any any -> boolean)

collects/lang/private/teachprims.ss

@@ -2,7 +2,7 @@
 collects/tests/mzscheme/beginner.ss
                     .../beginner-abbr.ss
                     .../intermediate.ss
-                    .../intermediate-lam.ss
+                    .../intermediate-lambda.ss
                     .../advanced.ss
 
 Each one has to run separately, since they mangle the top-level
@@ -197,25 +197,13 @@ namespace.
       (if (and (cons? stuff0) (symbol? (first stuff0)))
           (values (first stuff0) (rest stuff0))
           (values false stuff0)))
-    (define str
+    (error (apply
-      (let loop ([stuff stuff1][frmt ""][pieces '()])
+            string-append
-        (cond
+            (if f (format "~a: " f) "")
-          [(empty? stuff) (apply format frmt (reverse pieces))]
+            (for/list ([ele (in-list stuff1)])
-          [else 
+              (if (string? ele)
-           (let ([f (first stuff)]
+                  ele
-                 [r (rest stuff)])
+                  (format "~e" ele)))))))
-             (if (string? f)
-                 (loop r (string-append frmt f) pieces)
-                 (loop r (string-append frmt "~e") (cons f pieces))))])))
-    (if f (error f str) (error str)))
-  #;
-  (lambda (str)
-    (unless (string? str)
-      (raise
-       (make-exn:fail:contract
-        (format "error: expected a string, got ~e and ~e" str)
-        (current-continuation-marks))))
-    (error str)))
 
 (define-teach beginner struct?
   (lambda (x)

collects/tests/mzscheme/beg-adv.ss

@@ -387,6 +387,15 @@
 (htdp-test false 'string-lower-case? (string-lower-case? "ab\t"))
 (htdp-test true 'string-lower-case? (string-lower-case? "abc"))
 
+(htdp-err/rt-test (error "a" "a") #rx"^aa$")
+(htdp-err/rt-test (error 'a "a") #rx"^a: a$")
+(htdp-err/rt-test (error "This is" " an err" "or" " message with a number: " 5)
+                  #rx"^This is an error message with a number: 5$")
+(htdp-err/rt-test (error "several numbers " 1 2 3 4 5 6 7)
+                  #rx"^several numbers 1234567$")
+(htdp-err/rt-test (error "several numbers " 1 " 2 " 3 " 4")
+                  #rx"^several numbers 1 2 3 4$")
+
 (htdp-top (require scheme/match))
 (htdp-test 17 'match (match 'x ['x 17]))
 (htdp-test 'x 'match (match 'x ['y 17][z z]))

collects/tests/mzscheme/htdp-test.ss

@@ -94,7 +94,7 @@
      #'(void)]))
 
 (define (htdp-string-to-pred exn?/rx)
-  (if (string? exn?/rx)
+  (if (or (regexp? exn?/rx) (string? exn?/rx))
       (lambda (x)
 	(regexp-match exn?/rx (exn-message x)))
       exn?/rx))