;;; installed-scm-file
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
;;;; 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 3 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
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
-;;;; This file is based upon stklos.stk from the STk distribution by
-;;;; Erick Gallesio <eg@unice.fr>.
+;;;; This file was based upon stklos.stk from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
;;;;
(define-module (oop goops)
#'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...)))))))
-(define-syntax define-class
- (syntax-rules ()
- ((_ name supers slot ...)
- (begin
- (define-class-pre-definitions (slot ...))
- (if (and (defined? 'name)
- (is-a? name <class>)
- (memq <object> (class-precedence-list name)))
- (class-redefinition name
- (class supers slot ... #:name 'name))
- (toplevel-define! 'name (class supers slot ... #:name 'name)))))))
+(define-syntax-rule (define-class name supers slot ...)
+ (begin
+ (define-class-pre-definitions (slot ...))
+ (if (and (defined? 'name)
+ (is-a? name <class>)
+ (memq <object> (class-precedence-list name)))
+ (class-redefinition name
+ (class supers slot ... #:name 'name))
+ (toplevel-define! 'name (class supers slot ... #:name 'name)))))
-(define-syntax standard-define-class
- (syntax-rules ()
- ((_ arg ...) (define-class arg ...))))
+(define-syntax-rule (standard-define-class arg ...)
+ (define-class arg ...))
;;;
;;; {Generic functions and accessors}
names))
(goops-error "no prefixes supplied"))))
-(define (make-generic . name)
- (let ((name (and (pair? name) (car name))))
- (make <generic> #:name name)))
+(define* (make-generic #:optional 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)))
+(define* (make-extended-generic gfs #:optional name)
+ (let* ((gfs (if (list? 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)))
(for-each (lambda (gf)
(slot-set! gf 'extended-by
(cons eg (slot-ref gf 'extended-by))))
- gfs))
+ gfs)
+ (invalidate-method-cache! eg))
(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)
- ((procedure-with-setter? old-definition)
- (make <generic-with-setter>
- #:name name
- #:default (procedure old-definition)
- #:setter (setter old-definition)))
- ((procedure? old-definition)
- (if (generic-capability? old-definition) old-definition
- (make <generic> #:name name #:default old-definition)))
- (else (make <generic> #:name name)))))
+ gfs)
+ (invalidate-method-cache! eg))
+
+(define* (ensure-generic old-definition #:optional name)
+ (cond ((is-a? old-definition <generic>) old-definition)
+ ((procedure-with-setter? old-definition)
+ (make <generic-with-setter>
+ #:name name
+ #:default (procedure old-definition)
+ #:setter (setter old-definition)))
+ ((procedure? old-definition)
+ (if (generic-capability? old-definition) old-definition
+ (make <generic> #:name name #:default old-definition)))
+ (else (make <generic> #:name name))))
;; same semantics as <generic>
-(define-syntax define-accessor
- (syntax-rules ()
- ((_ name)
- (define name
- (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
- ((is-a? name <accessor>) (make <accessor> #:name 'name))
- (else (ensure-accessor name 'name)))))))
+(define-syntax-rule (define-accessor name)
+ (define name
+ (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
+ ((is-a? name <accessor>) (make <accessor> #:name 'name))
+ (else (ensure-accessor name '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 <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 ((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-accessor proc (make-generic name)))
- ((procedure-with-setter? proc)
- (make <accessor>
- #:name name
- #:default (procedure proc)
- #:setter (ensure-generic (setter proc) name)))
- ((procedure? proc)
- (ensure-accessor (if (generic-capability? proc)
- (make <generic> #:name name #:default proc)
- (ensure-generic proc name))
- name))
- (else
- (make-accessor name)))))
+(define* (make-accessor #:optional name)
+ (make <accessor>
+ #:name name
+ #:setter (make <generic>
+ #:name (and name (make-setter-name name)))))
+
+(define* (ensure-accessor proc #:optional name)
+ (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-accessor proc (make-generic name)))
+ ((procedure-with-setter? proc)
+ (make <accessor>
+ #:name name
+ #:default (procedure proc)
+ #:setter (ensure-generic (setter proc) name)))
+ ((procedure? proc)
+ (ensure-accessor (if (generic-capability? proc)
+ (make <generic> #:name name #:default proc)
+ (ensure-generic proc name))
+ name))
+ (else
+ (make-accessor name))))
(define (upgrade-accessor generic setter)
(let ((methods (slot-ref generic 'methods))
(slot-set! method 'generic-function gws))
methods)
(slot-set! gws 'methods methods)
+ (invalidate-method-cache! gws)
gws))
;;;
methods)
(loop (cdr l)))))))
+(define (method-n-specializers m)
+ (length* (slot-ref m 'specializers)))
+
+(define (calculate-n-specialized gf)
+ (fold (lambda (m n) (max n (method-n-specializers m)))
+ 0
+ (generic-function-methods gf)))
+
+(define (invalidate-method-cache! gf)
+ (%invalidate-method-cache! gf)
+ (slot-set! gf 'n-specialized (calculate-n-specialized gf))
+ (for-each (lambda (gf) (invalidate-method-cache! gf))
+ (slot-ref gf 'extended-by)))
+
(define internal-add-method!
(method ((gf <generic>) (m <method>))
(slot-set! m 'generic-function gf)
(slot-set! gf 'methods (compute-new-list-of-methods gf m))
- (let ((specializers (slot-ref m 'specializers)))
- (slot-set! gf 'n-specialized
- (max (length* specializers)
- (slot-ref gf 'n-specialized))))
- (%invalidate-method-cache! gf)
+ (invalidate-method-cache! gf)
(add-method-in-classes! m)
*unspecified*))
(slot-set! val2
'extended-by
(cons gf (delq! gf (slot-ref val2 'extended-by))))
+ (invalidate-method-cache! gf)
var)))
(module-define! duplicate-handlers 'merge-generics merge-generics)
;; remove the method from its GF
(slot-set! gf 'methods
(delq1! m (slot-ref gf 'methods)))
- (%invalidate-method-cache! gf)
+ (invalidate-method-cache! gf)
;; remove the method from its specializers
(remove-method-in-classes! m))))
(class-direct-methods c)))
HCoop / bpt / guile.git / blobdiff