Changeset 13817


Ignore:
Timestamp:
01/28/12 14:23:51 (9 years ago)
Author:
rschlatte
Message:

Implement writer-method-class.

... Bonus content: make non-standard reader method classes actually

work.

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

Legend:

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

    r13816 r13817  
    748748        (add-reader-method class reader direct-slot))
    749749      (dolist (writer (slot-definition-writers direct-slot))
    750         (add-writer-method class writer (slot-definition-name direct-slot)))))
     750        (add-writer-method class writer direct-slot))))
    751751  (setf (class-direct-default-initargs class) direct-default-initargs)
    752752  (maybe-finalize-class-subtree class)
     
    24282428;;; Reader and writer methods
    24292429
    2430 (defun make-instance-standard-reader-method (gf
    2431                                              &key
    2432                                              lambda-list
    2433                                              qualifiers
    2434                                              specializers
    2435                                              documentation
    2436                                              function
    2437                                              fast-function
    2438                                              slot-definition)
    2439   (declare (ignore gf))
    2440   (let ((method (std-allocate-instance +the-standard-reader-method-class+)))
     2430(defun make-instance-standard-accessor-method (method-class
     2431                                               &key
     2432                                               lambda-list
     2433                                               qualifiers
     2434                                               specializers
     2435                                               documentation
     2436                                               function
     2437                                               fast-function
     2438                                               slot-definition)
     2439  (let ((method (std-allocate-instance method-class)))
    24412440    (setf (method-lambda-list method) lambda-list)
    24422441    (setf (method-qualifiers method) qualifiers)
     
    24532452
    24542453(defun add-reader-method (class function-name slot-definition)
    2455   (let* ((method-class (if (eq (class-of class) +the-standard-class+)
    2456                            +the-standard-reader-method-class+
    2457                            (reader-method-class class)))
    2458          (slot-name (slot-definition-name slot-definition))
     2454  (let* ((slot-name (slot-definition-name slot-definition))
    24592455         (lambda-expression
    24602456          (if (eq (class-of class) +the-standard-class+)
     
    24642460         (fast-function (compute-method-fast-function lambda-expression))
    24652461         (method-lambda-list '(object))
    2466          (gf (find-generic-function function-name nil)))
     2462         (gf (find-generic-function function-name nil))
     2463         (initargs `(:lambda-list ,method-lambda-list
     2464                     :qualifiers ()
     2465                     :specializers (,class)
     2466                     :function ,(if (autoloadp 'compile)
     2467                                    method-function
     2468                                    (autocompile method-function))
     2469                     :fast-function ,(if (autoloadp 'compile)
     2470                                         fast-function
     2471                                         (autocompile fast-function))
     2472                     :slot-definition ,slot-definition))
     2473         (method-class (if (eq class +the-standard-class+)
     2474                           +the-standard-reader-method-class+
     2475                           (apply #'reader-method-class class slot-definition
     2476                                  initargs))))
    24672477    ;; required by AMOP pg. 225
    24682478    (assert (subtypep method-class +the-standard-reader-method-class+))
     
    24752485    (let ((method
    24762486           (if (eq method-class +the-standard-reader-method-class+)
    2477                (make-instance-standard-reader-method
    2478                 gf
    2479                 :lambda-list method-lambda-list
    2480                 :qualifiers ()
    2481                 :specializers (list class)
    2482                 :function (if (autoloadp 'compile)
    2483                               method-function
    2484                               (autocompile method-function))
    2485                 :fast-function (if (autoloadp 'compile)
    2486                                    fast-function
    2487                                    (autocompile fast-function))
    2488                 :slot-definition slot-definition)
    2489                (make-instance method-class
    2490                               :lambda-list method-lambda-list
    2491                               :qualifiers ()
    2492                               :specializers (list class)
    2493                               :function (if (autoloadp 'compile)
    2494                                             method-function
    2495                                             (autocompile method-function))
    2496                               :fast-function (if (autoloadp 'compile)
    2497                                                  fast-function
    2498                                                  (autocompile fast-function))
    2499                               :slot-definition slot-definition))))
     2487               (apply #'make-instance-standard-accessor-method method-class
     2488                      initargs)
     2489               (apply #'make-instance method-class
     2490                      :generic-function nil ; handled by add-method
     2491                      initargs))))
    25002492      (if (eq (class-of gf) +the-standard-generic-function-class+)
    25012493          (std-add-method gf method)
     
    25032495      method)))
    25042496
    2505 (defun add-writer-method (class function-name slot-name)
    2506   (let* ((lambda-expression
     2497(defun add-writer-method (class function-name slot-definition)
     2498  (let* ((slot-name (slot-definition-name slot-definition))
     2499         (lambda-expression
    25072500          (if (eq (class-of class) +the-standard-class+)
    25082501              `(lambda (new-value object)
     
    25122505         (method-function (compute-method-function lambda-expression))
    25132506         (fast-function (compute-method-fast-function lambda-expression))
    2514          )
    2515     (ensure-method function-name
    2516                    :lambda-list '(new-value object)
    2517                    :qualifiers ()
    2518                    :specializers (list +the-T-class+ class)
    2519 ;;                    :function `(function ,method-function)
    2520                    :function (if (autoloadp 'compile)
    2521                                  method-function
    2522                                  (autocompile method-function))
    2523                    :fast-function (if (autoloadp 'compile)
    2524                                       fast-function
    2525                                       (autocompile fast-function))
    2526                    )))
     2507         (method-lambda-list '(new-value object))
     2508         (gf (find-generic-function function-name nil))
     2509         (initargs `(:lambda-list ,method-lambda-list
     2510                     :qualifiers ()
     2511                     :specializers (,+the-T-class+ ,class)
     2512                     :function ,(if (autoloadp 'compile)
     2513                                    method-function
     2514                                    (autocompile method-function))
     2515                     :fast-function ,(if (autoloadp 'compile)
     2516                                         fast-function
     2517                                         (autocompile fast-function))))
     2518         (method-class (if (eq class +the-standard-class+)
     2519                           +the-standard-writer-method-class+
     2520                           (apply #'writer-method-class class slot-definition
     2521                                  initargs))))
     2522    ;; required by AMOP pg. 242
     2523    (assert (subtypep method-class +the-standard-writer-method-class+))
     2524    (if gf
     2525        (check-method-lambda-list function-name
     2526                                  method-lambda-list
     2527                                  (generic-function-lambda-list gf))
     2528        (setf gf (ensure-generic-function function-name
     2529                                          :lambda-list method-lambda-list)))
     2530    (let ((method
     2531           (if (eq method-class +the-standard-writer-method-class+)
     2532               (apply #'make-instance-standard-accessor-method method-class
     2533                      initargs)
     2534               (apply #'make-instance method-class
     2535                      :generic-function nil ; handled by add-method
     2536                      initargs))))
     2537      (if (eq (class-of gf) +the-standard-generic-function-class+)
     2538          (std-add-method gf method)
     2539          (add-method gf method))
     2540      method)))
    25272541
    25282542(defmacro atomic-defgeneric (function-name &rest rest)
     
    27562770  (declare (ignore initargs))
    27572771  +the-standard-reader-method-class+)
     2772
     2773;;; AMOP pg. 242
     2774(defgeneric writer-method-class (class direct-slot &rest initargs))
     2775
     2776(defmethod writer-method-class ((class standard-class)
     2777                                (direct-slot standard-direct-slot-definition)
     2778                                &rest initargs)
     2779  (declare (ignore initargs))
     2780  +the-standard-writer-method-class+)
     2781
     2782(defmethod writer-method-class ((class funcallable-standard-class)
     2783                                (direct-slot standard-direct-slot-definition)
     2784                                &rest initargs)
     2785  (declare (ignore initargs))
     2786  +the-standard-writer-method-class+)
    27582787
    27592788(atomic-defgeneric documentation (x doc-type)
     
    35643593
    35653594
    3566 
     3595;;; FIXME (rudi 2012-01-28): this can be a function, it only needs to
     3596;;; use standard accessor functions
    35673597(defgeneric find-method (generic-function
    35683598                         qualifiers
     
    35733603                        qualifiers specializers &optional (errorp t))
    35743604  (%find-method generic-function qualifiers specializers errorp))
     3605
     3606(defgeneric find-method ((generic-function symbol)
     3607                         qualifiers specializers &optional (errorp t))
     3608  (find-method (find-generic-function generic-function errorp)
     3609               qualifiers specializers errorp))
    35753610
    35763611(defgeneric add-method (generic-function method))
  • trunk/abcl/src/org/armedbear/lisp/mop.lisp

    r13814 r13817  
    2929               (eql (class-name superclass) 'standard-class)))))
    3030
    31 (export '(funcallable-standard-object
     31(export '(;; classes
     32          funcallable-standard-object
    3233          funcallable-standard-class
    3334          forward-referenced-class
    34           validate-superclass
    3535          direct-slot-definition-class
    3636          effective-slot-definition-class
     37          standard-method
     38          standard-accessor-method
     39          standard-reader-method
     40          standard-writer-method
     41         
    3742          compute-effective-slot-definition
    3843          compute-class-precedence-list
     
    4247          slot-boundp-using-class
    4348          slot-makunbound-using-class
     49          validate-superclass
    4450
    4551          ensure-class
     
    5662          generic-function-lambda-list
    5763
    58           standard-method
    5964          method-function
    6065          method-specializers
    6166          method-generic-function
    62 
    63           standard-accessor-method
    6467          standard-reader-method
    6568          standard-writer-method
     69          reader-method-class
     70          writer-method-class
    6671
    6772          slot-definition
Note: See TracChangeset for help on using the changeset viewer.