From 7d6762f989e30f72fae6553bbb4e6dbddf03a698 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 4 Jul 2001 20:00:03 +0000
Subject: [PATCH] .

original commit: 18d7e54bedb46e00c16fdc28b14f6383812369be
---
 collects/mzlib/include.ss | 11 +++--
 collects/mzlib/shared.ss  | 96 +++------------------------------------
 2 files changed, 12 insertions(+), 95 deletions(-)

diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss
index 2ed1981..649c616 100644
--- a/collects/mzlib/include.ss
+++ b/collects/mzlib/include.ss
@@ -1,13 +1,12 @@
 
 (module include mzscheme
+  (require-for-syntax (lib "stx.ss" "syntax"))
 
   (define-syntax include
     (lambda (stx)
       ;; Parse the file name
       (let ([file
-	     (syntax-case* stx (build-path) (lambda (a b)
-					      (eq? (syntax-e a)
-						   (syntax-e b)))
+	     (syntax-case* stx (build-path) module-or-top-identifier=?
 	       [(_ fn)
 		(string? (syntax-e (syntax fn)))
 		(syntax-e (syntax fn))]
@@ -15,8 +14,10 @@
 		(andmap
 		 (lambda (e)
 		   (or (string? (syntax-e e))
-		       (module-identifier=? e (quote-syntax up))
-		       (module-identifier=? e (quote-syntax same))))
+		       (and (identifier? e)
+			    (or
+			     (module-identifier=? e (quote-syntax up))
+			     (module-identifier=? e (quote-syntax same))))))
 		 (syntax->list (syntax (elem1 elem ...))))
 		(apply build-path (syntax-object->datum (syntax (elem1 elem ...))))])])
 	;; Complete the file name
diff --git a/collects/mzlib/shared.ss b/collects/mzlib/shared.ss
index 52496a1..a68d437 100644
--- a/collects/mzlib/shared.ss
+++ b/collects/mzlib/shared.ss
@@ -1,99 +1,15 @@
 
 (module shared mzscheme
+  (require-for-syntax (lib "stx.ss" "syntax")
+		      (lib "kerncase.ss" "syntax")
+		      "include.ss")
 
   (provide shared)
 
   (define undefined (letrec ([x x]) x))
+  (require (rename mzscheme the-cons cons))
   
   (define-syntax shared
     (lambda (stx)
-      (syntax-case stx ()
-	[(_ ([name expr] ...) body1 body ...)
-	 (let ([names (syntax->list (syntax (name ...)))]
-	       [exprs (syntax->list (syntax (expr ...)))])
-	   (for-each (lambda (name)
-		       (unless (identifier? name)
-			 (raise-syntax-error
-			  'shared
-			  "not an identifier"
-			  stx
-			  name)))
-		     names)
-	   (let ([dup (check-duplicate-identifier names)])
-	     (when dup
-	       (raise-syntax-error
-		'shared
-		"duplicate identifier"
-		stx
-		dup)))
-	   (with-syntax ([(init-expr ...)
-			  (map (lambda (expr)
-				 (define (bad n)
-				   (raise-syntax-error
-				    'shared
-				    (format "illegal use of ~a" n)
-				    stx
-				    expr))
-				 (syntax-case expr (cons list box vector)
-				   [(cons a d)
-				    (syntax (cons undefined undefined))]
-				   [(cons . _)
-				    (bad "list")]
-				   [(list e ...)
-				    (with-syntax ([(e ...)
-						   (map (lambda (x) (syntax undefined))
-							(syntax->list (syntax (e ...))))])
-				      (syntax (list e ...)))]
-				   [(list . _)
-				    (bad "list")]
-				   [(box v)
-				    (syntax (box undefined))]
-				   [(box . _)
-				    (bad "box")]
-				   [(vector e ...)
-				    (with-syntax ([(e ...)
-						   (map (lambda (x) (syntax undefined))
-							(syntax->list (syntax (e ...))))])
-				      (syntax (vector e ...)))]
-				   [(vector . _)
-				    (bad "vector")]
-				   [_else expr]))
-			       exprs)]
-			 [(finish-expr ...)
-			  (let ([gen-n (lambda (l)
-					 (let loop ([l l][n 0])
-					   (if (null? l)
-					       null
-					       (cons (datum->syntax-object (quote-syntax here) n #f)
-						     (loop (cdr l) (add1 n))))))])
-			    (map (lambda (name expr)
-				   (with-syntax ([name name])
-				     (syntax-case expr (cons list box vector)
-				       [(cons a d)
-					(syntax (begin 
-						  (set-car! name a)
-						  (set-cdr! name d)))]
-				       [(list e ...)
-					(with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))])
-					  (syntax (let ([lst name])
-						    (set-car! (list-tail lst n) e)
-						    ...)))]
-				       [(box v)
-					(syntax (set-box! name v))]
-				       [(vector e ...)
-					(with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))])
-					  (syntax (let ([vec name])
-						    (vector-set! vec n e)
-						    ...)))]
-				       [_else (syntax (void))])))
-				 names exprs))])
-	     (syntax
-	      (letrec ([name init-expr] ...)
-		finish-expr
-		...
-		body1
-		body
-		...))))]))))
-
-				    
-	 
+      (define make-check-cdr #f)
+      (include (build-path "private" "shared-body.ss")))))