Changeset 13778


Ignore:
Timestamp:
01/15/12 14:04:57 (10 years ago)
Author:
rschlatte
Message:

Define make-instance for standard-class and funcallable-standard-class

... Don't define a method for class (which would cover built-in-class

etc. as well)

... refactor out some common parts

File:
1 edited

Legend:

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

    r13776 r13778  
    28342834(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
    28352835
    2836 (defmethod make-instance ((class class) &rest initargs)
     2836(defmethod make-instance :before ((class class) &rest initargs)
    28372837  (when (oddp (length initargs))
    28382838    (error 'program-error :format-control "Odd number of keyword arguments."))
    28392839  (unless (class-finalized-p class)
    2840     (std-finalize-inheritance class))
    2841   (let ((class-default-initargs (class-default-initargs class)))
    2842     (when class-default-initargs
    2843       (let ((default-initargs '()))
    2844         (do* ((list class-default-initargs (cddr list))
    2845               (key (car list) (car list))
    2846               (fn (cadr list) (cadr list)))
    2847              ((null list))
    2848           (when (eq (getf initargs key 'not-found) 'not-found)
    2849             (setf default-initargs (append default-initargs (list key (funcall fn))))))
    2850         (setf initargs (append initargs default-initargs)))))
    2851 
    2852   (let ((instance (allocate-instance class)))
     2840    (finalize-inheritance class)))
     2841
     2842(defun augment-initargs-with-defaults (class initargs)
     2843  (let ((default-initargs '()))
     2844    (do* ((list (class-default-initargs class) (cddr list))
     2845          (key (car list) (car list))
     2846          (fn (cadr list) (cadr list)))
     2847         ((null list))
     2848      (when (eq (getf initargs key 'not-found) 'not-found)
     2849        (setf default-initargs (append default-initargs (list key (funcall fn))))))
     2850    (append initargs default-initargs)))
     2851
     2852(defmethod make-instance ((class standard-class) &rest initargs)
     2853  (setf initargs (augment-initargs-with-defaults class initargs))
     2854  (let ((instance (std-allocate-instance class)))
     2855    (check-initargs (list #'allocate-instance #'initialize-instance)
     2856                    (list* instance initargs)
     2857                    instance t initargs
     2858                    *make-instance-initargs-cache* 'make-instance)
     2859    (apply #'initialize-instance instance initargs)
     2860    instance))
     2861
     2862(defmethod make-instance ((class funcallable-standard-class) &rest initargs)
     2863  (setf initargs (augment-initargs-with-defaults class initargs))
     2864  (let ((instance (allocate-funcallable-instance class)))
    28532865    (check-initargs (list #'allocate-instance #'initialize-instance)
    28542866                    (list* instance initargs)
Note: See TracChangeset for help on using the changeset viewer.