module/oop/goops/stklos.scm

   1 ;;;; Copyright (C) 1999,2002, 2006, 2010, 2011 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 3 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library 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 GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18
  19 (define-module (oop goops stklos)
  20   :use-module (oop goops internal)
  21   :no-backtrace
  22   )
  23
  24 ;;;
  25 ;;; This is the stklos compatibility module.
  26 ;;;
  27 ;;; WARNING: This module is under construction.  While we expect to be able
  28 ;;; to run most stklos code without problems in the future, this is not the
  29 ;;; case now.  The current compatibility is only superficial.
  30 ;;;
  31 ;;; Any comments/complaints/patches are welcome.  Tell us about
  32 ;;; your incompatibility problems (bug-guile@gnu.org).
  33 ;;;
  34
  35 ;; Export all bindings that are exported from (oop goops)...
  36 (module-for-each (lambda (sym var)
  37                    (module-add! (module-public-interface (current-module))
  38                                 sym var))
  39                  (resolve-interface '(oop goops)))
  40
  41 ;; ...but replace the following bindings:
  42 (export define-class define-method)
  43
  44 ;; Also export the following
  45 (export write-object)
  46
  47 ;;; Enable keyword support (*fixme*---currently this has global effect)
  48 (read-set! keywords 'prefix)
  49
  50 (define-syntax-rule (define-class name supers (slot ...) rest ...)
  51   (standard-define-class name supers slot ... rest ...))
  52
  53 (define (toplevel-define! name val)
  54   (module-define! (current-module) name val))
  55
  56 (define-syntax define-method
  57   (syntax-rules (setter)
  58     ((_ (setter name) rest ...)
  59      (begin
  60        (if (or (not (defined? 'name))
  61                (not (is-a? name <generic-with-setter>)))
  62            (toplevel-define! 'name
  63                              (ensure-accessor
  64                               (if (defined? 'name) name #f) 'name)))
  65        (add-method! (setter name) (method rest ...))))
  66     ((_ name rest ...)
  67      (begin
  68        (if (or (not (defined? 'name))
  69                (not (or (is-a? name <generic>)
  70                         (is-a? name <primitive-generic>))))
  71            (toplevel-define! 'name
  72                              (ensure-generic
  73                               (if (defined? 'name) name #f) 'name)))
  74        (add-method! name (method rest ...))))))