;;; {Methods}
;;;
- (let lp ((specs (method-specializers m)) (types types))
+;; Note: `a' and `b' can have unequal lengths (i.e. one can be one
+;; element longer than the other when we have a dotted parameter
+;; list). For instance, with the call
+;;
+;; (M 1)
+;;
+;; with
+;;
+;; (define-method M (a . l) ....)
+;; (define-method M (a) ....)
+;;
+;; we consider that the second method is more specific.
+;;
+;; Precondition: `a' and `b' are methods and are applicable to `types'.
+(define (%method-more-specific? a b types)
+ (let lp ((a-specializers (method-specializers a))
+ (b-specializers (method-specializers b))
+ (types types))
+ (cond
+ ;; (a) less specific than (a b ...) or (a . b)
+ ((null? a-specializers) #t)
+ ;; (a b ...) or (a . b) less specific than (a)
+ ((null? b-specializers) #f)
+ ;; (a . b) less specific than (a b ...)
+ ((not (pair? a-specializers)) #f)
+ ;; (a b ...) more specific than (a . b)
+ ((not (pair? b-specializers)) #t)
+ (else
+ (let ((a-specializer (car a-specializers))
+ (b-specializer (car b-specializers))
+ (a-specializers (cdr a-specializers))
+ (b-specializers (cdr b-specializers))
+ (type (car types))
+ (types (cdr types)))
+ (if (eq? a-specializer b-specializer)
+ (lp a-specializers b-specializers types)
+ (let lp ((cpl (class-precedence-list type)))
+ (let ((elt (car cpl)))
+ (cond
+ ((eq? a-specializer elt) #t)
+ ((eq? b-specializer elt) #f)
+ (else (lp (cdr cpl))))))))))))
+
+(define (%sort-applicable-methods methods types)
+ (sort methods (lambda (a b) (%method-more-specific? a b types))))
+
+(define (generic-function-methods obj)
+ "Return the methods of the generic function @var{obj}."
+ (define (fold-upward method-lists gf)
+ (cond
+ ((is-a? gf <extended-generic>)
+ (let lp ((method-lists method-lists) (gfs (slot-ref gf 'extends)))
+ (match gfs
+ (() method-lists)
+ ((gf . gfs)
+ (lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf)
+ gfs)))))
+ (else method-lists)))
+ (define (fold-downward method-lists gf)
+ (let lp ((method-lists (cons (slot-ref gf 'methods) method-lists))
+ (gfs (slot-ref gf 'extended-by)))
+ (match gfs
+ (() method-lists)
+ ((gf . gfs)
+ (lp (fold-downward method-lists gf) gfs)))))
+ (unless (is-a? obj <generic>)
+ (scm-error 'wrong-type-arg #f "Not a generic: ~S"
+ (list obj) #f))
+ (concatenate (fold-downward (fold-upward '() obj) obj)))
+
+(define (%compute-applicable-methods gf args)
+ (define (method-applicable? m types)
- ((null? specs) (null? types))
- ((not (pair? specs)) #t)
- ((null? types) #f)
++ (let ((specs (method-specializers m)))
+ (cond
- (and (memq (car specs) (class-precedence-list (car types)))
- (lp (cdr specs) (cdr types)))))))
++ ((and (is-a? m <accessor-method>)
++ (or (null? specs) (null? types)
++ (not (eq? (car specs) (car types)))))
++ ;; Slot accessor methods are added to each subclass with the
++ ;; slot. They only apply to that specific concrete class, which
++ ;; appears as the first argument.
++ #f)
+ (else
++ (let lp ((specs specs) (types types))
++ (cond
++ ((null? specs) (null? types))
++ ((not (pair? specs)) #t)
++ ((null? types) #f)
++ (else
++ (and (memq (car specs) (class-precedence-list (car types)))
++ (lp (cdr specs) (cdr types))))))))))
+ (let ((n (length args))
+ (types (map class-of args)))
+ (let lp ((methods (generic-function-methods gf))
+ (applicable '()))
+ (if (null? methods)
+ (and (not (null? applicable))
+ (%sort-applicable-methods applicable types))
+ (let ((m (car methods)))
+ (lp (cdr methods)
+ (if (method-applicable? m types)
+ (cons m applicable)
+ applicable)))))))
+
+(define compute-applicable-methods %compute-applicable-methods)
+
(define (toplevel-define! name val)
(module-define! (current-module) name val))
;;;
(define (compute-slot-accessors class slots)
(for-each
- (lambda (s g-n-s)
- (let ((getter-function (slot-definition-getter s))
- (setter-function (slot-definition-setter s))
- (accessor (slot-definition-accessor s)))
- (if getter-function
- (add-method! getter-function
- (compute-getter-method class g-n-s)))
- (if setter-function
- (add-method! setter-function
- (compute-setter-method class g-n-s)))
- (if accessor
- (begin
- (add-method! accessor
- (compute-getter-method class g-n-s))
- (add-method! (setter accessor)
- (compute-setter-method class g-n-s))))))
- slots (slot-ref class 'getters-n-setters)))
-
-(define-method (compute-getter-method (class <class>) g-n-s)
- (let ((init-thunk (cadr g-n-s))
- (g-n-s (cddr g-n-s)))
- (make <accessor-method>
- #:specializers (list class)
- #:procedure (cond ((pair? 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 g-n-s)))
-
-(define-method (compute-setter-method (class <class>) g-n-s)
- (let ((init-thunk (cadr g-n-s))
- (g-n-s (cddr g-n-s)))
- (make <accessor-method>
- #:specializers (list class <top>)
- #:procedure (if (pair? g-n-s)
- (cadr g-n-s)
- (standard-set g-n-s))
- #:slot-definition g-n-s)))
+ (lambda (slot)
+ (let ((getter (%slot-definition-getter slot))
+ (setter (%slot-definition-setter slot))
+ (accessor-setter setter)
+ (accessor (%slot-definition-accessor slot)))
+ (when getter
+ (add-method! getter (compute-getter-method class slot)))
+ (when setter
+ (add-method! setter (compute-setter-method class slot)))
+ (when accessor
+ (add-method! accessor (compute-getter-method class slot))
+ (add-method! (accessor-setter accessor)
+ (compute-setter-method class slot)))))
+ slots))
+
+(define-method (compute-getter-method (class <class>) slot)
- (let ((name (slot-definition-name slot)))
- (make <accessor-method>
- #:specializers (list class)
- #:procedure (lambda (o) (slot-ref o name))
- #:slot-definition slot)))
++ (make <accessor-method>
++ #:specializers (list class)
++ #:procedure (slot-definition-slot-ref slot)
++ #:slot-definition slot))
+
+(define-method (compute-setter-method (class <class>) slot)
- (let ((name (slot-definition-name slot)))
- (make <accessor-method>
- #:specializers (list class <top>)
- #:procedure (lambda (o v) (slot-set! o name v))
- #:slot-definition slot)))
++ (make <accessor-method>
++ #:specializers (list class <top>)
++ #:procedure (slot-definition-slot-set! slot)
++ #:slot-definition slot))
(define (make-generic-bound-check-getter proc)
- (lambda (o) (assert-bound (proc o) o)))
-
-;; the idea is to compile the index into the procedure, for fastest
-;; lookup.
-
-(eval-when (expand load eval)
- (define num-standard-pre-cache 20))
-
-(define-macro (define-standard-accessor-method form . body)
- (let ((name (caar form))
- (n-var (cadar form))
- (args (cdr form)))
- (define (make-one x)
- (define (body-trans form)
- (cond ((not (pair? form)) form)
- ((eq? (car form) 'struct-ref)
- `(,(car form) ,(cadr form) ,x))
- ((eq? (car form) 'struct-set!)
- `(,(car form) ,(cadr form) ,x ,(cadddr form)))
- (else
- (map body-trans form))))
- `(lambda ,args ,@(map body-trans body)))
- `(define ,name
- (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
- (lambda (n)
- (if (< n ,num-standard-pre-cache)
- (vector-ref cache n)
- ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
-
-(define-standard-accessor-method ((bound-check-get n) o)
- (let ((x (struct-ref o n)))
- (if (unbound? x)
- (slot-unbound o)
- x)))
-
-(define-standard-accessor-method ((standard-get n) o)
- (struct-ref o n))
-
-(define-standard-accessor-method ((standard-set n) o v)
- (struct-set! o n v))
-
-;;; compute-getters-n-setters
-;;;
-(define (compute-getters-n-setters class slots)
-
- (define (compute-slot-init-function name s)
- (or (let ((thunk (slot-definition-init-thunk s)))
- (and thunk
- (if (thunk? thunk)
- thunk
- (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
- name class thunk))))
- (let ((init (slot-definition-init-value s)))
- (and (not (unbound? init))
- (lambda () init)))))
-
- (define (verify-accessors slot l)
- (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 (procedure? get))
- (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
- slot class get))
- (if (not (procedure? set))
- (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
- slot class set))))))
-
- (map (lambda (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)))
- ;; 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)
- (case (slot-definition-allocation s)
- ((#:each-subclass #:class)
- (unless (and (zero? size) (pair? g-n-s))
- (error "Class-allocated slots should not reserve fields"))
- ;; Don't initialize the slot; that's handled when the slot
- ;; is allocated, in compute-get-n-set.
- (cons name (cons #f g-n-s)))
- (else
- (cons name
- (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))
+ (lambda (o)
+ (let ((val (proc o)))
+ (if (unbound? val)
+ (slot-unbound o)
+ val))))
;;; compute-cpl
;;;
HCoop / bpt / guile.git / commitdiff