1 ;;;; Copyright (C) 1999,2002, 2006 Free Software Foundation, Inc.
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 2.1 of the License, or (at your option) any later version.
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.
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
19 (define-module (oop goops stklos)
20 :use-module (oop goops internal)
25 ;;; This is the stklos compatibility module.
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.
31 ;;; Any comments/complaints/patches are welcome. Tell us about
32 ;;; your incompatibility problems (bug-guile@gnu.org).
35 ;; Export all bindings that are exported from (oop goops)...
36 (module-for-each (lambda (sym var)
37 (module-add! %module-public-interface sym var))
38 (nested-ref the-root-module '(app modules oop goops
39 %module-public-interface)))
41 ;; ...but replace the following bindings:
42 (export define-class define-method)
44 ;; Also export the following
47 ;;; Enable keyword support (*fixme*---currently this has global effect)
48 (read-set! keywords 'prefix)
50 (define standard-define-class-transformer
51 (macro-transformer standard-define-class))
59 (procedure->memoizing-macro
61 (standard-define-class-transformer
62 `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
67 (procedure->memoizing-macro
69 (let ((name (cadr exp)))
71 (eq? (car name) 'setter)
74 (let ((name (cadr name)))
75 (cond ((not (symbol? name))
76 (goops-error "bad method name: ~S" name))
79 (if (not (is-a? ,name <generic-with-setter>))
80 (define-accessor ,name))
81 (add-method! (setter ,name) (method ,@(cddr exp)))))
84 (define-accessor ,name)
85 (add-method! (setter ,name) (method ,@(cddr exp)))))))
86 (cond ((not (symbol? name))
87 (goops-error "bad method name: ~S" name))
90 (if (not (or (is-a? ,name <generic>)
91 (is-a? ,name <primitive-generic>)))
92 (define-generic ,name))
93 (add-method! ,name (method ,@(cddr exp)))))
96 (define-generic ,name)
97 (add-method! ,name (method ,@(cddr exp)))))))))))