Changeset 5040


Ignore:
Timestamp:
12/09/03 22:07:57 (17 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r5039 r5040  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.20 2003-12-09 21:14:51 piso Exp $
     4;;; $Id: clos.lisp,v 1.21 2003-12-09 22:07:57 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    167167  writers
    168168  allocation
    169   location)
     169  allocation-class
     170  (location nil))
    170171
    171172(defun make-direct-slot-definition (class &rest properties
     
    186187    (setf (slot-definition-writers slot) writers)
    187188    (setf (slot-definition-allocation slot) allocation)
     189    (setf (slot-definition-allocation-class slot) class)
    188190    slot))
    189191
     
    194196                                             (initfunction nil)
    195197                                             (allocation :instance)
     198                                             (allocation-class nil)
    196199                                             &allow-other-keys)
    197200  (let ((slot (make-slot-definition)))
     
    201204    (setf (slot-definition-initfunction slot) initfunction)
    202205    (setf (slot-definition-allocation slot) allocation)
     206    (setf (slot-definition-allocation-class slot) allocation-class)
    203207    slot))
    204208
     
    223227         (incf location))
    224228        (:class
    225          (setf (slot-definition-location slot)
    226                (cons (slot-definition-name slot) +slot-unbound+))))))
     229         (unless (slot-definition-location slot)
     230           (let ((allocation-class (slot-definition-allocation-class slot)))
     231             (setf (slot-definition-location slot)
     232                   (if (eq class allocation-class)
     233                       (cons (slot-definition-name slot) +slot-unbound+)
     234                       (slot-location allocation-class (slot-definition-name slot))))))))))
    227235  (setf (class-default-initargs class)
    228236        (compute-class-default-initargs class))
     
    353361                (mapappend #'slot-definition-initargs
    354362                           direct-slots))
    355      :allocation (slot-definition-allocation (car direct-slots)))))
     363     :allocation (slot-definition-allocation (car direct-slots))
     364     :allocation-class (slot-definition-allocation-class (car direct-slots)))))
    356365
    357366;;; Simple vectors are used for slot storage.
Note: See TracChangeset for help on using the changeset viewer.