Changeset 4296


Ignore:
Timestamp:
10/10/03 23:35:08 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4290 r4296  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.4 2003-10-10 17:17:24 piso Exp $
     4;;; $Id: defclass.lisp,v 1.5 2003-10-10 23:35:08 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    334334  (make-array size :initial-element initial-value))
    335335
     336;;; Standard instance slot access
     337
     338;;; N.B. The location of the effective-slots slots in the class metaobject for
     339;;; standard-class must be determined without making any further slot
     340;;; references.
     341
     342(defvar the-slots-of-standard-class) ;standard-class's class-slots
     343(defvar the-class-standard-class)    ;standard-class's class metaobject
     344
     345(defun slot-location (class slot-name)
     346  (if (and (eq slot-name 'effective-slots)
     347           (eq class the-class-standard-class))
     348      (position 'effective-slots the-slots-of-standard-class
     349                :key #'slot-definition-name)
     350      (let ((slot (find slot-name
     351                        (class-slots class)
     352                        :key #'slot-definition-name)))
     353        (if (null slot)
     354            (error "The slot ~S is missing from the class ~S."
     355                   slot-name class)
     356            (let ((pos (position slot
     357                                 (remove-if-not #'instance-slot-p
     358                                                (class-slots class)))))
     359              (if (null pos)
     360                  (error "The slot ~S is not an instance~@
     361                  slot in the class ~S."
     362                         slot-name class)
     363                  pos))))))
     364
     365(defun slot-contents (slots location)
     366  (svref slots location))
     367
     368(defun (setf slot-contents) (new-value slots location)
     369  (setf (svref slots location) new-value))
     370
     371(defun std-slot-value (instance slot-name)
     372  (let* ((location (slot-location (class-of instance) slot-name))
     373         (slots (std-instance-slots instance))
     374         (val (slot-contents slots location)))
     375    (if (eq secret-unbound-value val)
     376        (error "The slot ~S is unbound in the object ~S."
     377               slot-name instance)
     378        val)))
     379(defun slot-value (object slot-name)
     380  (if (eq (class-of (class-of object)) the-class-standard-class)
     381      (std-slot-value object slot-name)
     382      (slot-value-using-class (class-of object) object slot-name)))
     383
     384(defun (setf std-slot-value) (new-value instance slot-name)
     385  (let ((location (slot-location (class-of instance) slot-name))
     386        (slots (std-instance-slots instance)))
     387    (setf (slot-contents slots location) new-value)))
     388(defun (setf slot-value) (new-value object slot-name)
     389  (if (eq (class-of (class-of object)) the-class-standard-class)
     390      (setf (std-slot-value object slot-name) new-value)
     391      (setf-slot-value-using-class
     392       new-value (class-of object) object slot-name)))
     393
     394(defun std-slot-boundp (instance slot-name)
     395  (let ((location (slot-location (class-of instance) slot-name))
     396        (slots (std-instance-slots instance)))
     397    (not (eq secret-unbound-value (slot-contents slots location)))))
     398(defun slot-boundp (object slot-name)
     399  (if (eq (class-of (class-of object)) the-class-standard-class)
     400      (std-slot-boundp object slot-name)
     401      (slot-boundp-using-class (class-of object) object slot-name)))
     402
     403(defun std-slot-makunbound (instance slot-name)
     404  (let ((location (slot-location (class-of instance) slot-name))
     405        (slots (std-instance-slots instance)))
     406    (setf (slot-contents slots location) secret-unbound-value))
     407  instance)
     408(defun slot-makunbound (object slot-name)
     409  (if (eq (class-of (class-of object)) the-class-standard-class)
     410      (std-slot-makunbound object slot-name)
     411      (slot-makunbound-using-class (class-of object) object slot-name)))
     412
     413(defun std-slot-exists-p (instance slot-name)
     414  (not (null (find slot-name (class-slots (class-of instance))
     415                   :key #'slot-definition-name))))
     416(defun slot-exists-p (object slot-name)
     417  (if (eq (class-of (class-of object)) the-class-standard-class)
     418      (std-slot-exists-p object slot-name)
     419      (slot-exists-p-using-class (class-of object) object slot-name)))
     420
    336421;;; Standard instance allocation
    337422
Note: See TracChangeset for help on using the changeset viewer.