From f12de0a178b82e9b06b6a29a725cf6a182e53392 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 24 Mar 2005 10:23:17 +0000 Subject: [PATCH] * accessors.scm, simple.scm: New files. * goops.scm (standard-define-class): Removed; Export define-class as standard-define-class. --- oop/ChangeLog | 7 ++++ oop/goops.scm | 5 +-- oop/goops/Makefile.am | 4 +- oop/goops/accessors.scm | 81 +++++++++++++++++++++++++++++++++++++++++ oop/goops/simple.scm | 28 ++++++++++++++ 5 files changed, 120 insertions(+), 5 deletions(-) create mode 100644 oop/goops/accessors.scm create mode 100644 oop/goops/simple.scm diff --git a/oop/ChangeLog b/oop/ChangeLog index ff5ad2b01..ecb9445f2 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,10 @@ +2005-03-24 Mikael Djurfeldt + + * accessors.scm, simple.scm: New files. + + * goops.scm (standard-define-class): Removed; Export + define-class as standard-define-class. + 2005-01-18 Marius Vollmer * goops.scm (class-of): Changed from being re-exported to just diff --git a/oop/goops.scm b/oop/goops.scm index 2b22be241..b62959a48 100644 --- a/oop/goops.scm +++ b/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 ...) ;;; diff --git a/oop/goops/Makefile.am b/oop/goops/Makefile.am index 125909e3b..84c711158 100644 --- a/oop/goops/Makefile.am +++ b/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) diff --git a/oop/goops/accessors.scm b/oop/goops/accessors.scm new file mode 100644 index 000000000..0916d7284 --- /dev/null +++ b/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)))))) diff --git a/oop/goops/simple.scm b/oop/goops/simple.scm new file mode 100644 index 000000000..43683d252 --- /dev/null +++ b/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)))