guile18/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 define-class-with-accessors
  27   (procedure->memoizing-macro
  28    (lambda (exp env)
  29      (let ((name (cadr exp))
  30            (supers (caddr exp))
  31            (slots (cdddr exp))
  32            (eat? #f))
  33        `(standard-define-class ,name ,supers
  34           ,@(map-in-order
  35              (lambda (slot)
  36                (cond (eat?
  37                       (set! eat? #f)
  38                       slot)
  39                      ((keyword? slot)
  40                       (set! eat? #t)
  41                       slot)
  42                      ((pair? slot)
  43                       (if (get-keyword #:accessor (cdr slot) #f)
  44                           slot
  45                           (let ((name (car slot)))
  46                             `(,name #:accessor ,name ,@(cdr slot)))))
  47                      (else
  48                       `(,slot #:accessor ,slot))))
  49              slots))))))
  50
  51 (define define-class-with-accessors-keywords
  52   (procedure->memoizing-macro
  53    (lambda (exp env)
  54      (let ((name (cadr exp))
  55            (supers (caddr exp))
  56            (slots (cdddr exp))
  57            (eat? #f))
  58        `(standard-define-class ,name ,supers
  59           ,@(map-in-order
  60              (lambda (slot)
  61                (cond (eat?
  62                       (set! eat? #f)
  63                       slot)
  64                      ((keyword? slot)
  65                       (set! eat? #t)
  66                       slot)
  67                      ((pair? slot)
  68                       (let ((slot
  69                              (if (get-keyword #:accessor (cdr slot) #f)
  70                                  slot
  71                                  (let ((name (car slot)))
  72                                    `(,name #:accessor ,name ,@(cdr slot))))))
  73                         (if (get-keyword #:init-keyword (cdr slot) #f)
  74                             slot
  75                             (let* ((name (car slot))
  76                                    (keyword (symbol->keyword name)))
  77                               `(,name #:init-keyword ,keyword ,@(cdr slot))))))
  78                      (else
  79                       `(,slot #:accessor ,slot
  80                               #:init-keyword ,(symbol->keyword slot)))))
  81              slots))))))