Changeset 5070


Ignore:
Timestamp:
12/11/03 19:17:41 (18 years ago)
Author:
piso
Message:

Layout-related changes.

File:
1 edited

Legend:

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

    r5057 r5070  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.33 2003-12-10 18:20:57 piso Exp $
     4;;; $Id: clos.lisp,v 1.34 2003-12-11 19:17:41 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    7070
    7171(defsetf class-name %set-class-name)
     72(defsetf class-layout %set-class-layout)
    7273(defsetf class-direct-superclasses %set-class-direct-superclasses)
    7374(defsetf class-direct-subclasses %set-class-direct-subclasses)
     
    7879(defsetf class-default-initargs %set-class-default-initargs)
    7980(defsetf class-precedence-list %set-class-precedence-list)
    80 (defsetf std-instance-class %set-std-instance-class)
     81(defsetf std-instance-layout %set-std-instance-layout)
    8182(defsetf std-instance-slots %set-std-instance-slots)
    8283
     
    252253                     #'compute-slots)
    253254                 class))
    254   (let ((location 0))
     255  (let ((length 0))
    255256    (dolist (slot (class-slots class))
    256257      (case (slot-definition-allocation slot)
    257258        (:instance
    258          (setf (slot-definition-location slot) location)
    259          (incf location))
     259         (setf (slot-definition-location slot) length)
     260         (incf length))
    260261        (:class
    261262         (unless (slot-definition-location slot)
     
    264265                   (if (eq class allocation-class)
    265266                       (cons (slot-definition-name slot) +slot-unbound+)
    266                        (slot-location allocation-class (slot-definition-name slot))))))))))
     267                       (slot-location allocation-class (slot-definition-name slot)))))))))
     268    (setf (class-layout class)
     269          (make-layout class length)))
    267270  (setf (class-default-initargs class)
    268271        (compute-class-default-initargs class))
     
    396399     :allocation-class (slot-definition-allocation-class (car direct-slots)))))
    397400
    398 ;;; Simple vectors are used for slot storage.
    399 
    400 (defun allocate-slot-storage (size initial-value)
    401   (make-array size :initial-element initial-value))
    402 
    403401;;; Standard instance slot access
    404402
     
    498496      (slot-exists-p-using-class (class-of object) object slot-name)))
    499497
    500 ;;; Standard instance allocation
    501 
    502498(defun instance-slot-p (slot)
    503499  (eq (slot-definition-allocation slot) :instance))
    504500
     501;;; Simple vectors are used for slot storage.
     502
     503(defun allocate-slot-storage (size initial-value)
     504  (make-array size :initial-element initial-value))
     505
     506;;; Standard instance allocation
     507
    505508(defun std-allocate-instance (class)
    506   (allocate-std-instance
    507    class
    508    (allocate-slot-storage (count-if #'instance-slot-p (class-slots class))
    509                           +slot-unbound+)))
     509  (let* ((layout (class-layout class))
     510         (length (and layout (layout-length layout))))
     511    (unless layout
     512      (format t "no layout for class ~S~%" class)
     513      (backtrace))
     514    (unless length
     515      (format t "no layout length for class ~S~%" class)
     516      (setf length (count-if #'instance-slot-p (class-slots class))))
     517    (allocate-std-instance class
     518                           (allocate-slot-storage length +slot-unbound+))))
    510519
    511520(defun make-instance-standard-class (metaclass
     
    658667;;   (slot-value gf 'classes-to-emf-table))
    659668  (slot-contents (std-instance-slots gf) *sgf-classes-to-emf-table-index*))
     669
    660670(defun (setf classes-to-emf-table) (new-value gf)
    661671  (setf (slot-value gf 'classes-to-emf-table) new-value))
     
    14881498(defgeneric change-class (instance new-class &key))
    14891499
    1490 (defmethod change-class
    1491   ((old-instance standard-object)
    1492    (new-class standard-class)
    1493    &rest initargs)
     1500(defmethod change-class ((old-instance standard-object) (new-class standard-class)
     1501                         &rest initargs)
    14941502  (let ((new-instance (allocate-instance new-class)))
    14951503    (dolist (slot-name (mapcar #'slot-definition-name
     
    15011509    (rotatef (std-instance-slots new-instance)
    15021510             (std-instance-slots old-instance))
    1503     (rotatef (std-instance-class new-instance)
    1504              (std-instance-class old-instance))
     1511    (rotatef (std-instance-layout new-instance)
     1512             (std-instance-layout old-instance))
    15051513    (apply #'update-instance-for-different-class
    15061514           new-instance old-instance initargs)
    15071515    old-instance))
    15081516
    1509 (defmethod change-class
    1510   ((instance standard-object) (new-class symbol) &rest initargs)
     1517(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
    15111518  (apply #'change-class instance (find-class new-class) initargs))
    15121519
Note: See TracChangeset for help on using the changeset viewer.