Changeset 5032


Ignore:
Timestamp:
12/09/03 02:48:27 (18 years ago)
Author:
piso
Message:

Support :allocation :class slots.

File:
1 edited

Legend:

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

    r5031 r5032  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.17 2003-12-08 21:28:44 piso Exp $
     4;;; $Id: clos.lisp,v 1.18 2003-12-09 02:48:27 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    151151    (t (list `',(car option) `',(cadr option)))))
    152152
     153(defconstant +slot-unbound+ (make-symbol "SLOT-UNBOUND"))
     154
    153155;;; Slot definition metaobjects
    154156
     
    212214  (let ((location 0))
    213215    (dolist (slot (class-slots class))
    214       (when (instance-slot-p slot)
    215         (setf (slot-definition-location slot) location)
    216         (incf location))))
     216      (case (slot-definition-allocation slot)
     217        (:instance
     218         (setf (slot-definition-location slot) location)
     219         (incf location))
     220        (:class
     221         (setf (slot-definition-location slot)
     222               (cons (slot-definition-name slot) +slot-unbound+))))))
    217223  (setf (class-default-initargs class)
    218224        (compute-class-default-initargs class))
     
    377383
    378384(defun std-slot-value (instance slot-name)
    379   (let ((location (slot-location (class-of instance) slot-name)))
    380     (if location
    381         (let ((val (slot-contents (std-instance-slots instance) location)))
    382           (if (eq secret-unbound-value val)
    383               (error "the slot ~S is unbound in the object ~S" slot-name instance)
    384               val))
    385         (slot-missing (class-of instance) instance slot-name 'slot-value))))
     385  (let* ((location (slot-location (class-of instance) slot-name))
     386         (value (cond ((fixnump location)
     387                       (slot-contents (std-instance-slots instance) location))
     388                      ((consp location)
     389                       (cdr location))
     390                      (t
     391                       (slot-missing (class-of instance) instance slot-name 'slot-value)))))
     392    (if (eq +slot-unbound+ value)
     393        (error "the slot ~S is unbound in the object ~S" slot-name instance)
     394        value)))
    386395
    387396(defun slot-value (object slot-name)
     
    391400
    392401(defun (setf std-slot-value) (new-value instance slot-name)
    393   (let ((location (slot-location (class-of instance) slot-name))
    394         (slots (std-instance-slots instance)))
    395     (if location
    396         (setf (slot-contents slots location) new-value)
    397         (progn
    398           (slot-missing (class-of instance) instance slot-name 'setf new-value)
    399           new-value))))
     402  (let ((location (slot-location (class-of instance) slot-name)))
     403    (cond ((fixnump location)
     404           (setf (slot-contents (std-instance-slots instance) location) new-value))
     405          ((consp location)
     406           (setf (cdr location) new-value))
     407          (t
     408           (slot-missing (class-of instance) instance slot-name 'setf new-value))))
     409  new-value)
     410
    400411(defun (setf slot-value) (new-value object slot-name)
    401412  (if (eq (class-of (class-of object)) the-class-standard-class)
     
    405416
    406417(defun std-slot-boundp (instance slot-name)
    407   (let ((location (slot-location (class-of instance) slot-name))
    408         (slots (std-instance-slots instance)))
    409     (if location
    410         (not (eq secret-unbound-value (slot-contents slots location)))
    411         (not (null (slot-missing (class-of instance) instance slot-name 'slot-boundp))))))
     418  (let ((location (slot-location (class-of instance) slot-name)))
     419    (cond ((fixnump location)
     420           (neq +slot-unbound+ (slot-contents (std-instance-slots instance) location)))
     421          ((consp location)
     422           (neq +slot-unbound+ (cdr location)))
     423          (t
     424           (not (null (slot-missing (class-of instance) instance slot-name 'slot-boundp)))))))
     425
    412426(defun slot-boundp (object slot-name)
    413427  (if (eq (class-of (class-of object)) the-class-standard-class)
     
    416430
    417431(defun std-slot-makunbound (instance slot-name)
    418   (let ((location (slot-location (class-of instance) slot-name))
    419         (slots (std-instance-slots instance)))
    420     (if location
    421         (setf (slot-contents slots location) secret-unbound-value)
    422         (slot-missing (class-of instance) instance slot-name 'slot-makunbound))
    423   instance))
     432  (let ((location (slot-location (class-of instance) slot-name)))
     433    (cond ((fixnump location)
     434           (setf (slot-contents (std-instance-slots instance) location) +slot-unbound+))
     435          ((consp location)
     436           (setf (cdr location) +slot-unbound+))
     437          (t
     438           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
     439  instance)
     440
    424441(defun slot-makunbound (object slot-name)
    425442  (if (eq (class-of (class-of object)) the-class-standard-class)
     
    437454;;; Standard instance allocation
    438455
    439 (defparameter secret-unbound-value (list "slot unbound"))
    440 
    441456(defun instance-slot-p (slot)
    442   (eq (slot-definition-allocation slot) ':instance))
     457  (eq (slot-definition-allocation slot) :instance))
    443458
    444459(defun std-allocate-instance (class)
     
    446461   class
    447462   (allocate-slot-storage (count-if #'instance-slot-p (class-slots class))
    448                           secret-unbound-value)))
     463                          +slot-unbound+)))
    449464
    450465(defun allocate-instance (class)
Note: See TracChangeset for help on using the changeset viewer.