fixed a bug in check syntax and a bug in the contract system

svn: r9524

collects/drscheme/syncheck.ss

@@ -2295,7 +2295,9 @@ If the namespace does not, they are colored the unbound color.
     ;; colors the syntax with style-name's style
     (define (color source-editor-cache stx style-name)
       (let ([source (find-source-editor source-editor-cache stx)])
-        (when (is-a? source text%)
+        (when (and (is-a? source text%)
+                   (syntax-position stx)
+                   (syntax-span stx))
           (let ([pos (- (syntax-position stx) 1)]
                 [span (syntax-span stx)])
             (color-range source pos (+ pos span) style-name)))))

collects/scheme/private/contract-arrow.ss

@@ -899,15 +899,7 @@ v4 todo:
                                (cond
                                  [(not rng) #f]
                                  [(box? rng) 
-                                  (map (λ (val)
-                                         (keyword-apply
-                                          val
-                                          kwd-args
-                                          kwd-arg-vals
-                                          (append 
-                                           ;; this parameter (if necc.)
-                                           (if (->d-mtd? ->d-stct) (list (car raw-orig-args)) '())
-                                           orig-args)))
+                                  (map (λ (val) (apply val dep-pre-args))
                                        (unbox rng))]
                                  [else rng]))]
                         [rng-underscore? (box? (->d-range ->d-stct))])

collects/tests/drscheme/syncheck-test.ss

@@ -829,7 +829,7 @@
                     #f)))
   
   (define (run-test)
-    (check-language-level #rx"Graphical")
+    (check-language-level #rx"Pretty")
     (let* ([drs (wait-for-drscheme-frame)]
            [defs (send drs get-definitions-text)]
            [filename (make-temporary-file "syncheck-test~a")])

collects/tests/mzscheme/contract-test.ss

@@ -1642,6 +1642,22 @@
       x)
    '(ctc body))
   
+  (test/spec-passed/result
+   '->d-underscore4
+   '((contract (->d ([str any/c]) () #:rest rest (listof any/c) [_ any/c])
+               (λ (x . y) (cons x y))
+               'pos 'neg)
+     1 2 3)
+   '(1 2 3))
+  
+  (test/spec-passed/result
+   '->d-underscore5
+   '((contract (->d ([str any/c]) () #:rest rest (listof any/c) [_ any/c])
+               (λ (x . y) (cons x y))
+               'pos 'neg)
+     1 2 3 4 5)
+   '(1 2 3 4 5))
+  
 ;                                               
 ;                                               
 ;