summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>2001-03-10 03:09:50 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>2001-03-10 03:09:50 +0000
commit71d540f734534c3a783d9b65fd84a3a299402b86 (patch)
tree396a8c9453f2679581fdd0478346048cee9eb6b8
parente75341b38d65736421ace4b75f405b0bcdaacf9c (diff)
downloadguile-71d540f734534c3a783d9b65fd84a3a299402b86.tar.gz
* goops.scm (define-method): Only accept new syntax.
* goops/old-define-method.scm: New file. * goops.scm, goops/save.scm, goops/composite-slot.scm, goops/active-slot.scm: Use new method syntax.
-rw-r--r--oop/ChangeLog11
-rw-r--r--oop/goops.scm181
-rw-r--r--oop/goops/Makefile.am5
-rw-r--r--oop/goops/active-slot.scm4
-rw-r--r--oop/goops/composite-slot.scm4
-rw-r--r--oop/goops/describe.scm14
-rw-r--r--oop/goops/old-define-method.scm62
-rw-r--r--oop/goops/save.scm58
8 files changed, 213 insertions, 126 deletions
diff --git a/oop/ChangeLog b/oop/ChangeLog
index cf3f52287..56c117c72 100644
--- a/oop/ChangeLog
+++ b/oop/ChangeLog
@@ -1,3 +1,14 @@
+2001-03-09 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops.scm (define-method): Only accept new syntax.
+
+ * Makefile.am: Added old-define-method.scm.
+
+ * goops/old-define-method.scm: New file.
+
+ * goops.scm, goops/save.scm, goops/composite-slot.scm,
+ goops/active-slot.scm: Use new method syntax.
+
2001-03-04 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
* goops/compile.scm (compile-method): Tag method closure for body
diff --git a/oop/goops.scm b/oop/goops.scm
index ca5c85dec..32b86108e 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -425,40 +425,53 @@
(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)
+ (let ((head (cadr exp)))
+ (if (not (pair? head))
+ (goops-error "bad method head: ~S" head)
+ (let ((gf (car head)))
+ (cond ((and (pair? gf)
+ (eq? (car gf) 'setter)
+ (pair? (cdr gf))
+ (symbol? (cadr gf))
+ (null? (cddr gf)))
+ ;; named setter method
+ (let ((name (cadr gf)))
+ (cond ((not (symbol? name))
+ `(add-method! (setter ,name)
+ (method ,(cdadr exp)
+ ,@(cddr exp))))
+ ((defined? name env)
+ `(begin
+ ;; *fixme* Temporary hack for the current
+ ;; module system
+ (if (not ,name)
+ (define-accessor ,name))
+ (add-method! (setter ,name)
+ (method ,(cdadr exp)
+ ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-accessor ,name)
+ (add-method! (setter ,name)
+ (method ,(cdadr exp)
+ ,@(cddr exp))))))))
+ ((not (symbol? gf))
+ `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
+ ((defined? gf env)
`(begin
- ;; *fixme* Temporary hack for the current module system
- (if (not ,name)
- (define-generic ,name))
- (add-method! (setter ,name) (method ,@(cddr exp)))))
+ ;; *fixme* Temporary hack for the current
+ ;; module system
+ (if (not ,gf)
+ (define-generic ,gf))
+ (add-method! ,gf
+ (method ,(cdadr exp)
+ ,@(cddr exp)))))
(else
`(begin
- (define-accessor ,name)
- (add-method! (setter ,name) (method ,@(cddr exp)))))))
- (cond ((pair? name)
- ;; Convert new syntax to old
- `(define-method ,(car name) ,(cdr name) ,@(cddr exp)))
- ((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)))))))))))
+ (define-generic ,gf)
+ (add-method! ,gf
+ (method ,(cdadr exp)
+ ,@(cddr exp))))))))))))
(define (make-method specializers procedure)
(make <method>
@@ -543,17 +556,17 @@
#:specializers (list <generic> <method>)
#:procedure internal-add-method!))
-(define-method add-method! ((proc <procedure>) (m <method>))
+(define-method (add-method! (proc <procedure>) (m <method>))
(if (generic-capability? proc)
(begin
(enable-primitive-generic! proc)
(add-method! proc m))
(next-method)))
-(define-method add-method! ((pg <primitive-generic>) (m <method>))
+(define-method (add-method! (pg <primitive-generic>) (m <method>))
(add-method! (primitive-generic-generic pg) m))
-(define-method add-method! (obj (m <method>))
+(define-method (add-method! obj (m <method>))
(goops-error "~S is not a valid generic function" obj))
;;;
@@ -563,7 +576,7 @@
;;;
;;; Methods
;;;
-(define-method method-source ((m <method>))
+(define-method (method-source (m <method>))
(let* ((spec (map* class-name (slot-ref m 'specializers)))
(proc (procedure-source (slot-ref m 'procedure)))
(args (cadr proc))
@@ -618,8 +631,8 @@
;;; Methods to compare objects
;;;
-(define-method object-eqv? (x y) #f)
-(define-method object-equal? (x y) (eqv? x y))
+(define-method (object-eqv? x y) #f)
+(define-method (object-equal? x y) (eqv? x y))
;;;
;;; methods to display/write an object
@@ -633,14 +646,14 @@
(define (display-address o file)
(display (number->string (object-address o) 16) file))
-(define-method write (o file)
+(define-method (write o file)
(display "#<instance " file)
(display-address o file)
(display #\> file))
(define write-object (primitive-generic-generic write))
-(define-method write ((o <object>) file)
+(define-method (write (o <object>) file)
(let ((class (class-of o)))
(if (slot-bound? class 'name)
(begin
@@ -651,7 +664,7 @@
(display #\> file))
(next-method))))
-(define-method write ((o <foreign-object>) file)
+(define-method (write (o <foreign-object>) file)
(let ((class (class-of o)))
(if (slot-bound? class 'name)
(begin
@@ -662,7 +675,7 @@
(display #\> file))
(next-method))))
-(define-method write ((class <class>) file)
+(define-method (write (class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name)
(slot-bound? meta 'name))
@@ -676,7 +689,7 @@
(display #\> file))
(next-method))))
-(define-method write ((gf <generic>) file)
+(define-method (write (gf <generic>) file)
(let ((meta (class-of gf)))
(if (and (slot-bound? meta 'name)
(slot-bound? gf 'methods))
@@ -693,7 +706,7 @@
(display ")>" file))
(next-method))))
-(define-method write ((o <method>) file)
+(define-method (write (o <method>) file)
(let ((meta (class-of o)))
(if (and (slot-bound? meta 'name)
(slot-bound? o 'specializers))
@@ -713,7 +726,7 @@
(next-method))))
;; Display (do the same thing as write by default)
-(define-method display (o file)
+(define-method (display o file)
(write-object o file))
;;;
@@ -738,42 +751,42 @@
(define (class-slot-set! class slot value)
((cadr (class-slot-g-n-s class slot)) #f value))
-(define-method slot-unbound ((c <class>) (o <object>) s)
+(define-method (slot-unbound (c <class>) (o <object>) s)
(goops-error "Slot `~S' is unbound in object ~S" s o))
-(define-method slot-unbound ((c <class>) s)
+(define-method (slot-unbound (c <class>) s)
(goops-error "Slot `~S' is unbound in class ~S" s c))
-(define-method slot-unbound ((o <object>))
+(define-method (slot-unbound (o <object>))
(goops-error "Unbound slot in object ~S" o))
-(define-method slot-missing ((c <class>) (o <object>) s)
+(define-method (slot-missing (c <class>) (o <object>) s)
(goops-error "No slot with name `~S' in object ~S" s o))
-(define-method slot-missing ((c <class>) s)
+(define-method (slot-missing (c <class>) s)
(goops-error "No class slot with name `~S' in class ~S" s c))
-(define-method slot-missing ((c <class>) (o <object>) s value)
+(define-method (slot-missing (c <class>) (o <object>) s value)
(slot-missing c o s))
;;; Methods for the possible error we can encounter when calling a gf
-(define-method no-next-method ((gf <generic>) args)
+(define-method (no-next-method (gf <generic>) args)
(goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
-(define-method no-applicable-method ((gf <generic>) args)
+(define-method (no-applicable-method (gf <generic>) args)
(goops-error "No applicable method for ~S in call ~S"
gf (cons (generic-function-name gf) args)))
-(define-method no-method ((gf <generic>) args)
+(define-method (no-method (gf <generic>) args)
(goops-error "No method defined for ~S" gf))
;;;
;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
;;;
-(define-method shallow-clone ((self <object>))
+(define-method (shallow-clone (self <object>))
(let ((clone (%allocate-instance (class-of self) '()))
(slots (map slot-definition-name
(class-slots (class-of self)))))
@@ -783,7 +796,7 @@
slots)
clone))
-(define-method deep-clone ((self <object>))
+(define-method (deep-clone (self <object>))
(let ((clone (%allocate-instance (class-of self) '()))
(slots (map slot-definition-name
(class-slots (class-of self)))))
@@ -816,7 +829,7 @@
;;; 2. Old class header exists on old super classes direct-subclass lists
;;; 3. New class header exists on new super classes direct-subclass lists
-(define-method class-redefinition ((old <class>) (new <class>))
+(define-method (class-redefinition (old <class>) (new <class>))
;; Work on direct methods:
;; 1. Remove accessor methods from the old class
;; 2. Patch the occurences of new in the specializers by old
@@ -866,7 +879,7 @@
;;; remove-class-accessors!
;;;
-(define-method remove-class-accessors! ((c <class>))
+(define-method (remove-class-accessors! (c <class>))
(for-each (lambda (m)
(if (is-a? m <accessor-method>)
(remove-method-in-classes! m)))
@@ -876,7 +889,7 @@
;;; update-direct-method!
;;;
-(define-method update-direct-method! ((m <method>)
+(define-method (update-direct-method! (m <method>)
(old <class>)
(new <class>))
(let loop ((l (method-specializers m)))
@@ -892,7 +905,7 @@
;;; update-direct-subclass!
;;;
-(define-method update-direct-subclass! ((c <class>)
+(define-method (update-direct-subclass! (c <class>)
(old <class>)
(new <class>))
(class-redefinition c
@@ -929,7 +942,7 @@
(compute-setter-method class g-n-s))))))
slots (slot-ref class 'getters-n-setters)))
-(define-method compute-getter-method ((class <class>) slotdef)
+(define-method (compute-getter-method (class <class>) slotdef)
(let ((init-thunk (cadr slotdef))
(g-n-s (cddr slotdef)))
(make <accessor-method>
@@ -945,7 +958,7 @@
(bound-check-get g-n-s)))
#:slot-definition slotdef)))
-(define-method compute-setter-method ((class <class>) slotdef)
+(define-method (compute-setter-method (class <class>) slotdef)
(let ((g-n-s (cddr slotdef)))
(make <accessor-method>
#:specializers (list class <top>)
@@ -1047,7 +1060,7 @@
;;; => cpl (a) = a b d c e f object top
;;;
-(define-method compute-cpl ((class <class>))
+(define-method (compute-cpl (class <class>))
(compute-std-cpl class class-direct-supers))
;; Support
@@ -1174,7 +1187,7 @@
;;; compute-get-n-set
;;;
-(define-method compute-get-n-set ((class <class>) s)
+(define-method (compute-get-n-set (class <class>) s)
(case (slot-definition-allocation s)
((#:instance) ;; Instance slot
;; get-n-set is just its offset
@@ -1217,20 +1230,20 @@
(list (lambda (o) shared-variable)
(lambda (o v) (set! shared-variable v)))))
-(define-method compute-get-n-set ((o <object>) s)
+(define-method (compute-get-n-set (o <object>) s)
(goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
-(define-method compute-slots ((class <class>))
+(define-method (compute-slots (class <class>))
(%compute-slots class))
;;;
;;; {Initialize}
;;;
-(define-method initialize ((object <object>) initargs)
+(define-method (initialize (object <object>) initargs)
(%initialize-object object initargs))
-(define-method initialize ((class <class>) initargs)
+(define-method (initialize (class <class>) initargs)
(next-method)
(let ((dslots (get-keyword #:slots initargs '()))
(supers (get-keyword #:dsupers initargs '()))
@@ -1282,23 +1295,23 @@
(set-object-procedure! object
(lambda args (apply proc args)))))))
-(define-method initialize ((class <operator-class>) initargs)
+(define-method (initialize (class <operator-class>) initargs)
(next-method)
(initialize-object-procedure class initargs))
-(define-method initialize ((owsc <operator-with-setter-class>) initargs)
+(define-method (initialize (owsc <operator-with-setter-class>) initargs)
(next-method)
(%set-object-setter! owsc (get-keyword #:setter initargs #f)))
-(define-method initialize ((entity <entity>) initargs)
+(define-method (initialize (entity <entity>) initargs)
(next-method)
(initialize-object-procedure entity initargs))
-(define-method initialize ((ews <entity-with-setter>) initargs)
+(define-method (initialize (ews <entity-with-setter>) initargs)
(next-method)
(%set-object-setter! ews (get-keyword #:setter initargs #f)))
-(define-method initialize ((generic <generic>) initargs)
+(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
(name (get-keyword #:name initargs #f)))
(next-method)
@@ -1316,7 +1329,7 @@
(define dummy-procedure (lambda args *unspecified*))
-(define-method initialize ((method <method>) initargs)
+(define-method (initialize (method <method>) initargs)
(next-method)
(slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
@@ -1324,7 +1337,7 @@
(get-keyword #:procedure initargs dummy-procedure))
(slot-set! method 'code-table '()))
-(define-method initialize ((obj <foreign-object>) initargs))
+(define-method (initialize (obj <foreign-object>) initargs))
;;;
;;; {Change-class}
@@ -1361,13 +1374,13 @@
old-instance))
-(define-method update-instance-for-different-class ((old-instance <object>)
+(define-method (update-instance-for-different-class (old-instance <object>)
(new-instance
<object>))
;;not really important what we do, we just need a default method
new-instance)
-(define-method change-class ((old-instance <object>) (new-class <class>))
+(define-method (change-class (old-instance <object>) (new-class <class>))
(change-object-class old-instance (class-of old-instance) new-class))
;;;
@@ -1376,10 +1389,10 @@
;;; A new definition which overwrites the previous one which was built-in
;;;
-(define-method allocate-instance ((class <class>) initargs)
+(define-method (allocate-instance (class <class>) initargs)
(%allocate-instance class initargs))
-(define-method make-instance ((class <class>) . initargs)
+(define-method (make-instance (class <class>) . initargs)
(let ((instance (allocate-instance class initargs)))
(initialize instance initargs)
instance))
@@ -1400,7 +1413,7 @@
;;; - the currified protocol would be imho inefficient in C.
;;;
-(define-method apply-generic ((gf <generic>) args)
+(define-method (apply-generic (gf <generic>) args)
(if (null? (slot-ref gf 'methods))
(no-method gf args))
(let ((methods (compute-applicable-methods gf args)))
@@ -1413,24 +1426,24 @@
(define %%compute-applicable-methods
(make <generic> #:name 'compute-applicable-methods))
-(define-method %%compute-applicable-methods ((gf <generic>) args)
+(define-method (%%compute-applicable-methods (gf <generic>) args)
(%compute-applicable-methods gf args))
(set! compute-applicable-methods %%compute-applicable-methods)
-(define-method sort-applicable-methods ((gf <generic>) methods args)
+(define-method (sort-applicable-methods (gf <generic>) methods args)
(let ((targs (map class-of args)))
(sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
-(define-method method-more-specific? ((m1 <method>) (m2 <method>) targs)
+(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
(%method-more-specific? m1 m2 targs))
-(define-method apply-method ((gf <generic>) methods build-next args)
+(define-method (apply-method (gf <generic>) methods build-next args)
(apply (method-procedure (car methods))
(build-next (cdr methods) args)
args))
-(define-method apply-methods ((gf <generic>) (l <list>) args)
+(define-method (apply-methods (gf <generic>) (l <list>) args)
(letrec ((next (lambda (procs args)
(lambda new-args
(let ((a (if (null? new-args) args new-args)))
diff --git a/oop/goops/Makefile.am b/oop/goops/Makefile.am
index 73a77e474..b80216bbc 100644
--- a/oop/goops/Makefile.am
+++ b/oop/goops/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 2000 Free Software Foundation, Inc.
+## Copyright (C) 2000, 2001 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -24,7 +24,8 @@ AUTOMAKE_OPTIONS = foreign
# These should be installed and distributed.
goops_sources = \
active-slot.scm compile.scm composite-slot.scm describe.scm \
- dispatch.scm internal.scm save.scm stklos.scm util.scm
+ dispatch.scm internal.scm save.scm stklos.scm util.scm \
+ old-define-method.scm
subpkgdatadir = $(pkgdatadir)/$(VERSION)/oop/goops
subpkgdata_DATA = $(goops_sources)
diff --git a/oop/goops/active-slot.scm b/oop/goops/active-slot.scm
index ca9424d0f..46e6aa921 100644
--- a/oop/goops/active-slot.scm
+++ b/oop/goops/active-slot.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1999 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -33,7 +33,7 @@
(define-class <active-class> (<class>))
-(define-method compute-get-n-set ((class <active-class>) slot)
+(define-method (compute-get-n-set (class <active-class>) slot)
(if (eq? (slot-definition-allocation slot) #:active)
(let* ((index (slot-ref class 'nfields))
(name (car slot))
diff --git a/oop/goops/composite-slot.scm b/oop/goops/composite-slot.scm
index 4f44f0619..32e8d9eaf 100644
--- a/oop/goops/composite-slot.scm
+++ b/oop/goops/composite-slot.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -50,7 +50,7 @@
(define-class <composite-class> (<class>))
-(define-method compute-get-n-set ((class <composite-class>) slot)
+(define-method (compute-get-n-set (class <composite-class>) slot)
(if (eq? (slot-definition-allocation slot) #:propagated)
(compute-propagated-get-n-set slot)
(next-method)))
diff --git a/oop/goops/describe.scm b/oop/goops/describe.scm
index c6e51084e..e268fb877 100644
--- a/oop/goops/describe.scm
+++ b/oop/goops/describe.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1998, 1999 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2001 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -36,7 +36,7 @@
;;;
;;; describe for simple objects
;;;
-(define-method describe ((x <top>))
+(define-method (describe (x <top>))
(format #t "~s is " x)
(cond
((integer? x) (format #t "an integer"))
@@ -62,7 +62,7 @@
(format #t ".~%")
*unspecified*)
-(define-method describe ((x <procedure>))
+(define-method (describe (x <procedure>))
(let ((name (procedure-name x)))
(if name
(format #t "`~s'" name)
@@ -84,7 +84,7 @@
(class-name class)
class))
-(define-method describe ((x <object>))
+(define-method (describe (x <object>))
(format #t "~S is an instance of class ~A~%"
x (safe-class-name (class-of x)))
@@ -103,7 +103,7 @@
;;;
;;; Describe for classes
;;;
-(define-method describe ((x <class>))
+(define-method (describe (x <class>))
(format #t "~S is a class. It's an instance of ~A~%"
(safe-class-name x) (safe-class-name (class-of x)))
@@ -156,7 +156,7 @@
;;;
;;; Describe for generic functions
;;;
-(define-method describe ((x <generic>))
+(define-method (describe (x <generic>))
(let ((name (generic-function-name x))
(methods (generic-function-methods x)))
;; Title
@@ -172,7 +172,7 @@
;;;
;;; Describe for methods
;;;
-(define-method describe ((x <method>) . omit-generic)
+(define-method (describe (x <method>) . omit-generic)
(letrec ((print-args (lambda (args)
;; take care of dotted arg lists
(cond ((null? args) (newline))
diff --git a/oop/goops/old-define-method.scm b/oop/goops/old-define-method.scm
new file mode 100644
index 000000000..915b5b25c
--- /dev/null
+++ b/oop/goops/old-define-method.scm
@@ -0,0 +1,62 @@
+;;; installed-scm-file
+
+;;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+
+
+(define-module (oop goops old-define-method)
+ :use-module (oop goops)
+ :no-backtrace
+ )
+
+(export define-method)
+
+(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)))))))))))
diff --git a/oop/goops/save.scm b/oop/goops/save.scm
index e2a9e54d7..fa13778bd 100644
--- a/oop/goops/save.scm
+++ b/oop/goops/save.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 2000 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -88,22 +88,22 @@
;;; literal? COMPONENT ENV
;;;
-(define-method immediate? ((o <top>)) #f)
+(define-method (immediate? (o <top>)) #f)
-(define-method immediate? ((o <null>)) #t)
-(define-method immediate? ((o <number>)) #t)
-(define-method immediate? ((o <boolean>)) #t)
-(define-method immediate? ((o <symbol>)) #t)
-(define-method immediate? ((o <char>)) #t)
-(define-method immediate? ((o <keyword>)) #t)
+(define-method (immediate? (o <null>)) #t)
+(define-method (immediate? (o <number>)) #t)
+(define-method (immediate? (o <boolean>)) #t)
+(define-method (immediate? (o <symbol>)) #t)
+(define-method (immediate? (o <char>)) #t)
+(define-method (immediate? (o <keyword>)) #t)
;;; enumerate! OBJECT ENVIRONMENT
;;;
;;; Return #t if object is a literal.
;;;
-(define-method enumerate! ((o <top>) env) #t)
+(define-method (enumerate! (o <top>) env) #t)
-(define-method write-readably ((o <top>) file env)
+(define-method (write-readably (o <top>) file env)
;;(goops-error "No read-syntax defined for object `~S'" o)
(write o file) ;doesn't catch bugs, but is much more flexible
)
@@ -135,13 +135,13 @@
;;; Strings
;;;
-(define-method enumerate! ((o <string>) env) #f)
+(define-method (enumerate! (o <string>) env) #f)
;;;
;;; Vectors
;;;
-(define-method enumerate! ((o <vector>) env)
+(define-method (enumerate! (o <vector>) env)
(or (not (vector? o))
(let ((literal? #t))
(array-for-each (lambda (o)
@@ -150,7 +150,7 @@
o)
literal?)))
-(define-method write-readably ((o <vector>) file env)
+(define-method (write-readably (o <vector>) file env)
(if (not (vector? o))
(write o file)
(let ((n (vector-length o)))
@@ -185,7 +185,7 @@
;;; Arrays
;;;
-(define-method enumerate! ((o <array>) env)
+(define-method (enumerate! (o <array>) env)
(enumerate-component! (shared-array-root o) env))
(define (make-mapper array)
@@ -249,7 +249,7 @@
(display #\) file))))))
(display #\) file)))
-(define-method write-readably ((o <array>) file env)
+(define-method (write-readably (o <array>) file env)
(let ((root (shared-array-root o)))
(cond ((literal? o env)
(if (not (vector? root))
@@ -288,12 +288,12 @@
;;; `write-component'.
;;;
-(define-method enumerate! ((o <pair>) env)
+(define-method (enumerate! (o <pair>) env)
(let ((literal? (enumerate-component! (car o) env)))
(and (enumerate-component! (cdr o) env)
literal?)))
-(define-method write-readably ((o <pair>) file env)
+(define-method (write-readably (o <pair>) file env)
(let ((proper? (let loop ((ls o))
(or (null? ls)
(and (pair? ls)
@@ -390,7 +390,7 @@
(list ,@(cdddr exp)))
o))))
-(define-method enumerate! ((o <object>) env)
+(define-method (enumerate! (o <object>) env)
(get-set-for-each (lambda (get set)
(let ((val (get o)))
(if (not (unbound? val))
@@ -398,7 +398,7 @@
(class-of o))
#f)
-(define-method write-readably ((o <object>) file env)
+(define-method (write-readably (o <object>) file env)
(let ((class (class-of o)))
(display "(restore " file)
(display (class-name class) file)
@@ -444,9 +444,9 @@
;;; Currently, we don't support reading in class objects
;;;
-(define-method enumerate! ((o <class>) env) #f)
+(define-method (enumerate! (o <class>) env) #f)
-(define-method write-readably ((o <class>) file env)
+(define-method (write-readably (o <class>) file env)
(display (class-name o) file))
;;;
@@ -456,9 +456,9 @@
;;; Currently, we don't support reading in generic functions
;;;
-(define-method enumerate! ((o <generic>) env) #f)
+(define-method (enumerate! (o <generic>) env) #f)
-(define-method write-readably ((o <generic>) file env)
+(define-method (write-readably (o <generic>) file env)
(display (generic-function-name o) file))
;;;
@@ -468,9 +468,9 @@
;;; Currently, we don't support reading in methods
;;;
-(define-method enumerate! ((o <method>) env) #f)
+(define-method (enumerate! (o <method>) env) #f)
-(define-method write-readably ((o <method>) file env)
+(define-method (write-readably (o <method>) file env)
(goops-error "No read-syntax for <method> defined"))
;;;
@@ -820,13 +820,13 @@
written)))))
alist)))
-(define-method save-objects ((alist <pair>) (file <string>) . rest)
+(define-method (save-objects (alist <pair>) (file <string>) . rest)
(let ((port (open-output-file file)))
(apply save-objects alist port rest)
(close-port port)
*unspecified*))
-(define-method save-objects ((alist <pair>) (file <output-port>) . rest)
+(define-method (save-objects (alist <pair>) (file <output-port>) . rest)
(let ((excluded (if (>= (length rest) 1) (car rest) '()))
(uses (if (>= (length rest) 2) (cadr rest) '())))
(let ((env (make <environment> #:excluded excluded)))
@@ -853,13 +853,13 @@
(write-readables! alist file env)
(write-rebindings! "(define " (reverse (multiple-bound env)) file env))))
-(define-method load-objects ((file <string>))
+(define-method (load-objects (file <string>))
(let* ((port (open-input-file file))
(objects (load-objects port)))
(close-port port)
objects))
-(define-method load-objects ((file <input-port>))
+(define-method (load-objects (file <input-port>))
(let ((m (make-module)))
(module-use! m the-scm-module)
(module-use! m %module-public-interface)