guile18/oop/goops/stklos.scm

   1 ;;;; Copyright (C) 1999,2002, 2006 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 2.1 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 sym var))
  38                  (nested-ref the-root-module '(app modules oop goops
  39                                                    %module-public-interface)))
  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 standard-define-class-transformer
  51   (macro-transformer standard-define-class))
  52
  53 (define define-class
  54   ;; Syntax
  55   (let ((name cadr)
  56         (supers caddr)
  57         (slots cadddr)
  58         (rest cddddr))
  59     (procedure->memoizing-macro
  60       (lambda (exp env)
  61         (standard-define-class-transformer
  62          `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
  63             ,@(rest exp))
  64          env)))))
  65
  66 (define define-method
  67   (procedure->memoizing-macro
  68     (lambda (exp env)
  69       (let ((name (cadr exp)))
  70         (if (and (pair? name)
  71                  (eq? (car name) 'setter)
  72                  (pair? (cdr name))
  73                  (null? (cddr name)))
  74             (let ((name (cadr name)))
  75               (cond ((not (symbol? name))
  76                      (goops-error "bad method name: ~S" name))
  77                     ((defined? name env)
  78                      `(begin
  79                         (if (not (is-a? ,name <generic-with-setter>))
  80                             (define-accessor ,name))
  81                         (add-method! (setter ,name) (method ,@(cddr exp)))))
  82                     (else
  83                      `(begin
  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))
  88                   ((defined? name env)
  89                    `(begin
  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)))))
  94                   (else
  95                    `(begin
  96                       (define-generic ,name)
  97                       (add-method! ,name (method ,@(cddr exp)))))))))))