From: Taylor R. Campbell <net/mumble/campbell>
Date: Thu, 5 Apr 2007 02:35:14 +0000 (+0000)
Subject: Associate names with generic procedures generated by DEFINE {ACCESSOR,
X-Git-Tag: 20090517-FFI~691
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=83fb48ce3c7859585ee9f4a1488ddb4789a53ce6;p=mit-scheme.git

Associate names with generic procedures generated by DEFINE {ACCESSOR,
MODIFIER, INITPRED} clauses for slots in DEFINE-CLASS.
---

diff --git a/v7/src/sos/macros.scm b/v7/src/sos/macros.scm
index cf3cff438..352ba7f62 100644
--- a/v7/src/sos/macros.scm
+++ b/v7/src/sos/macros.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: macros.scm,v 1.20 2007/01/05 21:19:29 cph Exp $
+$Id: macros.scm,v 1.21 2007/04/05 02:35:14 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -231,19 +231,22 @@ USA.
 	   (if (or (and standard? (eq? 'STANDARD arg))
 		   (eq? keyword arg)
 		   (and (pair? arg) (memq keyword arg)))
-	       `((,(close-syntax 'DEFINE environment)
-		   ,(or (plist-lookup keyword (cdr slot-argument) #f)
-			(let ((name
-			       (intern
-				(generate
-				 (string-append (strip-angle-brackets name)
-						separator
-						(symbol->string
-						 (car slot-argument)))))))
-			  (set-cdr! slot-argument
-				    (cons* keyword name (cdr slot-argument)))
-			  name))
-		   (,(absolute 'MAKE-GENERIC-PROCEDURE environment) ,arity)))
+	       ((lambda (name)
+		  `((,(close-syntax 'DEFINE environment)
+		     ,name
+		     (,(absolute 'MAKE-GENERIC-PROCEDURE environment)
+		      ,arity
+		      ',name))))
+		(or (plist-lookup keyword (cdr slot-argument) #f)
+		    (let ((name (intern
+				 (generate
+				  (string-append (strip-angle-brackets name)
+						 separator
+						 (symbol->string
+						  (car slot-argument)))))))
+		      (set-cdr! slot-argument
+				(cons* keyword name (cdr slot-argument)))
+		      name)))
 	       '()))))
     (append (translate 'ACCESSOR #t 1
 		       (lambda (root) root))