Changeset 4337


Ignore:
Timestamp:
10/12/03 19:14:23 (19 years ago)
Author:
piso
Message:

ENSURE-CLASS: check for duplicate slots.

File:
1 edited

Legend:

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

    r4336 r4337  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.18 2003-10-12 18:40:17 piso Exp $
     4;;; $Id: defclass.lisp,v 1.19 2003-10-12 19:14:23 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1717;;; along with this program; if not, write to the Free Software
    1818;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
     19
     20;;; Adapted from Closette.
    1921
    2022(in-package "SYSTEM")
     
    129131;;; error), so that it's easy to add new ones.
    130132
    131 (defun make-direct-slot-definition
    132   (&rest properties
    133          &key name (initargs ()) (initform nil) (initfunction nil)
    134          (readers ()) (writers ()) (allocation :instance)
    135          &allow-other-keys)
     133(defun make-direct-slot-definition (&rest properties
     134                                          &key name
     135                                          (initargs ())
     136                                          (initform nil)
     137                                          (initfunction nil)
     138                                          (readers ())
     139                                          (writers ())
     140                                          (allocation :instance)
     141                                          &allow-other-keys)
    136142  (let ((slot (copy-list properties))) ; Don't want to side effect &rest list
    137143    (setf (getf* slot ':name) name)
     
    144150    slot))
    145151
    146 (defun make-effective-slot-definition
    147   (&rest properties
    148          &key name (initargs ()) (initform nil) (initfunction nil)
    149          (allocation :instance)
    150          &allow-other-keys)
     152(defun make-effective-slot-definition (&rest properties
     153                                             &key name
     154                                             (initargs ())
     155                                             (initform nil)
     156                                             (initfunction nil)
     157                                             (allocation :instance)
     158                                             &allow-other-keys)
    151159  (let ((slot (copy-list properties)))  ; Don't want to side effect &rest list
    152160    (setf (getf* slot ':name) name)
     
    465473                           slot-properties))
    466474                 direct-slots)))
    467 ;;     (format t "slots = ~S~%" slots)
    468475    (setf (class-direct-slots class) slots)
    469476    (dolist (direct-slot slots)
     
    473480      (dolist (writer (slot-definition-writers direct-slot))
    474481        (add-writer-method
    475          class writer (slot-definition-name direct-slot))))
    476     )
     482         class writer (slot-definition-name direct-slot)))))
    477483  (funcall (if (eq (class-of class) (find-class 'standard-class))
    478484               #'std-finalize-inheritance
     
    481487  (values))
    482488
     489(defun canonical-slot-name (canonical-slot)
     490  (getf canonical-slot :name))
     491
    483492(defun ensure-class (name &rest all-keys &allow-other-keys)
     493  ;; Check for duplicate slots.
     494  (let ((slots (getf all-keys :direct-slots)))
     495    (dolist (s1 slots)
     496      (let ((name1 (canonical-slot-name s1)))
     497        (dolist (s2 (cdr (memq s1 slots)))
     498    (when (eq name1 (canonical-slot-name s2))
     499            (error 'program-error "duplicate slot ~S" name1))))))
    484500  (let ((class (find-class name nil)))
    485501    (unless class
    486       (setf class (apply #'make-instance-standard-class (find-class 'standard-class) :name name all-keys))
     502      (setf class (apply #'make-instance-standard-class
     503                         (find-class 'standard-class) :name name all-keys))
    487504      (add-class class))
    488505    class))
Note: See TracChangeset for help on using the changeset viewer.