;;; installed-scm-file
-;;;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 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 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 program is distributed in the hope that it will be useful,
+;;;; 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 General Public License for more details.
+;;;; 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 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
+;;;; 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)
- :use-module (oop goops goopscore)
- :use-module (oop goops util)
- :use-module (oop goops dispatch)
- :use-module (oop goops compile)
- :no-backtrace
- )
-
-(export ; Define the exported symbols of this file
- goops-version is-a?
- ensure-metaclass ensure-metaclass-with-supers
- define-class class make-class
- define-generic make-generic ensure-generic
- define-accessor make-accessor ensure-accessor
- define-method make-method method add-method!
- object-eqv? object-equal?
- class-slot-ref class-slot-set! slot-unbound slot-missing
- slot-definition-name slot-definition-options slot-definition-allocation
- slot-definition-getter slot-definition-setter slot-definition-accessor
- slot-definition-init-value slot-definition-init-form
- slot-definition-init-thunk slot-definition-init-keyword
- slot-init-function class-slot-definition
- method-source
- compute-cpl compute-std-cpl compute-get-n-set compute-slots
- compute-getter-method compute-setter-method
- allocate-instance initialize make-instance make
- no-next-method no-applicable-method no-method
- change-class update-instance-for-different-class
- shallow-clone deep-clone
- class-redefinition
- apply-generic apply-method apply-methods
- compute-applicable-methods %compute-applicable-methods
- method-more-specific? sort-applicable-methods
- class-subclasses class-methods
- goops-error
- min-fixnum max-fixnum
-)
-
-;;; *fixme* Should go into goops.c
-
-(export
- instance? slot-ref-using-class
- slot-set-using-class! slot-bound-using-class?
- slot-exists-using-class? slot-ref slot-set! slot-bound? class-of
- class-name class-direct-supers class-direct-subclasses
- class-direct-methods class-direct-slots class-precedence-list
- class-slots class-environment
- generic-function-name
- generic-function-methods method-generic-function method-specializers
- primitive-generic-generic enable-primitive-generic!
- method-procedure accessor-method-slot-definition
- slot-exists? make find-method get-keyword
- %logand)
+ :export-syntax (define-class class standard-define-class
+ define-generic define-accessor define-method
+ define-extended-generic define-extended-generics
+ method)
+ :export (goops-version is-a? class-of
+ ensure-metaclass ensure-metaclass-with-supers
+ make-class
+ make-generic ensure-generic
+ make-extended-generic
+ make-accessor ensure-accessor
+ process-class-pre-define-generic
+ process-class-pre-define-accessor
+ process-define-generic
+ process-define-accessor
+ make-method add-method!
+ object-eqv? object-equal?
+ class-slot-ref class-slot-set! slot-unbound slot-missing
+ slot-definition-name slot-definition-options
+ slot-definition-allocation
+ slot-definition-getter slot-definition-setter
+ slot-definition-accessor
+ slot-definition-init-value slot-definition-init-form
+ slot-definition-init-thunk slot-definition-init-keyword
+ slot-init-function class-slot-definition
+ method-source
+ compute-cpl compute-std-cpl compute-get-n-set compute-slots
+ compute-getter-method compute-setter-method
+ allocate-instance initialize make-instance make
+ no-next-method no-applicable-method no-method
+ change-class update-instance-for-different-class
+ shallow-clone deep-clone
+ class-redefinition
+ apply-generic apply-method apply-methods
+ compute-applicable-methods %compute-applicable-methods
+ method-more-specific? sort-applicable-methods
+ class-subclasses class-methods
+ goops-error
+ min-fixnum max-fixnum
+ ;;; *fixme* Should go into goops.c
+ instance? slot-ref-using-class
+ slot-set-using-class! slot-bound-using-class?
+ slot-exists-using-class? slot-ref slot-set! slot-bound?
+ class-name class-direct-supers class-direct-subclasses
+ class-direct-methods class-direct-slots class-precedence-list
+ class-slots class-environment
+ generic-function-name
+ generic-function-methods method-generic-function method-specializers
+ primitive-generic-generic enable-primitive-generic!
+ method-procedure accessor-method-slot-definition
+ slot-exists? make find-method get-keyword)
+ :replace (<class> <operator-class> <entity-class> <entity>)
+ :no-backtrace)
+
+;; First initialize the builtin part of GOOPS
+(%init-goops-builtins)
+
+;; Then load the rest of GOOPS
+(use-modules (oop goops util)
+ (oop goops dispatch)
+ (oop goops compile))
\f
(define min-fixnum (- (expt 2 29)))
(define (define-class-pre-definition keyword exp env)
(case keyword
((#:getter #:setter)
- (if (defined? exp env)
- `(define ,exp (ensure-generic ,exp ',exp))
- `(define ,exp (make-generic ',exp))))
+ `(process-class-pre-define-generic ',exp))
((#:accessor)
- (if (defined? exp env)
- `(define ,exp (ensure-accessor ,exp ',exp))
- `(define ,exp (make-accessor ',exp))))
+ `(process-class-pre-define-accessor ',exp))
(else #f)))
+(define (process-class-pre-define-generic name)
+ (let ((var (module-variable (current-module) name)))
+ (if (not (and var
+ (variable-bound? var)
+ (is-a? (variable-ref var) <generic>)))
+ (process-define-generic name))))
+
+(define (process-class-pre-define-accessor name)
+ (let ((var (module-variable (current-module) name)))
+ (cond ((or (not var)
+ (not (variable-bound? var)))
+ (process-define-accessor name))
+ ((or (is-a? (variable-ref var) <accessor>)
+ (is-a? (variable-ref var) <extended-generic-with-setter>)))
+ ((is-a? (variable-ref var) <generic>)
+ ;;*fixme* don't mutate an imported object!
+ (variable-set! var (ensure-accessor (variable-ref var) name)))
+ (else
+ (process-define-accessor name)))))
+
;;; This code should be implemented in C.
;;;
(define define-class
(name cadr)
(slots cdddr))
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
(cond ((not (top-level-env? env))
(goops-error "define-class: Only allowed at top level"))
`(begin
;; define accessors
,@(pre-definitions (slots exp) env)
-
- ,(if (defined? name env)
-
- ;; redefine an old class
- `(define ,name
- (let ((old ,name)
- (new (class ,@(cddr exp) #:name ',name)))
- (if (and (is-a? old <class>)
- ;; Prevent redefinition of non-objects
- (memq <object>
- (class-precedence-list old)))
- (class-redefinition old new)
- new)))
-
- ;; define a new class
- `(define ,name
- (class ,@(cddr exp) #:name ',name)))))))))))
+ ;; update the current-module
+ (let* ((class (class ,@(cddr exp) #:name ',name))
+ (var (module-ensure-local-variable!
+ (current-module) ',name))
+ (old (and (variable-bound? var)
+ (variable-ref var))))
+ (if (and old
+ (is-a? old <class>)
+ (memq <object> (class-precedence-list old)))
+ (variable-set! var (class-redefinition old class))
+ (variable-set! var class)))))))))))
(define standard-define-class define-class)
;;;
(define define-generic
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" name))
- ((defined? name env)
- `(define ,name
- (if (is-a? ,name <generic>)
- (make <generic> #:name ',name)
- (ensure-generic ,name ',name))))
+ ((top-level-env? env)
+ `(process-define-generic ',name))
(else
`(define ,name (make <generic> #:name ',name))))))))
+(define (process-define-generic name)
+ (let ((var (module-ensure-local-variable! (current-module) name)))
+ (if (or (not var)
+ (not (variable-bound? var))
+ (is-a? (variable-ref var) <generic>))
+ ;; redefine if NAME isn't defined previously, or is another generic
+ (variable-set! var (make <generic> #:name name))
+ ;; otherwise try to upgrade the object to a generic
+ (variable-set! var (ensure-generic (variable-ref var) name)))))
+
+(define define-extended-generic
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (cond ((not (symbol? name))
+ (goops-error "bad generic function name: ~S" name))
+ ((null? (cddr exp))
+ (goops-error "missing expression"))
+ (else
+ `(define ,name (make-extended-generic ,(caddr exp) ',name))))))))
+(define define-extended-generics
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((names (cadr exp))
+ (prefixes (get-keyword #:prefix (cddr exp) #f)))
+ (if prefixes
+ `(begin
+ ,@(map (lambda (name)
+ `(define-extended-generic ,name
+ (list ,@(map (lambda (prefix)
+ (symbol-append prefix name))
+ prefixes))))
+ names))
+ (goops-error "no prefixes supplied"))))))
+
(define (make-generic . name)
(let ((name (and (pair? name) (car name))))
(make <generic> #:name name)))
+(define (make-extended-generic gfs . name)
+ (let* ((name (and (pair? name) (car name)))
+ (gfs (if (pair? gfs) gfs (list gfs)))
+ (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
+ (let ((ans (if gws?
+ (let* ((sname (and name (make-setter-name name)))
+ (setters
+ (apply append
+ (map (lambda (gf)
+ (if (is-a? gf <generic-with-setter>)
+ (list (ensure-generic (setter gf)
+ sname))
+ '()))
+ gfs)))
+ (es (make <extended-generic-with-setter>
+ #:name name
+ #:extends gfs
+ #:setter (make <extended-generic>
+ #:name sname
+ #:extends setters))))
+ (extended-by! setters (setter es))
+ es)
+ (make <extended-generic>
+ #:name name
+ #:extends gfs))))
+ (extended-by! gfs ans)
+ ans)))
+
+(define (extended-by! gfs eg)
+ (for-each (lambda (gf)
+ (slot-set! gf 'extended-by
+ (cons eg (slot-ref gf 'extended-by))))
+ gfs))
+
+(define (not-extended-by! gfs eg)
+ (for-each (lambda (gf)
+ (slot-set! gf 'extended-by
+ (delq! eg (slot-ref gf 'extended-by))))
+ gfs))
+
(define (ensure-generic old-definition . name)
(let ((name (and (pair? name) (car name))))
(cond ((is-a? old-definition <generic>) old-definition)
(else (make <generic> #:name name)))))
(define define-accessor
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" name))
- ((defined? name env)
- `(define ,name
- (if (and (is-a? ,name <generic-with-setter>)
- (is-a? (setter ,name) <generic>))
- (make-accessor ',name)
- (ensure-accessor ,name ',name))))
+ ((top-level-env? env)
+ `(process-define-accessor ',name))
(else
`(define ,name (make-accessor ',name))))))))
+(define (process-define-accessor name)
+ (let ((var (module-ensure-local-variable! (current-module) name)))
+ (if (or (not var)
+ (not (variable-bound? var))
+ (is-a? (variable-ref var) <accessor>)
+ (is-a? (variable-ref var) <extended-generic-with-setter>))
+ ;; redefine if NAME isn't defined previously, or is another accessor
+ (variable-set! var (make-accessor name))
+ ;; otherwise try to upgrade the object to an accessor
+ (variable-set! var (ensure-accessor (variable-ref var) name)))))
+
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
(define (make-accessor . name)
(let ((name (and (pair? name) (car name))))
- (make <generic-with-setter>
+ (make <accessor>
#:name name
#:setter (make <generic>
#:name (and name (make-setter-name name))))))
(define (ensure-accessor proc . name)
(let ((name (and (pair? name) (car name))))
- (cond ((is-a? proc <generic-with-setter>)
- (if (is-a? (setter proc) <generic>)
- proc
- (upgrade-generic-with-setter proc (setter proc))))
+ (cond ((and (is-a? proc <accessor>)
+ (is-a? (setter proc) <generic>))
+ proc)
+ ((is-a? proc <generic-with-setter>)
+ (upgrade-accessor proc (setter proc)))
((is-a? proc <generic>)
- (upgrade-generic-with-setter proc (make-generic name)))
+ (upgrade-accessor proc (make-generic name)))
((procedure-with-setter? proc)
- (make <generic-with-setter>
+ (make <accessor>
#:name name
#:default (procedure proc)
#:setter (ensure-generic (setter proc) name)))
(else
(make-accessor name)))))
-(define (upgrade-generic-with-setter generic setter)
- (let ((methods (generic-function-methods generic))
- (gws (make <generic-with-setter>
+(define (upgrade-accessor generic setter)
+ (let ((methods (slot-ref generic 'methods))
+ (gws (make (if (is-a? generic <extended-generic>)
+ <extended-generic-with-setter>
+ <accessor>)
#:name (generic-function-name generic)
+ #:extended-by (slot-ref generic 'extended-by)
#:setter setter)))
+ (if (is-a? generic <extended-generic>)
+ (let ((gfs (slot-ref generic 'extends)))
+ (not-extended-by! gfs generic)
+ (slot-set! gws 'extends gfs)
+ (extended-by! gfs gws)))
;; Steal old methods
(for-each (lambda (method)
(slot-set! method 'generic-function gws))
(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>
(define method
(letrec ((specializers
(lambda (ls)
- (cond ((null? ls) (list ls))
+ (cond ((null? ls) (list (list 'quote '())))
((pair? ls) (cons (if (pair? (car ls))
(cadar ls)
'<top>)
(let ((args (cadr exp))
(body (cddr exp)))
`(make <method>
- #:specializers (list* ,@(specializers args))
+ #:specializers (cons* ,@(specializers args))
#:procedure (lambda ,(formals args)
,@(if (null? body)
(list *unspecified*)
(define (compute-new-list-of-methods gf new)
(let ((new-spec (method-specializers new))
- (methods (generic-function-methods gf)))
+ (methods (slot-ref gf 'methods)))
(let loop ((l methods))
(if (null? l)
(cons new methods)
(slot-set! gf 'methods (compute-new-list-of-methods gf m))
(let ((specializers (slot-ref m 'specializers)))
(slot-set! gf 'n-specialized
- (let ((n-specialized (slot-ref gf 'n-specialized)))
- ;; The magnitude indicates # specializers.
- ;; A negative value indicates that at least one
- ;; method has rest arguments. (Ugly but effective
- ;; space optimization saving one slot in GF objects.)
- (cond ((negative? n-specialized)
- (- (max (+ 1 (length* specializers))
- (abs n-specialized))))
- ((list? specializers)
- (max (length specializers)
- n-specialized))
- (else
- (- (+ 1 (max (length* specializers)
- n-specialized)))))
- )))
+ (max (length* specializers)
+ (slot-ref gf 'n-specialized))))
(%invalidate-method-cache! gf)
(add-method-in-classes! m)
*unspecified*)
#: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))
;;;
;;;
;;; 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))
;;; Methods to compare objects
;;;
-(define-method object-eqv? (x y) #f)
-(define-method object-equal? (x y) (eqv? x y))
+(define-method (eqv? x y) #f)
+(define-method (equal? x y) (eqv? x y))
+
+;;; These following two methods are for backward compatibility only.
+;;; They are not called by the Guile interpreter.
+;;;
+(define-method (object-eqv? x y) #f)
+(define-method (object-equal? x y) (eqv? x y))
;;;
;;; methods to display/write an object
(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
(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
(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))
(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))
(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))
(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))
+;;;
+;;; Handling of duplicate bindings in the module system
+;;;
+
+(define-method (merge-generics (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <top>)
+ (int2 <module>)
+ (val2 <top>)
+ (var <top>)
+ (val <top>))
+ #f)
+
+(define-method (merge-generics (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <generic>)
+ (int2 <module>)
+ (val2 <generic>)
+ (var <top>)
+ (val <boolean>))
+ (and (not (eq? val1 val2))
+ (make-variable (make-extended-generic (list val2 val1) name))))
+
+(define-method (merge-generics (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <generic>)
+ (int2 <module>)
+ (val2 <generic>)
+ (var <top>)
+ (gf <extended-generic>))
+ (and (not (memq val2 (slot-ref gf 'extends)))
+ (begin
+ (slot-set! gf
+ 'extends
+ (cons val2 (delq! val2 (slot-ref gf 'extends))))
+ (slot-set! val2
+ 'extended-by
+ (cons gf (delq! gf (slot-ref val2 'extended-by))))
+ var)))
+
+(module-define! duplicate-handlers 'merge-generics merge-generics)
+
+(define-method (merge-accessors (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <top>)
+ (int2 <module>)
+ (val2 <top>)
+ (var <top>)
+ (val <top>))
+ #f)
+
+(define-method (merge-accessors (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <accessor>)
+ (int2 <module>)
+ (val2 <accessor>)
+ (var <top>)
+ (val <top>))
+ (merge-generics module name int1 val1 int2 val2 var val))
+
+(module-define! duplicate-handlers 'merge-accessors merge-accessors)
+
;;;
;;; slot access
;;;
(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)))))
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)))))
;;; 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
;;; 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)))
+ (let ((gf (slot-ref m 'generic-function)))
+ ;; remove the method from its GF
+ (slot-set! gf 'methods
+ (delq1! m (slot-ref gf 'methods)))
+ (%invalidate-method-cache! gf)
+ ;; remove the method from its specializers
+ (remove-method-in-classes! m))))
(class-direct-methods c)))
;;;
;;; 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)))
;;; update-direct-subclass!
;;;
-(define-method update-direct-subclass! ((c <class>)
+(define-method (update-direct-subclass! (c <class>)
(old <class>)
(new <class>))
(class-redefinition c
(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>
#:specializers (list class)
#:procedure (cond ((pair? g-n-s)
- (if init-thunk
- (car g-n-s)
- (make-generic-bound-check-getter (car g-n-s))
- ))
+ (make-generic-bound-check-getter (car g-n-s)))
(init-thunk
(standard-get g-n-s))
(else
(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>)
(define standard-set (standard-accessor-method make-set standard-set-methods))
;;; compute-getters-n-setters
-;;;
+;;;
+(define (make-thunk thunk)
+ (lambda () (thunk)))
+
(define (compute-getters-n-setters class slots env)
- (define (compute-slot-init-function s)
- (or (slot-definition-init-thunk s)
+ (define (compute-slot-init-function name s)
+ (or (let ((thunk (slot-definition-init-thunk s)))
+ (and thunk
+ (cond ((not (thunk? thunk))
+ (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+ name class thunk))
+ ((closure? thunk) thunk)
+ (else (make-thunk thunk)))))
(let ((init (slot-definition-init-value s)))
(and (not (unbound? init))
(lambda () init)))))
(define (verify-accessors slot l)
- (if (pair? l)
- (let ((get (car l))
- (set (cadr l)))
- (if (not (and (closure? get)
- (= (car (procedure-property get 'arity)) 1)))
- (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
- slot class get))
- (if (not (and (closure? set)
- (= (car (procedure-property set 'arity)) 2)))
- (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
- slot class set)))))
+ (cond ((integer? l))
+ ((not (and (list? l) (= (length l) 2)))
+ (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
+ slot class l))
+ (else
+ (let ((get (car l))
+ (set (cadr l)))
+ (if (not (and (closure? get)
+ (= (car (procedure-property get 'arity)) 1)))
+ (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+ slot class get))
+ (if (not (and (closure? set)
+ (= (car (procedure-property set 'arity)) 2)))
+ (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+ slot class set))))))
(map (lambda (s)
- (let* ((g-n-s (compute-get-n-set class s))
+ ;; The strange treatment of nfields is due to backward compatibility.
+ (let* ((index (slot-ref class 'nfields))
+ (g-n-s (compute-get-n-set class s))
+ (size (- (slot-ref class 'nfields) index))
(name (slot-definition-name s)))
- ; For each slot we have '(name init-function getter setter)
- ; If slot, we have the simplest form '(name init-function . index)
+ ;; NOTE: The following is interdependent with C macros
+ ;; defined above goops.c:scm_sys_prep_layout_x.
+ ;;
+ ;; For simple instance slots, we have the simplest form
+ ;; '(name init-function . index)
+ ;; For other slots we have
+ ;; '(name init-function getter setter . alloc)
+ ;; where alloc is:
+ ;; '(index size) for instance allocated slots
+ ;; '() for other slots
(verify-accessors name g-n-s)
(cons name
- (cons (compute-slot-init-function s)
- g-n-s))))
+ (cons (compute-slot-init-function name s)
+ (if (or (integer? g-n-s)
+ (zero? size))
+ g-n-s
+ (append g-n-s (list index size)))))))
slots))
;;; compute-cpl
;;; => 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
can-go-in-now))))
(loop
(filter (lambda (x) (not (eq? x choice)))
- elements)
+ elements)
constraints
(append result (list choice)))))))))
;;; 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
(set (get-keyword #:slot-set! (slot-definition-options s) #f))
(env (class-environment class)))
(if (not (and get set))
- (goops-error "You must supply a :slot-ref and a :slot-set! in ~S"
+ (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
s))
(list get set)))
(else (next-method))))
(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 '()))
;; Set the layout slot
(%prep-layout! class)))
-(define object-procedure-tags
- '(utag_closure utag_subr_1 utag_subr_2 utag_subr3 utag_lsubr_2))
-
(define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f)))
(cond ((not proc))
((pair? proc)
(apply set-object-procedure! object proc))
- ((memq (tag proc) object-procedure-tags)
+ ((valid-object-procedure? proc)
(set-object-procedure! object proc))
(else
(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)
(set-procedure-property! generic 'name name))
))
-(define-method initialize ((method <method>) initargs)
+(define-method (initialize (eg <extended-generic>) initargs)
+ (next-method)
+ (slot-set! eg 'extends (get-keyword #:extends initargs '())))
+
+(define dummy-procedure (lambda args *unspecified*))
+
+(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 '()))
- (slot-set! method 'procedure (get-keyword #:procedure initargs (lambda l '())))
+ (slot-set! method 'procedure
+ (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}
;;;
(define (change-object-class old-instance old-class new-class)
- (let ((new-instance (allocate-instance new-class ())))
- ;; Initalize the slot of the new instance
+ (let ((new-instance (allocate-instance new-class '())))
+ ;; Initialize the slots of the new instance
(for-each (lambda (slot)
(if (and (slot-exists-using-class? old-class old-instance slot)
(eq? (slot-definition-allocation
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))
;;;
;;; 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))
;;; - 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)))
(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)))
HCoop / bpt / guile.git / blobdiff