Changeset 13800


Ignore:
Timestamp:
01/25/12 08:53:54 (9 years ago)
Author:
rschlatte
Message:

minor refactorings in the vicinity of standard-generic-function.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

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

    r13799 r13800  
    7979;; * StandardObject.java
    8080;; * StandardObjectFunctions.java
     81;; * FuncallableStandardObject.java
    8182;; * Layout.java
    8283;;
     
    13281329    (let ((gf (fdefinition function-name)))
    13291330      (when (typep gf 'generic-function)
    1330         ;; Remove methods defined by previous DEFGENERIC forms.
     1331        ;; Remove methods defined by previous DEFGENERIC forms, as
     1332        ;; specified by CLHS, 7.7 (Macro DEFGENERIC).
    13311333        (dolist (method (generic-function-initial-methods gf))
    1332           (%remove-method gf method))
     1334          (if (typep gf 'standard-generic-function)
     1335              (std-remove-method gf method)
     1336              (remove-method gf method)))
    13331337        (setf (generic-function-initial-methods gf) '()))))
    13341338  (apply 'ensure-generic-function function-name all-keys))
    13351339
     1340;;; Bootstrap version of ensure-generic-function, handling only
     1341;;; standard-generic-function.  This function will be replaced in
     1342;;; mop.lisp.
     1343(declaim (notinline ensure-generic-function))
    13361344(defun ensure-generic-function (function-name
    13371345                                &rest all-keys
     
    13661374                                                                required-args)
    13671375                        nil)))
    1368             (finalize-generic-function gf))
     1376            (finalize-standard-generic-function gf))
    13691377          gf)
    13701378        (progn
     
    14031411    result))
    14041412
    1405 (defun finalize-generic-function (gf)
     1413(defun finalize-standard-generic-function (gf)
    14061414  (%finalize-generic-function gf)
    1407   (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
     1415  (unless (generic-function-classes-to-emf-table gf)
     1416    (set-generic-function-classes-to-emf-table gf (make-hash-table :test #'equal)))
     1417  (clrhash (generic-function-classes-to-emf-table gf))
    14081418  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
    14091419  (set-funcallable-instance-function
     
    14211431                                                argument-precedence-order
    14221432                                                documentation)
     1433  ;; to avoid circularities, we do not call generic functions in here.
    14231434  (declare (ignore generic-function-class))
    14241435  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
    14251436    (%set-generic-function-name gf name)
    1426     (setf (generic-function-lambda-list gf) lambda-list)
    1427     (setf (generic-function-initial-methods gf) ())
    1428     (setf (generic-function-methods gf) ())
    1429     (setf (generic-function-method-class gf) method-class)
    1430     (setf (generic-function-method-combination gf) method-combination)
    1431     (setf (generic-function-documentation gf) documentation)
    1432     (setf (classes-to-emf-table gf) nil)
     1437    (%set-generic-function-lambda-list gf lambda-list)
     1438    (set-generic-function-initial-methods gf ())
     1439    (set-generic-function-methods gf ())
     1440    (set-generic-function-method-class gf method-class)
     1441    (set-generic-function-method-combination gf method-combination)
     1442    (set-generic-function-documentation gf documentation)
     1443    (set-generic-function-classes-to-emf-table gf nil)
    14331444    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
    14341445           (required-args (getf plist ':required-args)))
    14351446      (%set-gf-required-args gf required-args)
    14361447      (%set-gf-optional-args gf (getf plist :optional-args))
    1437       (setf (generic-function-argument-precedence-order gf)
     1448      (set-generic-function-argument-precedence-order gf
    14381449            (if argument-precedence-order
    14391450                (canonicalize-argument-precedence-order argument-precedence-order
    14401451                                                        required-args)
    14411452                nil)))
    1442     (finalize-generic-function gf)
     1453    (finalize-standard-generic-function gf)
    14431454    gf))
    14441455
     
    16871698               (apply #'make-instance-standard-method gf all-keys)
    16881699               (apply #'make-instance (generic-function-method-class gf) all-keys))))
    1689       (%add-method gf method)
     1700      (std-add-method gf method)
    16901701      method)))
    16911702
     
    17141725    method))
    17151726
    1716 (defun %add-method (gf method)
     1727(defun std-add-method (gf method)
    17171728  (when (%method-generic-function method)
    17181729    (error 'simple-error
     
    17231734                                 (%method-specializers method) nil)))
    17241735    (when old-method
    1725       (%remove-method gf old-method)))
     1736      (std-remove-method gf old-method)))
    17261737  (%set-method-generic-function method gf)
    17271738  (push method (generic-function-methods gf))
     
    17291740    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
    17301741      (pushnew method (class-direct-methods specializer))))
    1731   (finalize-generic-function gf)
     1742  (finalize-standard-generic-function gf)
    17321743  gf)
    17331744
    1734 (defun %remove-method (gf method)
     1745(defun std-remove-method (gf method)
    17351746  (setf (generic-function-methods gf)
    17361747        (remove method (generic-function-methods gf)))
     
    17401751      (setf (class-direct-methods specializer)
    17411752            (remove method (class-direct-methods specializer)))))
    1742   (finalize-generic-function gf)
     1753  (finalize-standard-generic-function gf)
    17431754  gf)
    17441755
     
    24112422                                                                      (autocompile fast-function))
    24122423                                                   :slot-name slot-name)))
    2413         (%add-method gf method)
     2424        (std-add-method gf method)
    24142425        method))))
    24152426
     
    32253236
    32263237(defmethod initialize-instance :after ((gf standard-generic-function) &key)
    3227   (finalize-generic-function gf))
     3238  (finalize-standard-generic-function gf))
    32283239
    32293240;;; Methods having to do with generic function invocation.
     
    34773488    (check-method-lambda-list (%generic-function-name generic-function)
    34783489                              method-lambda-list gf-lambda-list))
    3479   (%add-method generic-function method))
     3490  (std-add-method generic-function method))
    34803491
    34813492(defgeneric remove-method (generic-function method))
    34823493
    34833494(defmethod remove-method ((generic-function standard-generic-function) method)
    3484   (%remove-method generic-function method))
     3495  (std-remove-method generic-function method))
    34853496
    34863497;; See describe.lisp.
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r13792 r13800  
    749749                 shared-initialize))
    750750    (let ((gf (and (fboundp sym) (fdefinition sym))))
    751       (when (typep gf 'generic-function)
     751      (when (typep gf 'standard-generic-function)
    752752        (unless (compiled-function-p gf)
    753           (mop::finalize-generic-function gf))))))
     753          (mop::finalize-standard-generic-function gf))))))
    754754
    755755(finalize-generic-functions)
Note: See TracChangeset for help on using the changeset viewer.