Changeset 13990


Ignore:
Timestamp:
07/02/12 16:33:36 (8 years ago)
Author:
rschlatte
Message:

Implement make-method-lambda

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

Legend:

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

    r13984 r13990  
    801801
    802802(defun std-allocate-instance (class)
    803   ;; AMOP says ALLOCATE-INSTANCE checks if the class is finalized
    804   ;; and if not, tries to finalize it.
    805   (unless (class-finalized-p class)
    806     (std-finalize-inheritance class))
    807803  (sys::%std-allocate-instance class))
    808804
    809805(defun allocate-funcallable-instance (class)
    810   (unless (class-finalized-p class)
    811     (std-finalize-inheritance class))
    812806  (let ((instance (sys::%allocate-funcallable-instance class)))
    813807    (set-funcallable-instance-function
     
    817811         (error 'program-error "Called a funcallable-instance with unset function.")))
    818812    instance))
     813
     814(declaim (notinline class-prototype))
     815(defun class-prototype (class)
     816  (unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class)))
     817  (std-allocate-instance class))
    819818
    820819(defun make-instance-standard-class (metaclass
     
    13881387(defun method-generic-function (method)
    13891388  (std-method-generic-function method))
     1389
     1390(declaim (notinline method-function))
     1391(defun method-function (method)
     1392  (std-method-function method))
    13901393
    13911394(declaim (notinline method-specializers))
     
    26032606           nil))))))
    26042607
     2608(declaim (notinline make-method-lambda))
     2609(defun make-method-lambda (generic-function method lambda-expression env)
     2610  (declare (ignore generic-function method env))
     2611  (values (compute-method-function lambda-expression) nil))
     2612
     2613
    26052614;; From CLHS section 7.6.5:
    26062615;; "When a generic function or any of its methods mentions &key in a lambda
     
    26192628      lambda-list))
    26202629
    2621 (defmacro defmethod (&rest args)
     2630(defmacro defmethod (&rest args &environment env)
    26222631  (multiple-value-bind
    26232632      (function-name qualifiers lambda-list specializers documentation declarations body)
     
    26252634    (let* ((specializers-form '())
    26262635           (lambda-expression `(lambda ,lambda-list ,@declarations ,body))
    2627            (method-function (compute-method-function lambda-expression))
     2636           (gf (or (find-generic-function function-name nil)
     2637                   (ensure-generic-function function-name :lambda-list lambda-list)))
     2638           (method-function
     2639             (make-method-lambda gf (class-prototype (generic-function-method-class gf))
     2640                                 lambda-expression env))
    26282641           (fast-function (compute-method-fast-function lambda-expression))
    26292642           )
     
    33393352;;; Instance creation and initialization
    33403353
    3341 ;;; AMOP pg. 168ff.  Checking whether the class is finalized is done
    3342 ;;; inside std-allocate-instance and allocate-funcallable-instance.
     3354;;; AMOP pg. 168ff.
    33433355(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
    33443356
     
    33603372  (declare (ignore initargs))
    33613373  (error "Cannot allocate instances of a built-in class: ~S" class))
     3374
     3375(defmethod allocate-instance :before ((class class) &rest initargs)
     3376  (declare (ignore initargs))
     3377  (unless (class-finalized-p class)
     3378    (finalize-inheritance class)))
    33623379
    33633380;; "The set of valid initialization arguments for a class is the set of valid
     
    37833800  (%compute-applicable-methods gf args))
    37843801
     3802;;; AMOP pg. 207
     3803(atomic-defgeneric make-method-lambda (generic-function method lambda-expression environment)
     3804  (:method ((generic-function standard-generic-function)
     3805            (method standard-method)
     3806            lambda-expression environment)
     3807    (declare (ignore environment))
     3808    (values (compute-method-function lambda-expression) nil)))
     3809
     3810
    37853811;;; Slot definition accessors
    37863812
     
    40844110(setf *clos-booting* nil)
    40854111
    4086 (defgeneric class-prototype (class))
    4087 
    4088 (defmethod class-prototype :before (class)
    4089   (unless (class-finalized-p class)
    4090     (error "~@<~S is not finalized.~:@>" class)))
    4091 
    4092 (defmethod class-prototype ((class standard-class))
    4093   (allocate-instance class))
    4094 
    4095 (defmethod class-prototype ((class funcallable-standard-class))
    4096   (allocate-instance class))
    4097 
    4098 (defmethod class-prototype ((class structure-class))
    4099   (allocate-instance class))
     4112(atomic-defgeneric class-prototype (class)
     4113  (:method ((class standard-class))
     4114    (allocate-instance class))
     4115  (:method ((class funcallable-standard-class))
     4116    (allocate-instance class))
     4117  (:method ((class structure-class))
     4118    (allocate-instance class))
     4119  (:method :before (class)
     4120    (unless (class-finalized-p class)
     4121      (error "~@<~S is not finalized.~:@>" class))))
     4122
     4123
     4124
     4125
    41004126
    41014127(defmethod shared-initialize :before ((instance generic-function)
  • trunk/abcl/src/org/armedbear/lisp/mop.lisp

    r13983 r13990  
    6161          compute-applicable-methods-using-classes
    6262          compute-effective-method
     63          make-method-lambda
    6364          compute-slots
    6465          finalize-inheritance
Note: See TracChangeset for help on using the changeset viewer.