Changeset 12752


Ignore:
Timestamp:
06/13/10 21:33:04 (12 years ago)
Author:
astalla
Message:

Progress towards custom slot definition support: use of generic slot-definition-*

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java

    r12749 r12752  
    9191  }
    9292
    93   public static SlotDefinition checkSlotDefinition(LispObject obj) {
    94           if (obj instanceof SlotDefinition) return (SlotDefinition)obj;
    95       return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION);     
     93  public static StandardObject checkSlotDefinition(LispObject obj) {
     94          if (obj instanceof StandardObject) return (StandardObject)obj;
     95      return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION);     
    9696  }
    9797
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r12749 r12752  
    6161  (find-class 'standard-generic-function))
    6262(defconstant +the-T-class+ (find-class 'T))
     63(defconstant +the-slot-definition-class+ (find-class 'slot-definition))
    6364(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
    6465(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
     
    262263  `(function (lambda () ,initform)))
    263264
     265(defun slot-definition-allocation (slot-definition)
     266  (%slot-definition-allocation slot-definition))
     267
     268(defun slot-definition-initargs (slot-definition)
     269  (%slot-definition-initargs slot-definition))
     270
     271(defun slot-definition-initform (slot-definition)
     272  (%slot-definition-initform slot-definition))
     273
     274(defun slot-definition-initfunction (slot-definition)
     275  (%slot-definition-initfunction slot-definition))
     276
     277(defun slot-definition-name (slot-definition)
     278  (%slot-definition-name slot-definition))
     279
    264280(defun init-slot-definition (slot &key name
    265281           (initargs ())
     
    328344        (shared-slots '()))
    329345    (dolist (slot (class-slots class))
    330       (case (%slot-definition-allocation slot)
     346      (case (slot-definition-allocation slot)
    331347        (:instance
    332348         (set-slot-definition-location slot length)
    333349         (incf length)
    334          (push (%slot-definition-name slot) instance-slots))
     350         (push (slot-definition-name slot) instance-slots))
    335351        (:class
    336352         (unless (%slot-definition-location slot)
     
    338354             (set-slot-definition-location slot
    339355                                           (if (eq allocation-class class)
    340                                                (cons (%slot-definition-name slot) +slot-unbound+)
    341                                                (slot-location allocation-class (%slot-definition-name slot))))))
     356                                               (cons (slot-definition-name slot) +slot-unbound+)
     357                                               (slot-location allocation-class (slot-definition-name slot))))))
    342358         (push (%slot-definition-location slot) shared-slots))))
    343359    (when old-layout
     
    347363               (old-location (layout-slot-location old-layout slot-name)))
    348364          (unless old-location
    349             (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name))
    350                    (initfunction (%slot-definition-initfunction slot-definition)))
     365            (let* ((slot-definition (find slot-name (class-slots class) :key #'slot-definition-name))
     366                   (initfunction (slot-definition-initfunction slot-definition)))
    351367              (when initfunction
    352368                (setf (cdr location) (funcall initfunction))))))))
     
    450466                               (class-precedence-list class)))
    451467         (all-names (remove-duplicates
    452                      (mapcar #'%slot-definition-name all-slots))))
     468                     (mapcar #'slot-definition-name all-slots))))
    453469    (mapcar #'(lambda (name)
    454470               (funcall
     
    458474                class
    459475                (remove name all-slots
    460                         :key #'%slot-definition-name
     476                        :key #'slot-definition-name
    461477                        :test-not #'eq)))
    462478            all-names)))
     
    464480(defun std-compute-effective-slot-definition (class direct-slots)
    465481  (let ((initer (find-if-not #'null direct-slots
    466                              :key #'%slot-definition-initfunction)))
     482                             :key #'slot-definition-initfunction)))
    467483    (make-effective-slot-definition
    468484     class
    469      :name (%slot-definition-name (car direct-slots))
     485     :name (slot-definition-name (car direct-slots))
    470486     :initform (if initer
    471                    (%slot-definition-initform initer)
     487                   (slot-definition-initform initer)
    472488                   nil)
    473489     :initfunction (if initer
    474                        (%slot-definition-initfunction initer)
     490                       (slot-definition-initfunction initer)
    475491                       nil)
    476492     :initargs (remove-duplicates
    477                 (mapappend #'%slot-definition-initargs
     493                (mapappend #'slot-definition-initargs
    478494                           direct-slots))
    479      :allocation (%slot-definition-allocation (car direct-slots))
     495     :allocation (slot-definition-allocation (car direct-slots))
    480496     :allocation-class (%slot-definition-allocation-class (car direct-slots)))))
    481497
     
    488504(defun find-slot-definition (class slot-name)
    489505  (dolist (slot (class-slots class) nil)
    490     (when (eq slot-name (%slot-definition-name slot))
     506    (when (eq slot-name (slot-definition-name slot))
    491507      (return slot))))
    492508
     
    538554(defun std-slot-exists-p (instance slot-name)
    539555  (not (null (find slot-name (class-slots (class-of instance))
    540                    :key #'%slot-definition-name))))
     556                   :key #'slot-definition-name))))
    541557
    542558(defun slot-exists-p (object slot-name)
     
    546562
    547563(defun instance-slot-p (slot)
    548   (eq (%slot-definition-allocation slot) :instance))
     564  (eq (slot-definition-allocation slot) :instance))
    549565
    550566(defun make-instance-standard-class (metaclass
     
    588604    (dolist (direct-slot slots)
    589605      (dolist (reader (%slot-definition-readers direct-slot))
    590         (add-reader-method class reader (%slot-definition-name direct-slot)))
     606        (add-reader-method class reader (slot-definition-name direct-slot)))
    591607      (dolist (writer (%slot-definition-writers direct-slot))
    592         (add-writer-method class writer (%slot-definition-name direct-slot)))))
     608        (add-writer-method class writer (slot-definition-name direct-slot)))))
    593609  (setf (class-direct-default-initargs class) direct-default-initargs)
    594610  (funcall (if (eq (class-of class) +the-standard-class+)
     
    21612177(defun valid-initarg-p (initarg slots)
    21622178  (dolist (slot slots nil)
    2163     (let ((valid-initargs (%slot-definition-initargs slot)))
     2179    (let ((valid-initargs (slot-definition-initargs slot)))
    21642180      (when (memq initarg valid-initargs)
    21652181        (return t)))))
     
    22182234       :format-arguments (list initarg))))
    22192235  (dolist (slot (class-slots (class-of instance)))
    2220     (let ((slot-name (%slot-definition-name slot)))
     2236    (let ((slot-name (slot-definition-name slot)))
    22212237      (multiple-value-bind (init-key init-value foundp)
    2222           (get-properties all-keys (%slot-definition-initargs slot))
     2238          (get-properties all-keys (slot-definition-initargs slot))
    22232239        (if foundp
    22242240            (setf (std-slot-value instance slot-name) init-value)
    22252241            (unless (std-slot-boundp instance slot-name)
    2226               (let ((initfunction (%slot-definition-initfunction slot)))
     2242              (let ((initfunction (slot-definition-initfunction slot)))
    22272243                (when (and initfunction (or (eq slot-names t)
    22282244                                            (memq slot-name slot-names)))
     
    22612277    (dolist (new-slot new-slots)
    22622278      (when (instance-slot-p new-slot)
    2263         (let* ((slot-name (%slot-definition-name new-slot))
    2264                (old-slot (find slot-name old-slots :key #'%slot-definition-name)))
     2279        (let* ((slot-name (slot-definition-name new-slot))
     2280               (old-slot (find slot-name old-slots :key #'slot-definition-name)))
    22652281          ;; "The values of slots specified as shared in the class CFROM and as
    22662282          ;; local in the class CTO are retained."
     
    22852301         (remove-if #'(lambda (slot-name)
    22862302                       (slot-exists-p old slot-name))
    2287                     (mapcar #'%slot-definition-name
     2303                    (mapcar #'slot-definition-name
    22882304                            (class-slots (class-of new))))))
    22892305    (check-initargs new added-slots initargs)
     
    23762392;;; Slot definition accessors
    23772393
    2378 (export '(slot-definition-allocation
     2394(mapcar (lambda (sym)
     2395    (fmakunbound sym) ;;we need to redefine them as GFs
     2396    (export sym))
     2397  '(slot-definition-allocation
    23792398    slot-definition-initargs
    23802399    slot-definition-initform
     
    23842403(defgeneric slot-definition-allocation (slot-definition)
    23852404  (:method ((slot-definition slot-definition))
    2386     (%slot-definition-allocation slot-definition)))
     2405    (let ((cl (class-of slot-definition)))
     2406      (case cl
     2407  ((+the-slot-definition-class+
     2408    +the-direct-slot-definition-class+
     2409    +the-effective-slot-definition-class+)
     2410   (%slot-definition-allocation slot-definition))
     2411  (t (slot-value slot-definition 'sys::allocation))))))
    23872412
    23882413(defgeneric slot-definition-initargs (slot-definition)
    23892414  (:method ((slot-definition slot-definition))
    2390     (%slot-definition-initargs slot-definition)))
     2415    (let ((cl (class-of slot-definition)))
     2416      (case cl
     2417  ((+the-slot-definition-class+
     2418    +the-direct-slot-definition-class+
     2419    +the-effective-slot-definition-class+)
     2420   (%slot-definition-initargs slot-definition))
     2421  (t (slot-value slot-definition 'sys::initargs))))))
    23912422
    23922423(defgeneric slot-definition-initform (slot-definition)
    23932424  (:method ((slot-definition slot-definition))
    2394     (%slot-definition-initform slot-definition)))
     2425    (let ((cl (class-of slot-definition)))
     2426      (case cl
     2427  ((+the-slot-definition-class+
     2428    +the-direct-slot-definition-class+
     2429    +the-effective-slot-definition-class+)
     2430   (%slot-definition-initform slot-definition))
     2431  (t (slot-value slot-definition 'sys::initform))))))
    23952432
    23962433(defgeneric slot-definition-initfunction (slot-definition)
    23972434  (:method ((slot-definition slot-definition))
    2398     (%slot-definition-initfunction slot-definition)))
     2435    (let ((cl (class-of slot-definition)))
     2436      (case cl
     2437  ((+the-slot-definition-class+
     2438    +the-direct-slot-definition-class+
     2439    +the-effective-slot-definition-class+)
     2440   (%slot-definition-initfunction slot-definition))
     2441  (t (slot-value slot-definition 'sys::initfunction))))))
    23992442
    24002443(defgeneric slot-definition-name (slot-definition)
    24012444  (:method ((slot-definition slot-definition))
    2402     (%slot-definition-name slot-definition)))
     2445    (let ((cl (class-of slot-definition)))
     2446      (case cl
     2447  ((+the-slot-definition-class+
     2448    +the-direct-slot-definition-class+
     2449    +the-effective-slot-definition-class+)
     2450   (%slot-definition-name slot-definition))
     2451  (t (slot-value slot-definition 'sys::name))))))
    24032452
    24042453;;; No %slot-definition-type.
Note: See TracChangeset for help on using the changeset viewer.