Changeset 4279


Ignore:
Timestamp:
10/10/03 14:15:43 (19 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4107 r4279  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.1 2003-09-28 18:34:45 piso Exp $
     4;;; $Id: defclass.lisp,v 1.2 2003-10-10 14:15:43 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2222(defmacro push-on-end (value location)
    2323  `(setf ,location (nconc ,location (list ,value))))
     24
     25;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
     26;;; which must be non-nil.
     27
     28(defun (setf getf*) (new-value plist key)
     29  (block body
     30    (do ((x plist (cddr x)))
     31        ((null x))
     32      (when (eq (car x) key)
     33        (setf (car (cdr x)) new-value)
     34        (return-from body new-value)))
     35    (push-on-end key plist)
     36    (push-on-end new-value plist)
     37    new-value))
    2438
    2539(defun mapappend (fun &rest args)
     
    3448      (cons (funcall fun (car x) (cadr x))
    3549            (mapplist fun (cddr x)))))
     50
     51(defsetf class-name %set-class-name)
    3652
    3753(defun canonicalize-direct-slots (direct-slots)
     
    102118    (t (list `',(car option) `',(cadr option)))))
    103119
     120;;; Slot definition metaobjects
     121
     122;;; N.B. Quietly retain all unknown slot options (rather than signaling an
     123;;; error), so that it's easy to add new ones.
     124
     125(defun make-direct-slot-definition
     126  (&rest properties
     127         &key name (initargs ()) (initform nil) (initfunction nil)
     128         (readers ()) (writers ()) (allocation :instance)
     129         &allow-other-keys)
     130  (let ((slot (copy-list properties))) ; Don't want to side effect &rest list
     131    (setf (getf* slot ':name) name)
     132    (setf (getf* slot ':initargs) initargs)
     133    (setf (getf* slot ':initform) initform)
     134    (setf (getf* slot ':initfunction) initfunction)
     135    (setf (getf* slot ':readers) readers)
     136    (setf (getf* slot ':writers) writers)
     137    (setf (getf* slot ':allocation) allocation)
     138    slot))
     139
     140(defun make-effective-slot-definition
     141  (&rest properties
     142         &key name (initargs ()) (initform nil) (initfunction nil)
     143         (allocation :instance)
     144         &allow-other-keys)
     145  (let ((slot (copy-list properties)))  ; Don't want to side effect &rest list
     146    (setf (getf* slot ':name) name)
     147    (setf (getf* slot ':initargs) initargs)
     148    (setf (getf* slot ':initform) initform)
     149    (setf (getf* slot ':initfunction) initfunction)
     150    (setf (getf* slot ':allocation) allocation)
     151    slot))
     152
     153(defun slot-definition-name (slot)
     154  (getf slot ':name))
     155(defun (setf slot-definition-name) (new-value slot)
     156  (setf (getf* slot ':name) new-value))
     157
     158(defun slot-definition-initfunction (slot)
     159  (getf slot ':initfunction))
     160(defun (setf slot-definition-initfunction) (new-value slot)
     161  (setf (getf* slot ':initfunction) new-value))
     162
     163(defun slot-definition-initform (slot)
     164  (getf slot ':initform))
     165(defun (setf slot-definition-initform) (new-value slot)
     166  (setf (getf* slot ':initform) new-value))
     167
     168(defun slot-definition-initargs (slot)
     169  (getf slot ':initargs))
     170(defun (setf slot-definition-initargs) (new-value slot)
     171  (setf (getf* slot ':initargs) new-value))
     172
     173(defun slot-definition-readers (slot)
     174  (getf slot ':readers))
     175(defun (setf slot-definition-readers) (new-value slot)
     176  (setf (getf* slot ':readers) new-value))
     177
     178(defun slot-definition-writers (slot)
     179  (getf slot ':writers))
     180(defun (setf slot-definition-writers) (new-value slot)
     181  (setf (getf* slot ':writers) new-value))
     182
     183(defun slot-definition-allocation (slot)
     184  (getf slot ':allocation))
     185(defun (setf slot-definition-allocation) (new-value slot)
     186  (setf (getf* slot ':allocation) new-value))
     187
     188;;; Simple vectors are used for slot storage.
     189
     190(defun allocate-slot-storage (size initial-value)
     191  (make-array size :initial-element initial-value))
     192
     193;;; Standard instance allocation
     194
     195(defparameter secret-unbound-value (list "slot unbound"))
     196
     197(defun instance-slot-p (slot)
     198  (eq (slot-definition-allocation slot) ':instance))
     199
     200(defun std-allocate-instance (class)
     201  (allocate-std-instance
     202   class
     203   (allocate-slot-storage (count-if #'instance-slot-p (class-slots class))
     204                          secret-unbound-value)))
     205
     206(defun make-instance-standard-class
     207  (metaclass &key name direct-superclasses direct-slots
     208             &allow-other-keys)
     209  (declare (ignore metaclass))
     210  (let ((class (std-allocate-instance (find-class 'standard-class))))
     211    (setf (class-name class) name)
     212;;     (setf (class-direct-subclasses class) ())
     213;;     (setf (class-direct-methods class) ())
     214    (std-after-initialization-for-classes class
     215                                          :direct-slots direct-slots
     216                                          :direct-superclasses direct-superclasses)
     217    class))
     218
     219;; FIXME
     220(defun std-after-initialization-for-classes (&rest args) )
     221
    104222(defun ensure-class (name &rest all-keys &allow-other-keys)
    105223  (let ((class (find-class name nil)))
    106224    (unless class
    107       (setf class (make-instance-standard-class name all-keys))
     225      (setf class (apply #'make-instance-standard-class (find-class 'standard-class) :name name all-keys))
    108226      (add-class class))
    109227    class))
Note: See TracChangeset for help on using the changeset viewer.