;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
define-generic define-accessor define-method
define-extended-generic define-extended-generics
method)
- :export (goops-version is-a? class-of
+ :export (is-a? class-of
ensure-metaclass ensure-metaclass-with-supers
make-class
make-generic ensure-generic
;; goops-error
;;
(define (goops-error format-string . args)
- (save-stack)
(scm-error 'goops-error #f format-string args '()))
;;
(lambda (x)
(syntax-case x ()
((_ (k arg rest ...) out ...)
- (keyword? (syntax->datum (syntax k)))
- (case (syntax->datum (syntax k))
+ (keyword? (syntax->datum #'k))
+ (case (syntax->datum #'k)
((#:getter #:setter)
- (syntax
- (define-class-pre-definition (rest ...)
- out ...
- (if (or (not (defined? 'arg))
- (not (is-a? arg <generic>)))
- (toplevel-define!
- 'arg
- (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+ #'(define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <generic>)))
+ (toplevel-define!
+ 'arg
+ (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
((#:accessor)
- (syntax
- (define-class-pre-definition (rest ...)
- out ...
- (if (or (not (defined? 'arg))
- (not (is-a? arg <accessor>)))
- (toplevel-define!
- 'arg
- (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+ #'(define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <accessor>)))
+ (toplevel-define!
+ 'arg
+ (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
(else
- (syntax
- (define-class-pre-definition (rest ...) out ...)))))
+ #'(define-class-pre-definition (rest ...) out ...))))
((_ () out ...)
- (syntax (begin out ...))))))
+ #'(begin out ...)))))
;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
(lambda (x)
(syntax-case x ()
((_ () out ...)
- (syntax (begin out ...)))
+ #'(begin out ...))
((_ (slot rest ...) out ...)
- (keyword? (syntax->datum (syntax slot)))
- (syntax (begin out ...)))
+ (keyword? (syntax->datum #'slot))
+ #'(begin out ...))
((_ (slot rest ...) out ...)
- (identifier? (syntax slot))
- (syntax (define-class-pre-definitions (rest ...)
- out ...)))
+ (identifier? #'slot)
+ #'(define-class-pre-definitions (rest ...)
+ out ...))
((_ ((slotname slotopt ...) rest ...) out ...)
- (syntax (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-class-pre-definitions (rest ...)
+ out ... (define-class-pre-definition (slotopt ...)))))))
+
+(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)
- (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 (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))
;;;
(let lp ((ls args) (formals '()) (specializers '()))
(syntax-case ls ()
(((f s) . rest)
- (and (identifier? (syntax f)) (identifier? (syntax s)))
- (lp (syntax rest)
- (cons (syntax f) formals)
- (cons (syntax s) specializers)))
+ (and (identifier? #'f) (identifier? #'s))
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'s specializers)))
((f . rest)
- (identifier? (syntax f))
- (lp (syntax rest)
- (cons (syntax f) formals)
- (cons (syntax <top>) specializers)))
+ (identifier? #'f)
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'<top> specializers)))
(()
(list (reverse formals)
- (reverse (cons (syntax '()) specializers))))
+ (reverse (cons #''() specializers))))
(tail
- (identifier? (syntax tail))
- (list (append (reverse formals) (syntax tail))
- (reverse (cons (syntax <top>) specializers)))))))
+ (identifier? #'tail)
+ (list (append (reverse formals) #'tail)
+ (reverse (cons #'<top> specializers)))))))
(define (find-free-id exp referent)
(syntax-case exp ()
((x . y)
- (or (find-free-id (syntax x) referent)
- (find-free-id (syntax y) referent)))
+ (or (find-free-id #'x referent)
+ (find-free-id #'y referent)))
(x
- (identifier? (syntax x))
- (let ((id (datum->syntax (syntax x) referent)))
- (and (free-identifier=? (syntax x) id) id)))
+ (identifier? #'x)
+ (let ((id (datum->syntax #'x referent)))
+ (and (free-identifier=? #'x id) id)))
(_ #f)))
(define (compute-procedure formals body)
(syntax-case body ()
((body0 ...)
(with-syntax ((formals formals))
- (syntax (lambda formals body0 ...))))))
+ #'(lambda formals body0 ...)))))
(define (->proper args)
(let lp ((ls args) (out '()))
(syntax-case ls ()
- ((x . xs) (lp (syntax xs) (cons (syntax x) out)))
+ ((x . xs) (lp #'xs (cons #'x out)))
(() (reverse out))
- (tail (reverse (cons (syntax tail) out))))))
+ (tail (reverse (cons #'tail out))))))
(define (compute-make-procedure formals body next-method)
(syntax-case body ()
(with-syntax ((next-method next-method))
(syntax-case formals ()
((formal ...)
- (syntax
- (lambda (real-next-method)
- (lambda (formal ...)
- (let ((next-method (lambda args
- (if (null? args)
- (real-next-method formal ...)
- (apply real-next-method args)))))
- body ...)))))
+ #'(lambda (real-next-method)
+ (lambda (formal ...)
+ (let ((next-method (lambda args
+ (if (null? args)
+ (real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...))))
(formals
- (with-syntax (((formal ...) (->proper (syntax formals))))
- (syntax
- (lambda (real-next-method)
- (lambda formals
- (let ((next-method (lambda args
- (if (null? args)
- (apply real-next-method formal ...)
- (apply real-next-method args)))))
- body ...)))))))))))
+ (with-syntax (((formal ...) (->proper #'formals)))
+ #'(lambda (real-next-method)
+ (lambda formals
+ (let ((next-method (lambda args
+ (if (null? args)
+ (apply real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...))))))))))
(define (compute-procedures formals body)
;; So, our use of this is broken, because it operates on the
(let ((id (find-free-id body 'next-method)))
(if id
;; return a make-procedure
- (values (syntax #f)
+ (values #'#f
(compute-make-procedure formals body id))
(values (compute-procedure formals body)
- (syntax #f)))))
+ #'#f))))
(syntax-case x ()
- ((_ args) (syntax (method args (if #f #f))))
+ ((_ args) #'(method args (if #f #f)))
((_ args body0 body1 ...)
- (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
+ (with-syntax (((formals (specializer ...)) (parse-args #'args)))
(call-with-values
(lambda ()
- (compute-procedures (syntax formals) (syntax (body0 body1 ...))))
+ (compute-procedures #'formals #'(body0 body1 ...)))
(lambda (procedure make-procedure)
(with-syntax ((procedure procedure)
(make-procedure make-procedure))
- (syntax
- (make <method>
- #:specializers (cons* specializer ...)
- #:formals 'formals
- #:body '(body0 body1 ...)
- #:make-procedure make-procedure
- #:procedure procedure))))))))))
+ #'(make <method>
+ #:specializers (cons* specializer ...)
+ #:formals 'formals
+ #:body '(body0 body1 ...)
+ #:make-procedure make-procedure
+ #:procedure procedure)))))))))
;;;
;;; {add-method!}
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)))
(let ((proc (get-keyword #:procedure initargs #f)))
(cond ((not proc))
((pair? proc)
- (apply set-object-procedure! object proc))
+ (apply slot-set! object 'procedure proc))
(else
- (set-object-procedure! object proc)))))
+ (slot-set! object 'procedure proc)))))
(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)