teaching-langauge error message improvements

svn: r1197

collects/lang/private/contracts/contracts-module-begin.ss

@@ -2,13 +2,16 @@
   
   (require "contracts.ss")
   
-  (require-for-syntax (lib "list.ss"))
+  (require-for-syntax (lib "list.ss")
+		      (lib "boundmap.ss" "syntax"))
   
   (provide beginner-module-begin intermediate-module-begin advanced-module-begin)
   
-  (define-syntaxes (beginner-module-begin intermediate-module-begin advanced-module-begin)
+  (define-syntaxes (beginner-module-begin intermediate-module-begin advanced-module-begin
+					  beginner-continue intermediate-continue advanced-continue)
     (let ()
-      (define (parse-contracts language-level-contract language-level-define-data)
+      (define (parse-contracts language-level-contract language-level-define-data
+			       module-begin-continue-id)
 	;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to
 	;; a contract declaration. Syntax: (contract function-name (domain ... -> range))
 	(define extract-contracts
@@ -138,8 +141,8 @@
                    (syntax (begin ))
                    (raise-syntax-error 'contracts "this contract has no corresponding def" (car cnt-list)))]
               [else
-               ;      (let ([expanded (local-expand (car exprs) (syntax-local-context) local-expand-stop-list)])
+               (let ([expanded (car exprs)])
-               (let ([expanded (local-expand (car exprs) 'module local-expand-stop-list)])
+
                  (syntax-case expanded (begin define-values define-data)
                    [(define-values (func) e1 ...)
                     (contract-defined? cnt-list expanded)
@@ -156,15 +159,13 @@
                         (#,ll-define-data name c1 c2 ...)
                         #,(loop cnt-list (cdr exprs))))]
                    [(begin e1 ...)
-                    (loop cnt-list (append (syntax-e (syntax (e1 ...)))(cdr exprs)))]
+                    (loop cnt-list (append (syntax-e (syntax (e1 ...))) (cdr exprs)))]
-                   [_else 
+		   [_else 
-                    (quasisyntax/loc (car exprs)
+		    (quasisyntax/loc (car exprs)
-                      (begin
+		      (begin
-                        #,(car exprs)
+			#,(car exprs)
-                        #,(loop cnt-list (cdr exprs))))]))])))
+			#,(loop cnt-list (cdr exprs))))]))])))
 	
-
-
 	;; contract transformations!
 	;; this is the macro, abstracted over which language level we are using. 
 	;; parse-contracts : 
@@ -174,26 +175,76 @@
 	;; ====>>>> (lang-lvl-contract f (number -> number) ...)
 	;; where ll-contract is either beginner-contract, intermediate-contract, or advanced-contract
 	;; and (define-data name ....) to (lang-lvl-define-data name ...)
-	
+
-        (lambda (stx)
+	(values
-	  (syntax-case stx ()
+	 ;; module-begin (for a specific language:)
-	    [(_ e1 ...)
+	 (lambda (stx)
-	     (let* ([top-level (syntax-e (syntax (e1 ...)))]
+	   (syntax-case stx ()
-		    [cnt-list (extract-contracts top-level)]
+	     [(_ e1 ...)
-		    [expr-list (extract-not-contracts top-level)])
+	      ;; module-begin-continue takes a sequence of expanded
-	       (with-syntax ([rest (parse-contract-expressions language-level-contract
+	      ;; exprs and a sequence of to-expand exprs; that way,
-                                                               language-level-define-data
+	      ;; the module-expansion machinery can be used to handle
-                                                               cnt-list
+	      ;; requires, etc.:
-                                                               expr-list)])
+	      #`(#%plain-module-begin
-		 (syntax/loc stx (#%plain-module-begin rest))))])))
+		 (#,module-begin-continue-id () (e1 ...) ()))]))
+
+	 ;; module-continue (for a specific language:)
+	 (lambda (stx)
+	   (syntax-case stx ()
+	     [(_ (e1 ...) () (defined-id ...))
+	      ;; Local-expanded all body elements, lifted out requires, etc.
+	      ;; Now process the result.
+	      (begin
+		;; The expansion for contracts breaks the way that beginner-define, etc.,
+		;;  check for duplicate definitions, so we have to re-check here.
+		;; A better strategy might be to turn every define into a define-syntax
+		;;  to redirect the binding, and then the identifier-binding check in
+		;;  beginner-define, etc. will work.
+		(let ([defined-ids (make-bound-identifier-mapping)])
+		  (for-each (lambda (id)
+			      (when (bound-identifier-mapping-get defined-ids id (lambda () #f))
+				(raise-syntax-error
+				 #f
+				 "this name was defined previously and cannot be re-defined"
+				 id))
+			      (bound-identifier-mapping-put! defined-ids id #t))
+			    (reverse (syntax->list #'(defined-id ...)))))
+		;; Now handle contracts:
+		(let* ([top-level (reverse (syntax->list (syntax (e1 ...))))]
+		       [cnt-list (extract-contracts top-level)]
+		       [expr-list (extract-not-contracts top-level)])
+		  (parse-contract-expressions language-level-contract
+					      language-level-define-data
+					      cnt-list
+					      expr-list)))]
+	     [(_ e1s (e2 . e3s) def-ids)
+	      (let ([e2 (local-expand #'e2 'module local-expand-stop-list)])
+		;; Lift out certain forms to make them visible to the module
+		;;  expander:
+		(syntax-case e2 (require define-syntaxes define-values-for-syntax define-values begin)
+		  [(require . __)
+		   #`(begin #,e2 (_ e1s e3s def-ids))]
+		  [(define-syntaxes (id ...) . __)
+		   #`(begin #,e2 (_ e1s e3s (id ... . def-ids)))]
+		  [(define-values-for-syntax . __)
+		   #`(begin #,e2 (_ e1s e3s def-ids))]
+		  [(begin b1 ...)
+		   #`(_ e1s (b1 ... . e3s) def-ids)]
+		  [(define-values (id ...) . __)
+		   #`(_ (#,e2 . e1s) e3s (id ... . def-ids))]
+		  [else
+		   #`(_ (#,e2 . e1s) e3s def-ids)]))]))))
       
-      (define parse-beginner-contract/func 
+      (define-values (parse-beginner-contract/func continue-beginner-contract/func)
-        (parse-contracts #'beginner-contract #'beginner-define-data))
+        (parse-contracts #'beginner-contract #'beginner-define-data #'beginner-continue))
-      (define parse-intermediate-contract/func 
+      (define-values (parse-intermediate-contract/func continue-intermediate-contract/func)
-        (parse-contracts #'intermediate-contract  #'intermediate-define-data))
+        (parse-contracts #'intermediate-contract  #'intermediate-define-data #'intermediate-continue))
-      (define parse-advanced-contract/func
+      (define-values (parse-advanced-contract/func continue-advanced-contract/func)
-        (parse-contracts #'advanced-contract #'advanced-define-data))
+        (parse-contracts #'advanced-contract #'advanced-define-data #'advanced-continue))
     
       (values parse-beginner-contract/func
               parse-intermediate-contract/func
-              parse-advanced-contract/func))))
+              parse-advanced-contract/func
+	      continue-beginner-contract/func
+              continue-intermediate-contract/func
+              continue-advanced-contract/func))))

collects/tests/mzscheme/beg-adv.ss

@@ -65,6 +65,8 @@
 (htdp-test 9 'app-f (f 4))
 (htdp-top (define f2 (lambda (y) (+ x y))))
 (htdp-test 15 'app-f (f 10))
+(htdp-top-pop 1)
+(htdp-top-pop 1)
 
 (htdp-top (define-struct a0 ()))
 (htdp-top (define-struct a1 (b)))
@@ -145,18 +147,21 @@
 (htdp-error-test #'(define (an-example-structure x) 5))
 (htdp-error-test #'(define-struct an-example-structure (y)))
 (htdp-error-test #'(define-struct an-example (structure y)))
+(htdp-top-pop 1)
 
 (htdp-top (define an-example-value 12))
 (htdp-error-test #'(define an-example-value 5))
 (htdp-error-test #'(define (an-example-value x) 5))
 (htdp-error-test #'(define-struct an-example-value (y)))
 (htdp-error-test #'(define-struct an-example (value y)))
+(htdp-top-pop 1)
 
 (htdp-top (define (an-example-function x) x))
 (htdp-error-test #'(define an-example-function 5))
 (htdp-error-test #'(define (an-example-function x) 5))
 (htdp-error-test #'(define-struct an-example-function (y)))
 (htdp-error-test #'(define-struct an-example (function y)))
+(htdp-top-pop 1)
 
 (htdp-test #t 'equal? (equal? 1 1))
 (htdp-test #t 'equal? (equal? (list 1) (list 1)))
@@ -184,3 +189,18 @@
 (htdp-test #t 'equal~? (equal~? (make-a1 #i2.0) (make-a1 2) #i0.2))
 (htdp-test #f 'equal~? (equal~? (make-a1 #i2.3) (make-a1 2) #i0.2))
 
+(htdp-top-pop 1)
+(htdp-top-pop 1)
+(htdp-top-pop 1)
+
+;; Error messages
+(htdp-top (define my-x 5))
+(htdp-top (define (my-f x) (+ x 5)))
+(htdp-syntax-test #'(cond [true my-x 5]) #rx"found a clause with 3 parts")
+(htdp-syntax-test #'(define foo17 my-x 5) #rx"found one extra part")
+(htdp-syntax-test #'(my-y 17) #rx"not defined, not an argument, and not a primitive name")
+(htdp-syntax-test #'(cond [true my-y 17]) #rx"not defined, not an argument, and not a primitive name")
+(htdp-syntax-test #'(define my-f 12) #rx"cannot be re-defined")
+(htdp-syntax-test #'(define my-x 12) #rx"cannot be re-defined")
+(htdp-top-pop 1)
+(htdp-top-pop 1)

collects/tests/mzscheme/beg-bega.ss

@@ -23,4 +23,6 @@
 (htdp-error-test #'1)
 (htdp-top-pop 1)
 
-
+(htdp-top (define (my-f x) (+ x 5)))
+(htdp-syntax-test #'my-f #rx"a procedure, so it must be applied")
+(htdp-top-pop 1)

collects/tests/mzscheme/htdp-test.ss

@@ -1,8 +1,4 @@
 
-(define (htdp-syntax-test stx)
-  (syntax-test #`(module m #,current-htdp-lang
-		   #,stx)))
-
 (define body-accum null)
 (define-syntax (htdp-top stx)
   (syntax-case stx (quote)
@@ -14,6 +10,17 @@
 			 null
 			 (cons (car body-accum) (loop (cdr body-accum)))))))
 
+(define htdp-syntax-test
+  (case-lambda
+   [(stx) (htdp-syntax-test stx #rx".")]
+   [(stx rx)
+    (error-test #`(module m #,current-htdp-lang
+		    #,@body-accum
+		    #,stx)
+		(lambda (x)
+		  (and (exn:fail:syntax? x)
+		       (regexp-match rx (exn-message x)))))]))
+
 (define-syntax (htdp-test stx)
   (syntax-case stx ()
     [(_ expect f . args)