variant constructors bound to syntax

svn: r875

collects/plai/plai-dynamic.ss

@@ -0,0 +1,122 @@
+
+;; Like PLAI advanced, but with dynamic scope.
+;; No `let', `let*', or `letrec'.
+;;`local' expects ;;  all definitions to have the
+;;  form `(define id expr)'.
+
+(module plai-dynamic 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-advanced stx)
+    #'(begin
+	(require (all-except (lib "htdp-advanced.ss" "lang")
+			     #%top define local let let* letrec lambda))
+	(provide (all-from-except (lib "htdp-advanced.ss" "lang")
+				  plai-else advanced-define))))
+  (provide-advanced)
+
+  (define-for-syntax (make-dynamic k)
+    (make-set!-transformer
+     (lambda (stx)
+       (syntax-case stx (set!)
+	 [id
+	  (identifier? #'id)
+	  #'(lookup-dynamic 'id)]
+	 [(set! id val)	    
+	  #'(set-dynamic! 'id val)]
+	 [(id expr ...)
+	  #'((lookup-dynamic 'id) expr ...)]))))
+
+  (define-syntax to-dynamic
+    (syntax-rules ()
+      [(_ (id ...) expr)
+       (with-continuation-mark*
+	('id ...) ((box id) ...)
+	(let-syntax ([id (make-dynamic (quote-syntax id))]
+		     ...)
+	  expr))]))
+  
+  (define-syntax (dynamic-type-case stx)
+    (syntax-case stx ()
+      [(_ type expr
+	  [id (param ...) body-expr]
+	  ...)
+       #'(advanced-type-case 
+	  type expr
+	  [id (param ...) 
+	      (to-dynamic (param ...)
+			  body-expr)] ...)]
+      [(_ . rest)
+       #'(advanced-type-case . rest)]))
+
+  (define-syntax (dynamic-define stx)
+    (syntax-case stx ()
+      [(_ (id arg ...) body-expr)
+       #'(advanced-define (id arg ...)
+			  (to-dynamic
+			   (arg ...)
+			   body-expr))]
+      [(_ . rest)
+       #'(advanced-define . rest)]))
+
+  (define-syntax (dynamic-lambda stx)
+    (syntax-case stx ()
+      [(_ (id ...) expr)
+       #'(lambda (id ...)
+	   (to-dynamic (id ...)
+		       expr))]))
+
+  (define-syntax (dynamic-local stx)
+    (syntax-case stx (dynamic-define)
+      [(_ [(dynamic-define id val) ...] body-expr)
+       (andmap identifier? (syntax->list #'(id ...)))
+       #'(let [(id val) ...]
+	   (to-dynamic (id ...)
+		       body-expr))]))
+  
+  (define-syntax (dynamic-top stx)
+    (syntax-case stx ()
+      [(_ . id)
+       (identifier? #'id)
+       #'(lookup-dynamic 'id)]))
+
+  (define (lookup-dynamic id)
+    (let ([v (continuation-mark-set-first #f id)])
+      (if v
+	  (unbox v)
+	  (namespace-variable-value id #f (lambda ()
+					    (error 'eval
+						   "no dynamic value for identifier: ~a"
+						   id))))))
+
+  (define (set-dynamic! id val)
+    (let ([v (continuation-mark-set-first #f id)])
+      (if v
+	  (set-box! v val)
+	  (namespace-set-variable-value! id val))))
+
+  (define-syntax with-continuation-mark*
+    (syntax-rules ()
+      [(_ () () expr) expr]
+      [(_ (key . krest) (val . vrest) expr)
+       (with-continuation-mark key val
+	 (with-continuation-mark* krest vrest expr))]))
+
+  (provide (rename dynamic-type-case type-case)
+	   (rename dynamic-define define)
+	   (rename dynamic-lambda lambda)
+	   (rename dynamic-local local)
+	   (rename dynamic-top #%top)
+	   define-type
+	   require provide provide-type
+           (all-from "test-harness.ss")
+
+	   ;; Hack to avoid certification bug :(
+	   lookup-dynamic)
+
+  (define-type-case advanced-type-case plai-else))

collects/plai/plai-tool.ss

@@ -71,16 +71,13 @@ 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")
-	       "PLAI - Void")
+	     '((-500 0 0) (-500 0 1) (-500 0 3) (-500 0 4))
-	     '((-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: PLT Pretty Big plus define-type"
+	       "PLAI: PLT Pretty Big plus define-type"))))))
-	       "PLAI: advanced without function arguments, lambda, or local"))))))

collects/plai/plai-void.ss

@@ -1,3 +1,9 @@
+
+;; Like PLAI Advanced, but all functions must accept one
+;;  argument, and the result is always changed to void.
+;; To enforce void returns, tail call are broken, currently.
+;; No `lambda', `local', `let', `let*', or `letrec'.
+
 (module plai-void mzscheme
   (require (rename (lib "htdp-advanced.ss" "lang") plai-else else)
 	   (rename (lib "htdp-advanced.ss" "lang") advanced-define define)

collects/plai/private/core-utils.ss

@@ -1,6 +1,7 @@
 
 (module core-utils mzscheme
-
+  (require-for-template mzscheme)
+  
   (define-values (struct:dt make-dt dt? dt-selector dt-accessor)
     (make-struct-type 'dt #f 3 0 #f null (current-inspector)	       
 		      (lambda (dt stx)
@@ -13,6 +14,43 @@
   (define dt-kind (make-struct-field-accessor dt-selector 2 'kind))
 		  
   (define-struct vt (name-stx predicate-stx accessor-stx selector-stxes field-count))
+
+  (define-values (struct:dtvt make-dtvt dtvt? dtvt-selector dtvt-accessor)
+    (make-struct-type 'dtvt #f 3 0 #f null (current-inspector)       
+		      (lambda (dtvt stx)
+			(syntax-case stx (set!)
+			  [(set! id v)
+			   (raise-syntax-error 
+			    #f
+			    "cannot assign to a variant name"
+			    stx
+			    #'id)]
+			  [(id . args)
+			   (let ([v (syntax-local-value (dtvt-orig-id dtvt)
+							(lambda () #f))])
+			     (if (and (procedure? v)
+				      (procedure-arity-includes? v 1))
+				 ;; Apply macro binding for orig id to this id:
+				 (v stx)
+				 ;; Orig id is not bound to a macro:
+				 (datum->syntax-object
+				  stx
+				  (cons (dtvt-orig-id dtvt)
+					(syntax args))
+				  stx)))]
+			  [else
+			   (let ([v (syntax-local-value (dtvt-orig-id dtvt)
+							(lambda () #f))])
+			     (if (and (procedure? v)
+				      (procedure-arity-includes? v 1))
+				 ;; Apply macro binding for orig id to this id:
+				 (v stx)
+				 ;; Orig id is not bound to a macro:
+				 (dtvt-orig-id dtvt)))]))))
+  
+  (define dtvt-dt (make-struct-field-accessor dtvt-selector 0 'dt))
+  (define dtvt-vt (make-struct-field-accessor dtvt-selector 1 'vt))
+  (define dtvt-orig-id (make-struct-field-accessor dtvt-selector 2 'orig-id))
   
   ;; Helper function:
   (define (variant-assq name-stx variants)
@@ -24,4 +62,5 @@
   
   (provide make-dt dt? dt-pred-stx dt-variants
 	   (struct vt (name-stx predicate-stx accessor-stx selector-stxes field-count))
+	   make-dtvt dtvt? dtvt-dt dtvt-vt
 	   variant-assq))

collects/plai/private/datatype-core.ss

@@ -52,10 +52,15 @@
 	 (flat-contract c))))
 
   ;; Syntax:
-  ;;   (define-datatype-core orig-form d-v (option ...) name (alpha ...) pred-name variant ...)
+  ;;   (define-datatype-core orig-form (option ...) d-v name (alpha ...) pred-name variant ...)
   ;; where the syntax is like `define-datatype' starting with `pred-name'.
+  ;;
   ;; The `orig-stx' part is used for syntax-error reporting.
-  ;; The `d-v' is used in place of `define-values' to binding procedures.
+  ;; The `d-v' is used in place of `define-values' to bind procedures. Beware
+  ;;   that variant-constructor procedures are bound as syntax and an different
+  ;;   name is bound to the actual procedure; if this "actual" binding itself
+  ;;   turns out to be a macro, then uses of the constructor name are expanded
+  ;;   by directly calling the macro from the "actual" binding
   ;; Each `alpha' is a parameter to the contract expressions of each variant field;
   ;;   using `x-of' for variant `x' allows the parameter contracts to be supplied, 
   ;;   while using `x' directly instantiates each parameter as `any/c'.
@@ -69,6 +74,16 @@
   ;;                      requires define-selectors
   ;;   define-compatibility: include `make-x' for each variant `x'
   ;;   (kind "str") : uses "str" to name the result, either "type" or "datatype"
+  ;;
+  ;; Internals:
+  ;;  The `name' is bound as syntax to a dt record, which supplies an id
+  ;;   for the datatype's predicate, and also lists the ;;  datatype's variants
+  ;;   through vt records.
+  ;;  Each variant constructor name is bound as syntax to a dtvt record,
+  ;;   which gives the variant's vt record as well as its datatype's dt
+  ;;   record.
+  ;;  (See "core-utils.ss" for the dt, vt, and dtvt records.)
+  ;;
   (define-syntax define-datatype-core
     (lambda (stx)
       (syntax-case stx ()
@@ -109,7 +124,9 @@
 			  (map (lambda (n) 
 				 (datum->syntax-object (quote-syntax here) n #f))
 			       (map length field-nameses))]
-			 [(variant-name/no-contract ...)
+			 [(orig-variant-name ...)
+			  (generate-dt-temporaries variant-names)]
+                         [(variant-name/no-contract ...)
 			  (generate-dt-temporaries variant-names)]
                          [(variant-of ...)
 			  (map (lambda (variant-name) 
@@ -186,29 +203,35 @@
 					   "datatype")])
 	     (quasisyntax
 	      (begin
-		(define-syntax name 
+		(define-syntaxes (name variant-name ...)
 		  ;; Note: we're back to the transformer environment, here.
 		  ;; Also, this isn't a transformer function, so any direct
 		  ;;  use of the name will trigger a syntax error. The name
 		  ;;  can be found by `syntax-local-value', though.
 		  (let ([cert (syntax-local-certifier)])
-		    (make-set!-transformer
+		    (let-values ([(variant-name ...)
-		     (make-dt (cert (syntax pred-name))
+				  (values
-			      (list
+				   (make-vt (cert (quote-syntax variant-name))
-			       (make-vt (cert (quote-syntax variant-name))
+					    (cert (quote-syntax variant?))
-					(cert (quote-syntax variant?))
+					    (cert (quote-syntax variant-accessor))
-					(cert (quote-syntax variant-accessor))
+					    (list (quote-syntax selector-name) ...)
-					(list (quote-syntax selector-name) ...)
+					    variant-field-count)
-					variant-field-count)
+				   ...)])
-			       ...)
+		      (let ([dt (make-dt (cert (syntax pred-name))
-			      datatype-str))))
+					 (list variant-name ...)
+					 datatype-str)])
+			(values
+			 (make-set!-transformer dt)
+			 (make-set!-transformer
+			  (make-dtvt dt variant-name (quote-syntax orig-variant-name)))
+			 ...)))))
 		;; Bind the predicate and selector functions:
 		(define-proc-values (pred-name
 				     variant-name/no-contract ...
 				     variant? ...
 				     variant-accessor ...
 				     selector-name ... ...
-				     variant-name ...)
+				     orig-variant-name ...)
 		  ;; Create a new structure for the datatype (using the
 		  ;; datatype name in `struct', so it prints nicely).
 		  (let-values ([(struct:x make-x x? acc mut)