Changeset 4458


Ignore:
Timestamp:
10/19/03 18:33:16 (18 years ago)
Author:
piso
Message:

DEFGENERIC, ENSURE-GENERIC-FUNCTION: support :METHOD-COMBINATION option (work in progress).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/defclass.lisp

    r4422 r4458  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.25 2003-10-17 02:33:41 piso Exp $
     4;;; $Id: defclass.lisp,v 1.26 2003-10-19 18:33:16 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    531531    :initarg :method-class)
    532532;;    (discriminating-function)  ; :accessor generic-function-discriminating-function
     533   (method-combination
     534    :initarg :method-combination)
    533535   (classes-to-emf-table      ; :accessor classes-to-emf-table
    534536    :initform (make-hash-table :test #'equal))))
     
    562564(defun (setf generic-function-method-class) (new-value gf)
    563565  (setf (slot-value gf 'method-class) new-value))
     566
     567(defun generic-function-method-combination (gf)
     568  (slot-value gf 'method-combination))
     569(defun (setf generic-function-method-combination) (new-value gf)
     570  (setf (slot-value gf 'method-combination) new-value))
    564571
    565572;;; Internal accessor for effective method function table
     
    672679                                (generic-function-class the-class-standard-gf)
    673680                                (method-class the-class-standard-method)
     681                                (method-combination 'standard)
    674682                                &allow-other-keys)
    675683  (if (find-generic-function function-name nil)
     
    686694                         :name function-name
    687695                         :method-class method-class
     696                         :method-combination method-combination
    688697                         all-keys)))
    689698          (setf (find-generic-function function-name) gf)
     
    713722
    714723(defun make-instance-standard-generic-function (generic-function-class
    715                                                 &key name lambda-list method-class)
     724                                                &key name lambda-list
     725                                                method-class
     726                                                method-combination)
    716727  (declare (ignore generic-function-class))
    717728  (let ((gf (std-allocate-instance the-class-standard-gf)))
     
    721732    (setf (generic-function-methods gf) ())
    722733    (setf (generic-function-method-class gf) method-class)
     734    (setf (generic-function-method-combination gf) method-combination)
    723735    (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
    724736    (finalize-generic-function gf)
     
    10771089          #'(lambda (args)
    10781090             (funcall (method-function around) args next-emfun)))
    1079         (let ((next-emfun (compute-primary-emfun (cdr primaries)))
    1080               (befores (remove-if-not #'before-method-p methods))
    1081               (reverse-afters
    1082                (reverse (remove-if-not #'after-method-p methods))))
    1083           #'(lambda (args)
    1084              (dolist (before befores)
    1085                (funcall (method-function before) args nil))
    1086              (multiple-value-prog1
    1087               (funcall (method-function (car primaries)) args next-emfun)
    1088               (dolist (after reverse-afters)
    1089                 (funcall (method-function after) args nil))))))))
     1091        (case (generic-function-method-combination gf)
     1092          (STANDARD
     1093           (let ((next-emfun (compute-primary-emfun (cdr primaries)))
     1094                 (befores (remove-if-not #'before-method-p methods))
     1095                 (reverse-afters
     1096                  (reverse (remove-if-not #'after-method-p methods))))
     1097             #'(lambda (args)
     1098                (dolist (before befores)
     1099                  (funcall (method-function before) args nil))
     1100                (multiple-value-prog1
     1101                 (funcall (method-function (car primaries)) args next-emfun)
     1102                 (dolist (after reverse-afters)
     1103                   (funcall (method-function after) args nil))))))
     1104          (t
     1105           (error "unsupported method combination type ~S~"
     1106                  (generic-function-method-combination gf)))))))
    10901107
    10911108;;; compute an effective method function from a list of primary methods:
Note: See TracChangeset for help on using the changeset viewer.