home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / oop / goops / accessors.scm next >
Encoding:
Text File  |  2008-12-17  |  2.5 KB  |  82 lines
  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.  
  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))))))
  82.