1 ;;;; Copyright (C) 1999 Free Software Foundation, Inc.
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.
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.
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., 59 Temple Place, Suite 330,
16 ;;;; Boston, MA 02111-1307 USA
20 (define-module (oop goops stklos)
21 :use-module (oop goops internal)
26 ;;; This is the stklos compatibility module.
28 ;;; WARNING: This module is under construction. While we expect to be able
29 ;;; to run most stklos code without problems in the future, this is not the
30 ;;; case now. The current compatibility is only superficial.
32 ;;; Any comments/complaints/patches are welcome. Tell us about
33 ;;; your incompatibility problems (bug-guile@gnu.org).
36 ;; Export all bindings that are exported from (oop goops)...
37 (module-for-each (lambda (sym var)
38 (module-add! %module-public-interface sym var))
39 (nested-ref the-root-module '(app modules oop goops
40 %module-public-interface)))
42 ;; ...but replace the following bindings:
43 (export define-class define-method)
45 ;; Also export the following
48 ;;; Enable keyword support (*fixme*---currently this has global effect)
49 (read-set! keywords 'prefix)
51 (define standard-define-class-transformer
52 (macro-transformer standard-define-class))
62 (standard-define-class-transformer
63 `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
68 (procedure->memoizing-macro
70 (let ((name (cadr exp)))
72 (eq? (car name) 'setter)
75 (let ((name (cadr name)))
76 (cond ((not (symbol? name))
77 (goops-error "bad method name: ~S" name))
80 (if (not (is-a? ,name <generic-with-setter>))
81 (define-accessor ,name))
82 (add-method! (setter ,name) (method ,@(cddr exp)))))
85 (define-accessor ,name)
86 (add-method! (setter ,name) (method ,@(cddr exp)))))))
87 (cond ((not (symbol? name))
88 (goops-error "bad method name: ~S" name))
91 (if (not (or (is-a? ,name <generic>)
92 (is-a? ,name <primitive-generic>)))
93 (define-generic ,name))
94 (add-method! ,name (method ,@(cddr exp)))))
97 (define-generic ,name)
98 (add-method! ,name (method ,@(cddr exp)))))))))))