Import guile-1.8 as multiple upstream tarball component

[lilypond.git] / guile18 / oop / goops / old-define-method.scm

diff --git a/guile18/oop/goops/old-define-method.scm b/guile18/oop/goops/old-define-method.scm
new file mode 100644 (file)
index 0000000..3469dc9
--- /dev/null
+++ b/guile18/oop/goops/old-define-method.scm
@@ -0,0 +1,60 @@
+;;; installed-scm-file
+
+;;;;   Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+\f
+
+(define-module (oop goops old-define-method)
+  :use-module (oop goops)
+  :export (define-method)
+  :no-backtrace
+  )
+
+(define define-method
+  (procedure->memoizing-macro
+    (lambda (exp env)
+      (let ((name (cadr exp)))
+       (if (and (pair? name)
+                (eq? (car name) 'setter)
+                (pair? (cdr name))
+                (symbol? (cadr name))
+                (null? (cddr name)))
+           (let ((name (cadr name)))
+             (cond ((not (symbol? name))
+                    (goops-error "bad method name: ~S" name))
+                   ((defined? name env)
+                    `(begin
+                       ;; *fixme* Temporary hack for the current module system
+                       (if (not ,name)
+                           (define-accessor ,name))
+                       (add-method! (setter ,name) (method ,@(cddr exp)))))
+                   (else
+                    `(begin
+                       (define-accessor ,name)
+                       (add-method! (setter ,name) (method ,@(cddr exp)))))))
+           (cond ((not (symbol? name))
+                  (goops-error "bad method name: ~S" name))
+                 ((defined? name env)
+                  `(begin
+                     ;; *fixme* Temporary hack for the current module system
+                     (if (not ,name)
+                         (define-generic ,name))
+                     (add-method! ,name (method ,@(cddr exp)))))
+                 (else
+                  `(begin
+                     (define-generic ,name)
+                     (add-method! ,name (method ,@(cddr exp)))))))))))