Changeset 4650


Ignore:
Timestamp:
11/05/03 01:48:52 (19 years ago)
Author:
piso
Message:

:DEFAULT-INITARGS option.

File:
1 edited

Legend:

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

    r4645 r4650  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.6 2003-11-04 19:38:30 piso Exp $
     4;;; $Id: clos.lisp,v 1.7 2003-11-05 01:48:52 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    7474(defsetf class-direct-methods %set-class-direct-methods)
    7575(defsetf class-direct-slots %set-class-direct-slots)
     76(defsetf class-slots %set-class-slots)
     77(defsetf class-direct-default-initargs %set-class-direct-default-initargs)
     78(defsetf class-default-initargs %set-class-default-initargs)
    7679(defsetf class-precedence-list %set-class-precedence-list)
    77 (defsetf class-slots %set-class-slots)
    7880(defsetf std-instance-class %set-std-instance-class)
    7981(defsetf std-instance-slots %set-std-instance-slots)
     
    233235                     #'compute-slots)
    234236                 class))
     237  (setf (class-default-initargs class)
     238        (compute-class-default-initargs class))
    235239  (values))
     240
     241(defun compute-class-default-initargs (class)
     242  (mapappend #'class-direct-default-initargs
     243             (class-precedence-list class)))
    236244
    237245;;; Class precedence lists
     
    464472  (std-allocate-instance class))
    465473
    466 (defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots
    467                                                &allow-other-keys)
     474(defun make-instance-standard-class (metaclass
     475                                     &key name direct-superclasses direct-slots
     476                                     direct-default-initargs
     477                                     &allow-other-keys)
    468478  (declare (ignore metaclass))
    469479  (let ((class (std-allocate-instance (find-class 'standard-class))))
     
    472482    (setf (class-direct-methods class) ())
    473483    (std-after-initialization-for-classes class
     484                                          :direct-superclasses direct-superclasses
    474485                                          :direct-slots direct-slots
    475                                           :direct-superclasses direct-superclasses)
     486                                          :direct-default-initargs direct-default-initargs)
    476487    class))
    477488
    478489(defun std-after-initialization-for-classes (class
    479490                                             &key direct-superclasses direct-slots
     491                                             direct-default-initargs
    480492                                             &allow-other-keys)
    481   (let ((supers
    482          (or direct-superclasses
    483              (list (find-class 'standard-object)))))
     493  (let ((supers (or direct-superclasses
     494                    (list (find-class 'standard-object)))))
    484495    (setf (class-direct-superclasses class) supers)
    485496    (dolist (superclass supers)
    486497      (push class (class-direct-subclasses superclass))))
    487   (let ((slots
    488          (mapcar #'(lambda (slot-properties)
    489                     (apply #'make-direct-slot-definition
    490                            slot-properties))
    491                  direct-slots)))
     498  (let ((slots (mapcar #'(lambda (slot-properties)
     499                          (apply #'make-direct-slot-definition slot-properties))
     500                       direct-slots)))
    492501    (setf (class-direct-slots class) slots)
    493502    (dolist (direct-slot slots)
     
    498507        (add-writer-method
    499508         class writer (slot-definition-name direct-slot)))))
     509  (setf (class-direct-default-initargs class) direct-default-initargs)
    500510  (funcall (if (eq (class-of class) (find-class 'standard-class))
    501511               #'std-finalize-inheritance
     
    517527  (let ((class (find-class name nil)))
    518528    (unless class
    519       (setf class (apply #'make-instance-standard-class
    520                          (find-class 'standard-class) :name name all-keys))
     529      (setf class (apply #'make-instance-standard-class (find-class 'standard-class)
     530                         :name name all-keys))
    521531      (%set-find-class name class))
    522532    class))
     
    13391349(defmethod make-instance ((class standard-class) &rest initargs)
    13401350  (let ((instance (allocate-instance class)))
    1341     (apply #'initialize-instance instance initargs)
     1351    (apply #'initialize-instance instance
     1352           (append initargs (class-default-initargs class)))
    13421353    instance))
    13431354(defmethod make-instance ((class symbol) &rest initargs)
Note: See TracChangeset for help on using the changeset viewer.