fixed implicit begin in type-case, added PLAI Void

svn: r814

collects/plai/plai-tool.ss

@@ -71,13 +71,16 @@ the default printing style shold be 'constructor instead of 'write
 	     '((lib "plai-beginner.ss" "plai") 
 	       (lib "plai-intermediate.ss" "plai") 
 	       (lib "plai-advanced.ss" "plai")
-	       (lib "plai-pretty-big.ss" "plai"))
+	       (lib "plai-pretty-big.ss" "plai")
+	       (lib "plai-void.ss" "plai"))
 	     '("PLAI - Beginning Student"
 	       "PLAI - Intermediate Student with lambda"
 	       "PLAI - Advanced Student"
-	       "PLAI - Pretty Big")
+	       "PLAI - Pretty Big"
-	     '((-500 0 0) (-500 0 1) (-500 0 3) (-500 0 4))
+	       "PLAI - Void")
+	     '((-500 0 0) (-500 0 1) (-500 0 3) (-500 0 4) (-500 0 5))
 	     '("PLAI: beginning students"
 	       "PLAI: beginner plus lexical scope and higher-order functions" 
 	       "PLAI: intermediate plus lambda and mutation"
-	       "PLAI: professional plt plus define-datatype"))))))
+	       "PLAI: PLT Pretty Big plus define-type"
+	       "PLAI: advanced without function arguments, lambda, or local"))))))

collects/plai/plai-void.ss

@@ -0,0 +1,40 @@
+(module plai-void mzscheme
+  (require (rename (lib "htdp-advanced.ss" "lang") plai-else else)
+	   (rename (lib "htdp-advanced.ss" "lang") advanced-define define)
+	   "private/datatype.ss"
+           "test-harness.ss")
+
+  ;; This macro requires & provides bindings without
+  ;;  making them locally visible:
+  (define-syntax (provide-void stx)
+    #'(begin
+	(require (all-except (lib "htdp-advanced.ss" "lang")
+			     lambda define local let let* letrec))
+	(provide (all-from-except (lib "htdp-advanced.ss" "lang")
+				  plai-else advanced-define))))
+  (provide-void)
+		   
+  (provide (rename void-define define)
+	   (rename void-type-case type-case)
+	   define-type
+	   require provide provide-type
+           (all-from "test-harness.ss"))
+
+  (define-syntax (void-define stx)
+    (syntax-case stx ()
+      [(_ id v)
+       (identifier? #'id)
+       #'(advanced-define id v)]
+      [(_ (id) body)
+       (identifier? #'id)
+       #'(advanced-define (id) (begin body (void)))]
+      [(_ (id x0 x ...) . rest)
+       (andmap identifier? (syntax->list #'(id x0 x ...)))
+       (raise-syntax-error
+	#f
+	"defined functions must accept no arguments in this language"
+	stx)]
+      [(_ . rest)
+       #'(advanced-define . rest)]))
+
+  (define-type-case void-type-case plai-else))

collects/plai/private/datatype-core.ss

@@ -334,7 +334,7 @@
   (define-syntax cases-core
     (lambda (stx)
       (syntax-case stx ()
-	[(_ orig-stx datatype-str cases-else
+	[(_ orig-stx datatype-str case-begin cases-else
 	    datatype expr 
 	    clause
 	    ...)
@@ -420,7 +420,9 @@
 						    (loop (cdr clauses) (cons orig-variant saw-cases))])
 					(values (cons vt vts)
 						(cons field-ids idss)
-						(cons (syntax (begin body0 body1 ...)) bodys)
+						(cons (with-syntax ([clause clause])
+							(syntax (case-begin orig-stx clause body0 body1 ...)))
+						      bodys)
 						else))))]
 				 [(else body0 body1 ...)
 				  (begin

collects/plai/private/datatype.ss

@@ -43,12 +43,23 @@
 	"expected an identifier for the type name"
 	stx)]))
   
+  (define-syntax (case-begin stx)
+    (syntax-case stx ()
+      [(_ orig-stx orig-clause expr) #'expr]
+      [(_ orig-stx orig-clause expr0 expr ...)
+       (raise-syntax-error
+	#f
+	(format "expected only one result expression, found ~a"
+		(add1 (length (syntax->list #'(expr ...)))))
+	#'orig-stx
+	#'orig-clause)]))
+
   (define-syntax define-type-case
     (syntax-rules ()
       [(_ type-case else)
        (define-syntax (type-case stx)
 	 (syntax-case stx ()
-	   [(_ . rest) #`(cases-core #,stx "type" else . rest)]))]))
+	   [(_ . rest) #`(cases-core #,stx "type" case-begin else . rest)]))]))
 
   (define-syntax (provide-type stx)
     (syntax-case stx ()