Changeset 13975


Ignore:
Timestamp:
06/17/12 16:34:58 (9 years ago)
Author:
rschlatte
Message:

Ensure argument-precedence-order matches lambda-list in defgeneric

  • fixes ansi tests defgeneric.error.4, defgeneric.error.8
  • also fix newly-introduced error ensure-generic-function.9
File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13974 r13975  
    15231523
    15241524;;; Bootstrap version of ensure-generic-function, handling only
    1525 ;;; standard-generic-function.  This function will be replaced in
    1526 ;;; mop.lisp.
     1525;;; standard-generic-function.  This function is replaced later.
    15271526(declaim (notinline ensure-generic-function))
    15281527(defun ensure-generic-function (function-name
     
    16161615  ;; to avoid circularities, we do not call generic functions in here.
    16171616  (declare (ignore generic-function-class))
     1617  (check-argument-precedence-order lambda-list argument-precedence-order)
    16181618  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
    16191619    (%set-generic-function-name gf name)
     
    18441844                all of the keyword arguments defined for the ~
    18451845                generic function." method-lambda-list name)))))
     1846
     1847(defun check-argument-precedence-order (lambda-list argument-precedence-order)
     1848  (when argument-precedence-order
     1849    (if lambda-list
     1850        ;; raising the required program-errors is a side-effect of
     1851        ;; calculating the given permutation of apo vs req
     1852        (argument-precedence-order-indices
     1853         argument-precedence-order
     1854         (getf (analyze-lambda-list lambda-list) :required-args))
     1855        ;; AMOP pg. 198
     1856        (error 'program-error "argument precedence order specified without lambda list"))))
    18461857
    18471858(defvar *gf-initialize-instance* nil
     
    36773688  ((class funcallable-standard-class) name direct-slots)
    36783689  (std-compute-effective-slot-definition class name direct-slots))
    3679 ;;; Methods having to do with generic function metaobjects.
    3680 
    3681 (defmethod initialize-instance :after ((gf standard-generic-function) &key)
    3682   (finalize-standard-generic-function gf))
    36833690
    36843691;;; Methods having to do with generic function invocation.
     
    40244031  (allocate-instance class))
    40254032
     4033(defmethod shared-initialize :before ((instance generic-function)
     4034                                      slot-names
     4035                                      &key lambda-list argument-precedence-order
     4036                                      &allow-other-keys)
     4037  (check-argument-precedence-order lambda-list argument-precedence-order))
     4038
    40264039(defmethod shared-initialize :after ((instance standard-generic-function)
    40274040                                     slot-names
     
    41944207                                                &key (generic-function-class +the-standard-generic-function-class+)
    41954208                                                  lambda-list
    4196                                                   argument-precedence-order
    41974209                                                  (method-class +the-standard-method-class+)
    4198                                                   documentation
    41994210                                                &allow-other-keys)
    42004211  (setf all-keys (copy-list all-keys))  ; since we modify it
     
    42144225    (error "The method class ~S is incompatible with the existing methods of ~S."
    42154226           method-class generic-function))
    4216   ;; FIXME (rudi 2012-03-26): should call reinitialize-instance here, as
    4217   ;; per AMOP.
    4218   (setf (generic-function-lambda-list generic-function) lambda-list)
    4219   (setf (generic-function-documentation generic-function) documentation)
    4220   (let* ((plist (analyze-lambda-list lambda-list))
    4221          (required-args (getf plist ':required-args)))
    4222     (%set-gf-required-args generic-function required-args)
    4223     (%set-gf-optional-args generic-function (getf plist :optional-args))
    4224     (setf (generic-function-argument-precedence-order generic-function)
    4225           (or argument-precedence-order required-args))
    4226     (finalize-standard-generic-function generic-function))
     4227  (apply #'reinitialize-instance generic-function
     4228         :method-class method-class all-keys)
    42274229  generic-function)
    42284230
Note: See TracChangeset for help on using the changeset viewer.