oop/goops/accessors.scm

   1 ;;;;    Copyright (C) 1999, 2000, 2005, 2006 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 ;;;; Boston, MA 02110-1301 USA
  17 ;;;;
  18 \f
  19
  20 (define-module (oop goops accessors)
  21   :use-module (oop goops)
  22   :re-export (standard-define-class)
  23   :export (define-class-with-accessors
  24            define-class-with-accessors-keywords))
  25
  26 (define-macro (define-class-with-accessors name supers . slots)
  27   (let ((eat? #f))
  28     `(standard-define-class
  29       ,name ,supers
  30       ,@(map-in-order
  31          (lambda (slot)
  32            (cond (eat?
  33                   (set! eat? #f)
  34                   slot)
  35                  ((keyword? slot)
  36                   (set! eat? #t)
  37                   slot)
  38                  ((pair? slot)
  39                   (if (get-keyword #:accessor (cdr slot) #f)
  40                       slot
  41                       (let ((name (car slot)))
  42                         `(,name #:accessor ,name ,@(cdr slot)))))
  43                  (else
  44                   `(,slot #:accessor ,slot))))
  45          slots))))
  46
  47 (define-macro (define-class-with-accessors-keywords name supers . slots)
  48   (let ((eat? #f))
  49     `(standard-define-class
  50       ,name ,supers
  51       ,@(map-in-order
  52          (lambda (slot)
  53            (cond (eat?
  54                   (set! eat? #f)
  55                   slot)
  56                  ((keyword? slot)
  57                   (set! eat? #t)
  58                   slot)
  59                  ((pair? slot)
  60                   (let ((slot
  61                          (if (get-keyword #:accessor (cdr slot) #f)
  62                              slot
  63                              (let ((name (car slot)))
  64                                `(,name #:accessor ,name ,@(cdr slot))))))
  65                     (if (get-keyword #:init-keyword (cdr slot) #f)
  66                         slot
  67                         (let* ((name (car slot))
  68                                (keyword (symbol->keyword name)))
  69                           `(,name #:init-keyword ,keyword ,@(cdr slot))))))
  70                  (else
  71                   `(,slot #:accessor ,slot
  72                           #:init-keyword ,(symbol->keyword slot)))))
  73          slots))))