.

original commit: 6435f1302b9b3345c352d134cf9cd33578e87053

collects/mzlib/compat.ss

@@ -11,7 +11,8 @@
 	  gentemp
 	  atom?
 	  putprop getprop
-	  new-cafe)
+	  new-cafe
+	  define-structure)
   
   (define 1+ add1)
   (define 1- sub1)
@@ -78,4 +79,42 @@
 			(lambda ()
 			  (current-eval orig-eval)
 			  (exit-handler orig-exit)))))])])
-      nc)))
+      nc))
+
+  (define-syntax define-structure
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ (sname field ...))
+	 (syntax (define-structure (sname field ...) ()))]
+	[(_ (sname field ...) ([init-field init] ...))
+	 (andmap identifier? (syntax->list 
+			      (syntax (sname field ... init-field ...))))
+	 (let ([name (symbol->string (syntax-e (syntax sname)))]
+	       [fields (map symbol->string 
+			    (map syntax-e 
+				 (syntax->list (syntax (field ...)))))]
+	       [init-fields (map symbol->string 
+				 (map syntax-e 
+				      (syntax->list (syntax (init-field ...)))))]
+	       [+ (lambda args
+		    (datum->syntax (string->symbol (apply string-append args)) 
+				   (syntax sname) (syntax sname)))])
+	   (with-syntax ([struct: (+ "struct:" name)]
+			 [make- (+ "make-" name)]
+			 [? (+ name "?")]
+			 [(gs ...)
+			  (apply
+			   append
+			   (map (lambda (f) (list (+ name "-" f)
+						  (+ "set-" name "-" f "!")))
+				(append fields init-fields)))])
+	     (syntax
+	      (define-values (struct: make- ? gs ...)
+		(let-values ([(struct: make- ? gs ...)
+			      (struct sname (field ... init-field ...))])
+		  (values struct: 
+			  (let ([make- (lambda (field ...)
+					 (make- field ...
+						init ...))])
+			    make-)
+			  ? gs ...))))))]))))

collects/mzlib/shared.ss

@@ -1,14 +1,100 @@
 
-(begin-elaboration-time 
+(module shared mzscheme
- (require-library "functios.ss"))
 
-(begin-elaboration-time 
+  (export shared)
- (require-library "invoke.ss"))
-
-(begin-elaboration-time
- (define-values/invoke-unit (shared)
-   (require-library "sharedr.ss")))
-
-(define-macro shared shared)
 
+  (define undefined (letrec ([x x]) x))
+  (export-indirect undefined)
+  
+  (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 n #f (quote-syntax here))
+						     (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
+		...))))]))))
 
+				    
+