Changeset 12753


Ignore:
Timestamp:
06/14/10 21:02:34 (12 years ago)
Author:
astalla
Message:

Progress towards support for custom slot definitions: use of generic (setf slot-definition-*), bugfixes

File:
1 edited

Legend:

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

    r12752 r12753  
    266266  (%slot-definition-allocation slot-definition))
    267267
     268(defun (setf slot-definition-allocation) (value slot-definition)
     269  (set-slot-definition-allocation slot-definition value))
     270
    268271(defun slot-definition-initargs (slot-definition)
    269272  (%slot-definition-initargs slot-definition))
    270273
     274(defun (setf slot-definition-initargs) (value slot-definition)
     275  (set-slot-definition-initargs slot-definition value))
     276
    271277(defun slot-definition-initform (slot-definition)
    272278  (%slot-definition-initform slot-definition))
    273279
     280(defun (setf slot-definition-initform) (value slot-definition)
     281  (set-slot-definition-initform slot-definition value))
     282
    274283(defun slot-definition-initfunction (slot-definition)
    275284  (%slot-definition-initfunction slot-definition))
    276285
     286(defun (setf slot-definition-initfunction) (value slot-definition)
     287  (set-slot-definition-initfunction slot-definition value))
     288
    277289(defun slot-definition-name (slot-definition)
    278290  (%slot-definition-name slot-definition))
     291
     292(defun (setf slot-definition-name) (value slot-definition)
     293  (set-slot-definition-name slot-definition value))
    279294
    280295(defun init-slot-definition (slot &key name
     
    286301           (allocation :instance)
    287302           (allocation-class nil)
    288             &allow-other-keys)
    289   (set-slot-definition-name slot name)
    290   (set-slot-definition-initargs slot initargs)
    291   (set-slot-definition-initform slot initform)
    292   (set-slot-definition-initfunction slot initfunction)
     303           &allow-other-keys)
     304  (setf (slot-definition-name slot) name)
     305  (setf (slot-definition-initargs slot) initargs)
     306  (setf (slot-definition-initform slot) initform)
     307  (setf (slot-definition-initfunction slot) initfunction)
    293308  (set-slot-definition-readers slot readers)
    294309  (set-slot-definition-writers slot writers)
    295   (set-slot-definition-allocation slot allocation)
     310  (setf (slot-definition-allocation slot) allocation)
    296311  (set-slot-definition-allocation-class slot allocation-class)
    297312  slot)
     
    20722087  (std-slot-value instance slot-name))
    20732088
     2089(defmethod slot-value-using-class ((class structure-class) instance slot-name)
     2090  (std-slot-value instance slot-name))
     2091
    20742092(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
     2093
    20752094(defmethod (setf slot-value-using-class) (new-value
    20762095                                          (class standard-class)
     2096                                          instance
     2097                                          slot-name)
     2098  (setf (std-slot-value instance slot-name) new-value))
     2099
     2100(defmethod (setf slot-value-using-class) (new-value
     2101                                          (class structure-class)
    20772102                                          instance
    20782103                                          slot-name)
     
    22532278
    22542279(defmethod shared-initialize ((slot slot-definition) slot-names
    2255             &rest initargs
     2280            &rest args
    22562281            &key name initargs initform initfunction
    22572282            readers writers allocation
     
    22612286  (declare (ignore slot-names)) ;;TODO?
    22622287  (declare (ignore name initargs initform initfunction readers writers allocation))
    2263   (apply #'init-slot-definition slot initargs))
     2288  (apply #'init-slot-definition slot args))
    22642289
    22652290;;; change-class
     
    23922417;;; Slot definition accessors
    23932418
    2394 (mapcar (lambda (sym)
    2395     (fmakunbound sym) ;;we need to redefine them as GFs
    2396     (export sym))
     2419(map nil (lambda (sym)
     2420     (fmakunbound sym) ;;we need to redefine them as GFs
     2421     (fmakunbound `(setf ,sym))
     2422     (export sym))
    23972423  '(slot-definition-allocation
    23982424    slot-definition-initargs
     
    24012427    slot-definition-name))
    24022428
     2429(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
     2430  `(let (($cl (class-of ,slot-definition)))
     2431     (case $cl
     2432       ((+the-slot-definition-class+
     2433   +the-direct-slot-definition-class+
     2434   +the-effective-slot-definition-class+)
     2435  ,std-form)
     2436       (t ,generic-form))))
     2437
    24032438(defgeneric slot-definition-allocation (slot-definition)
    24042439  (:method ((slot-definition slot-definition))
    2405     (let ((cl (class-of slot-definition)))
    2406       (case cl
    2407   ((+the-slot-definition-class+
    2408     +the-direct-slot-definition-class+
    2409     +the-effective-slot-definition-class+)
    2410    (%slot-definition-allocation slot-definition))
    2411   (t (slot-value slot-definition 'sys::allocation))))))
     2440    (slot-definition-dispatch slot-definition
     2441      (%slot-definition-allocation slot-definition)
     2442      (slot-value slot-definition 'sys::allocation))))
     2443
     2444(defgeneric (setf slot-definition-allocation) (value slot-definition)
     2445  (:method (value (slot-definition slot-definition))
     2446    (slot-definition-dispatch slot-definition
     2447      (set-slot-definition-allocation slot-definition value)
     2448      (setf (slot-value slot-definition 'sys::allocation) value))))
    24122449
    24132450(defgeneric slot-definition-initargs (slot-definition)
    24142451  (:method ((slot-definition slot-definition))
    2415     (let ((cl (class-of slot-definition)))
    2416       (case cl
    2417   ((+the-slot-definition-class+
    2418     +the-direct-slot-definition-class+
    2419     +the-effective-slot-definition-class+)
    2420    (%slot-definition-initargs slot-definition))
    2421   (t (slot-value slot-definition 'sys::initargs))))))
     2452    (slot-definition-dispatch slot-definition
     2453      (%slot-definition-initargs slot-definition)
     2454      (slot-value slot-definition 'sys::initargs))))
     2455
     2456(defgeneric (setf slot-definition-initargs) (value slot-definition)
     2457  (:method (value (slot-definition slot-definition))
     2458    (slot-definition-dispatch slot-definition
     2459      (set-slot-definition-initargs slot-definition value)
     2460      (setf (slot-value slot-definition 'sys::initargs) value))))
    24222461
    24232462(defgeneric slot-definition-initform (slot-definition)
    24242463  (:method ((slot-definition slot-definition))
    2425     (let ((cl (class-of slot-definition)))
    2426       (case cl
    2427   ((+the-slot-definition-class+
    2428     +the-direct-slot-definition-class+
    2429     +the-effective-slot-definition-class+)
    2430    (%slot-definition-initform slot-definition))
    2431   (t (slot-value slot-definition 'sys::initform))))))
     2464    (slot-definition-dispatch slot-definition
     2465      (%slot-definition-initform slot-definition)
     2466      (slot-value slot-definition 'sys::initform))))
     2467
     2468(defgeneric (setf slot-definition-initform) (value slot-definition)
     2469  (:method (value (slot-definition slot-definition))
     2470    (slot-definition-dispatch slot-definition
     2471      (set-slot-definition-initform slot-definition value)
     2472      (setf (slot-value slot-definition 'sys::initform) value))))
    24322473
    24332474(defgeneric slot-definition-initfunction (slot-definition)
    24342475  (:method ((slot-definition slot-definition))
    2435     (let ((cl (class-of slot-definition)))
    2436       (case cl
    2437   ((+the-slot-definition-class+
    2438     +the-direct-slot-definition-class+
    2439     +the-effective-slot-definition-class+)
    2440    (%slot-definition-initfunction slot-definition))
    2441   (t (slot-value slot-definition 'sys::initfunction))))))
     2476    (slot-definition-dispatch slot-definition
     2477      (%slot-definition-initfunction slot-definition)
     2478      (slot-value slot-definition 'sys::initfunction))))
     2479
     2480(defgeneric (setf slot-definition-initfunction) (value slot-definition)
     2481  (:method (value (slot-definition slot-definition))
     2482    (slot-definition-dispatch slot-definition
     2483      (set-slot-definition-initfunction slot-definition value)
     2484      (setf (slot-value slot-definition 'sys::initfunction) value))))
    24422485
    24432486(defgeneric slot-definition-name (slot-definition)
    24442487  (:method ((slot-definition slot-definition))
    2445     (let ((cl (class-of slot-definition)))
    2446       (case cl
    2447   ((+the-slot-definition-class+
    2448     +the-direct-slot-definition-class+
    2449     +the-effective-slot-definition-class+)
    2450    (%slot-definition-name slot-definition))
    2451   (t (slot-value slot-definition 'sys::name))))))
     2488    (slot-definition-dispatch slot-definition
     2489      (%slot-definition-name slot-definition)
     2490      (slot-value slot-definition 'sys::name))))
     2491
     2492(defgeneric (setf slot-definition-name) (value slot-definition)
     2493  (:method (value (slot-definition slot-definition))
     2494    (slot-definition-dispatch slot-definition
     2495      (set-slot-definition-name slot-definition value)
     2496      (setf (slot-value slot-definition 'sys::name) value))))
    24522497
    24532498;;; No %slot-definition-type.
Note: See TracChangeset for help on using the changeset viewer.