Changeset 13990
- Timestamp:
- 07/02/12 16:33:36 (9 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13984 r13990 801 801 802 802 (defun std-allocate-instance (class) 803 ;; AMOP says ALLOCATE-INSTANCE checks if the class is finalized804 ;; and if not, tries to finalize it.805 (unless (class-finalized-p class)806 (std-finalize-inheritance class))807 803 (sys::%std-allocate-instance class)) 808 804 809 805 (defun allocate-funcallable-instance (class) 810 (unless (class-finalized-p class)811 (std-finalize-inheritance class))812 806 (let ((instance (sys::%allocate-funcallable-instance class))) 813 807 (set-funcallable-instance-function … … 817 811 (error 'program-error "Called a funcallable-instance with unset function."))) 818 812 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)) 819 818 820 819 (defun make-instance-standard-class (metaclass … … 1388 1387 (defun method-generic-function (method) 1389 1388 (std-method-generic-function method)) 1389 1390 (declaim (notinline method-function)) 1391 (defun method-function (method) 1392 (std-method-function method)) 1390 1393 1391 1394 (declaim (notinline method-specializers)) … … 2603 2606 nil)))))) 2604 2607 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 2605 2614 ;; From CLHS section 7.6.5: 2606 2615 ;; "When a generic function or any of its methods mentions &key in a lambda … … 2619 2628 lambda-list)) 2620 2629 2621 (defmacro defmethod (&rest args )2630 (defmacro defmethod (&rest args &environment env) 2622 2631 (multiple-value-bind 2623 2632 (function-name qualifiers lambda-list specializers documentation declarations body) … … 2625 2634 (let* ((specializers-form '()) 2626 2635 (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)) 2628 2641 (fast-function (compute-method-fast-function lambda-expression)) 2629 2642 ) … … 3339 3352 ;;; Instance creation and initialization 3340 3353 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. 3343 3355 (defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)) 3344 3356 … … 3360 3372 (declare (ignore initargs)) 3361 3373 (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))) 3362 3379 3363 3380 ;; "The set of valid initialization arguments for a class is the set of valid … … 3783 3800 (%compute-applicable-methods gf args)) 3784 3801 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 3785 3811 ;;; Slot definition accessors 3786 3812 … … 4084 4110 (setf *clos-booting* nil) 4085 4111 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 4100 4126 4101 4127 (defmethod shared-initialize :before ((instance generic-function) -
trunk/abcl/src/org/armedbear/lisp/mop.lisp
r13983 r13990 61 61 compute-applicable-methods-using-classes 62 62 compute-effective-method 63 make-method-lambda 63 64 compute-slots 64 65 finalize-inheritance
Note: See TracChangeset
for help on using the changeset viewer.