diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2001-03-10 03:09:50 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2001-03-10 03:09:50 +0000 |
commit | 71d540f734534c3a783d9b65fd84a3a299402b86 (patch) | |
tree | 396a8c9453f2679581fdd0478346048cee9eb6b8 | |
parent | e75341b38d65736421ace4b75f405b0bcdaacf9c (diff) | |
download | guile-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/ChangeLog | 11 | ||||
-rw-r--r-- | oop/goops.scm | 181 | ||||
-rw-r--r-- | oop/goops/Makefile.am | 5 | ||||
-rw-r--r-- | oop/goops/active-slot.scm | 4 | ||||
-rw-r--r-- | oop/goops/composite-slot.scm | 4 | ||||
-rw-r--r-- | oop/goops/describe.scm | 14 | ||||
-rw-r--r-- | oop/goops/old-define-method.scm | 62 | ||||
-rw-r--r-- | oop/goops/save.scm | 58 |
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) |