299.107

svn: r259

original commit: 0d4bc2cd9d93b05203f70cccdaf832babee3a4cd

collects/mzlib/etc.ss

@@ -525,8 +525,10 @@
     ;; Body can have mixed exprs and defns. Wrap expressions with
     ;; `(define-values () ... (values))' as needed, and add a (void)
     ;; at the end if needed.
-    (let* ([ctx (generate-expand-context)]
+    (let* ([def-ctx (syntax-local-make-definition-context)]
-	   [kernel-forms (kernel-form-identifier-list #'here)]
+	   [ctx (list (gensym 'intdef))]
+	   [kernel-forms (kernel-form-identifier-list 
+			  (quote-syntax here))]
 	   [init-exprs (let ([v (syntax->list stx)])
 			 (unless v
 			   (raise-syntax-error #f "bad syntax" stx))
@@ -538,27 +540,45 @@
 			    (let ([expr (local-expand
 					 expr
 					 ctx
-					 kernel-forms)])
+					 kernel-forms
-			      (syntax-case expr (begin)
+					 def-ctx)])
+			      (syntax-case expr (begin define-syntaxes define-values)
 				[(begin . rest)
 				 (loop (syntax->list #'rest))]
+				[(define-syntaxes (id ...) rhs)
+				 (andmap identifier? (syntax->list #'(id ...)))
+				 (with-syntax ([rhs (local-transformer-expand
+						     #'rhs
+						     'expression
+						     null)])
+				   (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
+				   (list #'(define-syntaxes (id ...) rhs)))]
+				[(define-values (id ...) rhs)
+				 (andmap identifier? (syntax->list #'(id ...)))
+				 (let ([ids (syntax->list #'(id ...))])
+				   (syntax-local-bind-syntaxes ids #f def-ctx)
+				   (list expr))]
 				[else
 				 (list expr)])))
 			  exprs)))])
-      #`(let ()
+      (let loop ([exprs exprs][prev-stx-defns null][prev-defns null][prev-exprs null])
-	  #,@(let loop ([exprs exprs][prev-defns null][prev-exprs null])
 	(cond
-		[(null? exprs) (append 
+	 [(null? exprs) 
-				(reverse prev-defns)
+	  #`(letrec-syntaxes+values
-				(reverse prev-exprs)
+	     #,(map stx-cdr (reverse prev-stx-defns))
-				(if (null? prev-exprs)
+	     #,(map stx-cdr (reverse prev-defns))
+	     #,@(if (null? prev-exprs)
 		    (list #'(void))
-				    null))]
+		    (reverse prev-exprs)))]
 	 [(and (stx-pair? (car exprs))
 	       (identifier? (stx-car (car exprs)))
-		      (or (module-identifier=? #'define-values (stx-car (car exprs)))
+	       (module-identifier=? #'define-syntaxes (stx-car (car exprs))))
-			  (module-identifier=? #'define-syntaxes (stx-car (car exprs)))))
+	  (loop (cdr exprs) (cons (car exprs) prev-stx-defns) prev-defns prev-exprs)]
+	 [(and (stx-pair? (car exprs))
+	       (identifier? (stx-car (car exprs)))
+	       (module-identifier=? #'define-values (stx-car (car exprs))))
 	  (loop (cdr exprs)
+		prev-stx-defns
 		(cons (car exprs)
 		      (append
 		       (map (lambda (expr)
@@ -567,7 +587,7 @@
 		       prev-defns))
 		null)]
 	 [else
-		 (loop (cdr exprs) prev-defns (cons (car exprs) prev-exprs))])))))
+	  (loop (cdr exprs) prev-stx-defns prev-defns (cons (car exprs) prev-exprs))]))))
 
   (define-syntax (begin-lifted stx)
     (syntax-case stx ()

collects/mzlib/private/sigutil.ss

@@ -16,7 +16,7 @@
 			    elems     ; list of syms and signatures
 			    ctxs      ; list of stx
 			    structs)) ; list of struct-infos
-  (define-struct parsed-unit (imports renames vars stxes body stx-checks))
+  (define-struct parsed-unit (imports renames vars import-vars body stx-checks))
 
   (define-struct struct-def (name super-name names))
 
@@ -528,7 +528,10 @@
       (let ([vars (map syntax-e (parsed-unit-vars a-unit))])
 	(for-each
 	 (lambda (var)
-	   (let ([renamed (do-rename var renames)])
+	   (let ([renamed (let ([s (do-rename var renames)])
+			    (if (syntax? s)
+				(syntax-e s)
+				s))])
 	     (unless (memq renamed vars)
 		     (syntax-error #f expr
 				   (format 
@@ -578,7 +581,7 @@
 	   clause)))))
 
   (define parse-unit
-    (lambda (expr body sig user-stx-forms dv-stx begin-stx)
+    (lambda (expr body sig user-stx-forms dv-stx ds-stx begin-stx)
       (let ([body (stx->list body)])
 	(unless body
 	  (syntax-error #f expr "illegal use of `.'"))
@@ -590,12 +593,22 @@
 	(let* ([imports (parse-imports 'unit/sig #t #t expr (stx-cdr (car body)) #t)]
 	       [imported-names (flatten-signatures imports #f)]
 	       [exported-names (flatten-signature #f sig #f)]
+	       [def-ctx (syntax-local-make-definition-context)]
 	       [body (cdr body)])
 	  (let-values ([(renames body)
 			(if (and (stx-pair? body)
 				 (stx-pair? (car body))
 				 (eq? 'rename (syntax-e (stx-car (car body)))))
-			    (values (map syntax-object->datum (cdr (stx->list (car body)))) (cdr body))
+			    (values (map (lambda (p)
+					   (list (stx-car p)
+						 (syntax-e (stx-car (stx-cdr p)))))
+					 (cdr (stx->list 
+					       (let ([rn (car body)])
+						 (local-expand rn
+							       'expression
+							       (list (stx-car rn))
+							       def-ctx)))))
+				    (cdr body))
 			    (values null body))])
 	    (unless renames
 	      (syntax-error #f expr "illegal use of `.'" (car body)))
@@ -635,14 +648,29 @@
 				  (loop (cdr e))
 				  (cons (car e) (loop (cdr e)))))))]
 		   [local-vars (append renamed-internals filtered-exported-names imported-names)]
-		   [expand-context (generate-expand-context)])
+		   [expand-context (generate-expand-context)]
-	      (let loop ([pre-lines null][lines body][port #f][port-name #f][body null][vars null])
+		   [import-stxes (apply append (map (lambda (i) 
+						      (map
+						       (lambda (d)
+							 (datum->syntax-object expr d))
+						       (make-struct-stx-decls i #f #t expr #f)))
+						    imports))]
+		   [import-vars
+		    (let ([vars (map (lambda (sym) (datum->syntax-object expr sym expr))
+				     (flatten-signatures imports 'must-have-ctx))])
+		      ;; Treat imported names like internal definitions:
+		      (syntax-local-bind-syntaxes vars #f def-ctx)
+		      (cdr (syntax->list (local-expand #`(stop #,@vars)
+						       'expression
+						       (list #'stop)
+						       def-ctx))))])
+	      (let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null])
 		(cond
 		 [(and (null? pre-lines) (not port) (null? lines))
 		  (make-parsed-unit imports 
 				    renames 
 				    vars 
-				    (lambda (src-stx) (apply append (map (lambda (i) (make-struct-stx-decls i #f #t src-stx #f)) imports)))
+				    import-vars
 				    body
 				    (lambda (src-stx) 
 				      ;; Disabled until we have a mechanism for declaring precise information in signatures:
@@ -661,7 +689,8 @@
 							   expand-context
 							   (append
 							    user-stx-forms
-							  local-vars))))]
+							    local-vars)
+							   def-ctx)))]
 			       [(rest-pre-lines) 
 				(if (null? pre-lines)
 				    null
@@ -679,17 +708,48 @@
 			   (identifier? (stx-car line))
 			   (module-identifier=? (stx-car line) dv-stx))
 		      (syntax-case line ()
-			[(_ (id ...) expr)
+			[(_ (id ...) rhs)
+			 (let ([ids (syntax->list #'(id ...))])
+			   (for-each (lambda (id)
+				       (unless (identifier? #'id)
+					 (syntax-error #f id "not an identifier" line)))
+				     ids)
+			   (syntax-local-bind-syntaxes ids #f def-ctx)
 			   (loop rest-pre-lines
 				 rest-lines
 				 port
 				 port-name
 				 (cons line body)
-			       (append (syntax->list (syntax (id ...))) vars))]
+				 (append ids vars)))]
 			[else
 			 (syntax-error #f expr 
 				       "improper `define-values' clause form"
 				       line)])]
+		     [(and (stx-pair? line)
+			   (identifier? (stx-car line))
+			   (module-identifier=? (stx-car line) ds-stx))
+		      (syntax-case line ()
+			[(_ (id ...) rhs)
+			 (let ([ids (syntax->list #'(id ...))])
+			   (for-each (lambda (id)
+				       (unless (identifier? #'id)
+					 (syntax-error #f id "not an identifier" line)))
+				     ids)
+			   (with-syntax ([rhs (local-transformer-expand
+					       #'rhs
+					       'expression
+					       null)])
+			     (syntax-local-bind-syntaxes ids #'rhs def-ctx)
+			     (loop rest-pre-lines
+				   rest-lines
+				   port
+				   port-name
+				   (cons line body)
+				   vars)))]
+			[else
+			 (syntax-error #f expr 
+				       "improper `define-syntaxes' clause form"
+				       line)])]
 		     [(and (stx-pair? line)
 			   (identifier? (stx-car line))
 			   (module-identifier=? (stx-car line) begin-stx))
@@ -1148,9 +1208,10 @@
 
 	   parsed-unit-renames
 	   parsed-unit-imports
-	   parsed-unit-stxes
+	   parsed-unit-import-vars
 	   parsed-unit-body
 	   parsed-unit-stx-checks
+	   parsed-unit-vars
 
 	   make-struct-stx-decls
 	   verify-struct-shape

collects/mzlib/process.ss

@@ -28,7 +28,7 @@
 				      (build-path d 'up "command.com"))))))])
 		   (list cmd
 			 'exact
-			 (format "~a /c ~a" (path->string cmd) argstr))))
+			 (format "~a /c \"~a\"" (path->string cmd) argstr))))
       (else (raise-mismatch-error 
 	     who
 	     (format "~a: don't know what shell to use for platform: " who)

collects/mzlib/serialize.ss

@@ -357,9 +357,7 @@
 	      #,(generate-struct-declaration stx
 					     id super-id field-ids 
 					     (syntax-local-context)
-					     (make-make-make-struct-type #'(inspector-expr deserializer-id))
+					     (make-make-make-struct-type #'(inspector-expr deserializer-id)))
-					     #'continue-define-serializable-struct 
-					     #'(inspector-expr deserializer-id))
 	      (define deserializer-id (let ([l (internal-deserialize-info struct-type-id)])
 					(make-deserialize-info
 					 ((car l))
@@ -404,9 +402,6 @@
 	 (context-check stx)
 	 (main/versions stx)))))
 
-  (define-syntax (continue-define-serializable-struct stx)
-    (generate-delayed-struct-declaration stx make-make-make-struct-type))
-
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; serialize
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

collects/mzlib/struct.ss

@@ -163,14 +163,10 @@
 	(generate-struct-declaration stx
 				     id sup-id fields
 				     (syntax-local-context)
-				     (make-make-make-struct-type props+insp)
+				     (make-make-make-struct-type props+insp))))
-				     #'continue-ds/p props+insp)))
     
     (parse-at-main))
 
-  (define-syntax (continue-ds/p stx)
-    (generate-delayed-struct-declaration stx make-make-make-struct-type))
-
   ;; ------------------------------------------------------------
   ;; make->vector
   

collects/mzlib/unit.ss

@@ -37,8 +37,9 @@
   ;; ----------------------------------------------------------------------
   ;; The `unit' syntactic form
 
-  (define-syntax :unit
+  (define-syntaxes (:unit unit/no-expand)
-    (lambda (stx)
+    (let ([do-unit 
+	   (lambda (stx expand?)
 	     (syntax-case stx (import export)
 	       [(_ (import ivar ...)
 		   (export evar ...)
@@ -53,27 +54,47 @@
 		      [check-renamed-id 
 		       (lambda (v)
 			 (syntax-case v ()
-		    [id (identifier? (syntax id)) 'ok]
+			   [id (identifier? (syntax id)) (list v)]
 			   [(lid eid) (and (identifier? (syntax lid))
-				    (identifier? (syntax eid))) 'ok]
+					   (identifier? (syntax eid))) 
+			    (list #'lid #'eid)]
 			   [else (raise-syntax-error
 				  #f
 				  "export is not an identifier or renamed identifier"
 				  stx
 				  v)]))]
 		      [expand-context (generate-expand-context)]
-	       [ivars (syntax->list (syntax (ivar ...)))]
+		      [def-ctx (and expand?
+				    (syntax-local-make-definition-context))]
+		      [localify (lambda (ids def-ctx)
+				  (if (andmap identifier? ids)
+				      ;; In expand mode, add internal defn context
+				      (if expand?
+					  (begin
+					    ;; Treat imports as internal-defn names:
+					    (syntax-local-bind-syntaxes ids #f def-ctx)
+					    (cdr (syntax->list
+						  (local-expand #`(stop #,@ids)
+								'expression
+								(list #'stop)
+								def-ctx))))
+					  ids)
+				      ;; Let later checking report an error:
+				      ids))])
+		  (let ([ivars (localify (syntax->list (syntax (ivar ...))) def-ctx)]
 			[evars (syntax->list (syntax (evar ...)))])
 		    (for-each check-id ivars)
 		    (for-each check-renamed-id evars)
 		    
 		    ;; Get import/export declared names:
 		    (let* ([exported-names
+			    (localify
 			     (map (lambda (v)
 				    (syntax-case v ()
 				      [(lid eid) (syntax lid)]
 				      [id (syntax id)]))
-			evars)]
+				  evars)
+			     def-ctx)]
 			   [extnames (map (lambda (v)
 					    (syntax-case v ()
 					      [(lid eid) (syntax eid)]
@@ -96,22 +117,21 @@
 		      ;; Expand all body expressions
 		      ;; so that all definitions are exposed.
 		      (letrec ([expand-all
+				(if expand?
 				    (lambda (defns&exprs)
-			 (let ([expanded
+				      (apply
+				       append
 				       (map
 					(lambda (defn-or-expr)
+					  (let ([defn-or-expr
 						  (local-expand
 						   defn-or-expr
 						   expand-context
 						   (append
 						    (kernel-form-identifier-list (quote-syntax here))
-				     declared-names)))
+						    declared-names)
-				 defns&exprs)])
+						   def-ctx)])
-			   (apply
+					    (syntax-case defn-or-expr (begin define-values define-syntaxes)
-			    append
-			    (map
-			     (lambda (defn-or-expr)
-			       (syntax-case defn-or-expr (begin)
 					      [(begin . l)
 					       (let ([l (syntax->list (syntax l))])
 						 (unless l
@@ -122,8 +142,22 @@
 						 (expand-all (map (lambda (s)
 								    (syntax-track-origin s defn-or-expr #'begin))
 								  l)))]
-				 [else (list defn-or-expr)]))
+					      [(define-syntaxes (id ...) rhs)
-			     expanded))))])
+					       (andmap identifier? (syntax->list #'(id ...)))
+					       (with-syntax ([rhs (local-transformer-expand
+								   #'rhs
+								   'expression
+								   null)])
+						 (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
+						 (list #'(define-syntaxes (id ...) rhs)))]
+					      [(define-values (id ...) rhs)
+					       (andmap identifier? (syntax->list #'(id ...)))
+					       (begin
+						 (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f def-ctx)
+						 (list defn-or-expr))]
+					      [else (list defn-or-expr)])))
+					defns&exprs)))
+				    values)])
 			(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
 			  ;; Get all the defined names, sorting out variable definitions
 			  ;; from syntax definitions.
@@ -224,7 +258,8 @@
 					 (loop (cdr l))]
 					[else (cons (car l) (loop (cdr l)))]))])
 				;; Generate names for import/export boxes, etc:
-		       (with-syntax ([(iloc ...) (generate-temporaries (syntax (ivar ...)))]
+				(with-syntax ([(ivar ...) ivars]
+					      [(iloc ...) (generate-temporaries ivars)]
 					      [(eloc ...) (generate-temporaries evars)]
 					      [(extname ...) extnames]
 					      [(expname ...) exported-names]
@@ -288,7 +323,7 @@
 						  values
 						  (map (lambda (defn-or-expr)
 							 (syntax-case defn-or-expr (define-syntaxes)
-						  [(define-syntaxes . l) defn-or-expr]
+							   [(define-syntaxes . l) #'l]
 							   [else #f]))
 						       all-expanded))])
 				    ;; Build up set! redirection chain:
@@ -321,11 +356,13 @@
 					   (let ([eloc (box undefined)] ...)
 					     (list (vector eloc ...)
 						   (lambda (iloc ...)
-					    (let ([intname undefined] ...)
+						     (letrec-syntaxes+values 
-					      (letrec-syntaxes+values redirections ()
+						      (stx-defn ... . redirections)
-						stx-defn ...
+						      ([(intname) undefined] ...)
 						      (void) ; in case the body would be empty
-						defn&expr ...))))))))))))))))))])))
+						      defn&expr ...))))))))))))))))))]))])
+      (values (lambda (stx) (do-unit stx #t))
+	      (lambda (stx) (do-unit stx #f)))))
 
   ;; ----------------------------------------------------------------------
   ;; check-expected-interface: used by the expansion of `compound-unit'
@@ -824,7 +861,8 @@
 			      (syntax (define-values (tagged-export ...) invoke-unit)))))))])))])
       (values (mk #f) (mk #t))))
   
-  (provide (rename :unit unit) compound-unit invoke-unit unit?
+  (provide (rename :unit unit) unit/no-expand
+	   compound-unit invoke-unit unit?
 	   (struct exn:fail:unit ())
 
 	   define-values/invoke-unit

collects/mzlib/unitsig.ss

@@ -44,29 +44,32 @@
 	  (let ([a-unit (parse-unit expr (syntax rest) sig
 				    (kernel-form-identifier-list (quote-syntax here))
 				    (quote-syntax define-values)
+				    (quote-syntax define-syntaxes)
 				    (quote-syntax begin))])
 	    (check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr)
-	    (with-syntax ([imports (datum->syntax-object
+	    (with-syntax ([imports (parsed-unit-import-vars a-unit)]
-				    expr
-				    (flatten-signatures (parsed-unit-imports a-unit) 'must-have-ctx)
-				    expr)]
 			  [exports (datum->syntax-object
 				    expr
+				    (let ([vars (make-hash-table)])
+				      (for-each (lambda (var)
+						  (hash-table-put! vars (syntax-e var) var))
+						(parsed-unit-vars a-unit))
 				      (map
 				       (lambda (name)
-				       (list (do-rename name (parsed-unit-renames a-unit))
+					 (list (hash-table-get vars
+							       name
+							       (lambda () (do-rename name (parsed-unit-renames a-unit))))
 					       name))
-				     (signature-vars sig))
+				       (signature-vars sig)))
 				    expr)]
 			  [body (append
-				 ((parsed-unit-stxes a-unit) expr)
 				 (reverse! (parsed-unit-body a-unit))
 				 ((parsed-unit-stx-checks a-unit) expr))]
 			  [import-sigs (explode-named-sigs (parsed-unit-imports a-unit) #f)]
 			  [export-sig (explode-sig sig #f)])
 	      (syntax/loc expr
 		(make-signed-unit
-		 (unit
+		 (unit/no-expand
 		   (import . imports)
 		   (export . exports)
 		   . body)

collects/tests/mzscheme/etc.ss

@@ -0,0 +1,53 @@
+
+(load-relative "loadtest.ss")
+
+(SECTION 'etc)
+
+(require (lib "etc.ss"))
+
+(let () 
+  (begin-with-definitions 
+   (define-syntax (goo stx) 
+     (syntax-case stx () 
+       [(_ foo) #'(define-syntax (foo stx) (syntax-case stx () [(_ x) #'(define x 12)]))]))
+   (goo foo)
+   (foo x)
+   (test 12 'bwd x)))
+
+(let-syntax ([goo (lambda (stx) #'(begin (define z 13) (test 13 'bwd z)))])
+  (let-syntax ([y (lambda (stx) #'goo)])
+    (let () 
+      (begin-with-definitions 
+       (define-syntax (goo stx) 
+	 (syntax-case stx () 
+	   [(_ foo) #'(define-syntax (foo stx) (syntax-case stx () [(_ x) #'(define x 12)]))]))
+       (goo foo)
+       (foo x)
+       y
+       (test 12 'bwd x)))))
+
+(let ()
+  (begin-with-definitions 
+   (define-struct a (b c))
+   (test 2 'bwd (a-c (make-a 1 2)))))
+
+(let ()
+  (begin-with-definitions 
+   (define-struct a (b c))
+   (let ()
+     (define-struct (d a) (e))
+     (test 3 'bwd (d-e (make-d 1 2 3))))))
+
+(let ()
+  (begin-with-definitions 
+   (define-struct a (b c))
+   (define-struct (d a) (e))
+   (test 3 'bwd (d-e (make-d 1 2 3)))))
+
+(syntax-test #'(begin-with-definitions
+		 (define-syntax goo 10)
+		 (define goo 10)
+		 12))
+
+(report-errs)
+