* accessors.scm, simple.scm: New files.

* goops.scm (standard-define-class): Removed; Export
define-class as standard-define-class.

oop/ChangeLog

@@ -1,3 +1,10 @@
+2005-03-24  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* accessors.scm, simple.scm: New files.
+
+	* goops.scm (standard-define-class): Removed; Export
+	define-class as standard-define-class.
+
 2005-01-18  Marius Vollmer  <marius.vollmer@uni-dortmund.de>
 
 	* goops.scm (class-of): Changed from being re-exported to just

oop/goops.scm

@@ -26,7 +26,7 @@
 ;;;;
 
 (define-module (oop goops)
-  :export-syntax (define-class class
+  :export-syntax (define-class class standard-define-class
 		  define-generic define-accessor define-method
 		  define-extended-generic define-extended-generics
 		  method)
@@ -244,8 +244,7 @@
 			  (variable-set! var (class-redefinition old class))
 			  (variable-set! var class)))))))))))
 
-(defmacro standard-define-class args
-  `(define-class ,@args))
+(define standard-define-class define-class)
 
 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
 ;;;

oop/goops/Makefile.am

@@ -1,6 +1,6 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-##  	Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc.
+##  	Copyright (C) 2000, 2001, 2004, 2005 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##   
@@ -25,7 +25,7 @@ AUTOMAKE_OPTIONS = gnu
 goops_sources =							\
     active-slot.scm compile.scm composite-slot.scm describe.scm	\
     dispatch.scm internal.scm save.scm stklos.scm util.scm      \
-    old-define-method.scm
+    old-define-method.scm accessors.scm simple.scm
 
 subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/oop/goops
 subpkgdata_DATA = $(goops_sources)

oop/goops/accessors.scm

@@ -0,0 +1,81 @@
+;;;; 	Copyright (C) 1999, 2000, 2005 Free Software Foundation, Inc.
+;;;; 
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;; 
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;; 
+
+
+(define-module (oop goops accessors)
+  :use-module (oop goops)
+  :re-export (standard-define-class)
+  :export (define-class-with-accessors
+	   define-class-with-accessors-keywords))
+
+(define define-class-with-accessors
+  (procedure->memoizing-macro
+   (lambda (exp env)
+     (let ((name (cadr exp))
+	   (supers (caddr exp))
+	   (slots (cdddr exp))
+	   (eat? #f))
+       `(standard-define-class ,name ,supers
+	  ,@(map-in-order
+	     (lambda (slot)
+	       (cond (eat?
+		      (set! eat? #f)
+		      slot)
+		     ((keyword? slot)
+		      (set! eat? #t)
+		      slot)
+		     ((pair? slot)
+		      (if (get-keyword #:accessor (cdr slot) #f)
+			  slot
+			  (let ((name (car slot)))
+			    `(,name #:accessor ,name ,@(cdr slot)))))
+		     (else
+		      `(,slot #:accessor ,slot))))
+	     slots))))))
+
+(define define-class-with-accessors-keywords
+  (procedure->memoizing-macro
+   (lambda (exp env)
+     (let ((name (cadr exp))
+	   (supers (caddr exp))
+	   (slots (cdddr exp))
+	   (eat? #f))
+       `(standard-define-class ,name ,supers
+	  ,@(map-in-order
+	     (lambda (slot)
+	       (cond (eat?
+		      (set! eat? #f)
+		      slot)
+		     ((keyword? slot)
+		      (set! eat? #t)
+		      slot)
+		     ((pair? slot)
+		      (let ((slot
+			     (if (get-keyword #:accessor (cdr slot) #f)
+				 slot
+				 (let ((name (car slot)))
+				   `(,name #:accessor ,name ,@(cdr slot))))))
+			(if (get-keyword #:init-keyword (cdr slot) #f)
+			    slot
+			    (let* ((name (car slot))
+				   (keyword (symbol->keyword name)))
+			      `(,name #:init-keyword ,keyword ,@(cdr slot))))))
+		     (else
+		      `(,slot #:accessor ,slot
+			      #:init-keyword ,(symbol->keyword slot)))))
+	     slots))))))

oop/goops/simple.scm

@@ -0,0 +1,28 @@
+;;; installed-scm-file
+
+;;;; Copyright (C) 2005 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; 
+
+
+(define-module (oop goops simple)
+  :use-module (oop goops accessors)
+  :export (define-class)
+  :no-backtrace)
+
+(define define-class define-class-with-accessors-keywords)
+
+(module-use! %module-public-interface (resolve-interface '(oop goops)))