Changeset 12752

Timestamp:

06/13/10 21:33:04 (13 years ago)

Author:

astalla

Message:

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

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• SlotDefinition.java (modified) (1 diff)
• clos.lisp (modified) (18 diffs)

trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java

@@ -91 +91 @@
   }
 
-  public static SlotDefinition checkSlotDefinition(LispObject obj) {
-          if (obj instanceof SlotDefinition) return (SlotDefinition)obj;
-      return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION);     
+  public static StandardObject checkSlotDefinition(LispObject obj) {
+          if (obj instanceof StandardObject) return (StandardObject)obj;
+      return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION);     
   }
 

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -61 +61 @@
   (find-class 'standard-generic-function))
 (defconstant +the-T-class+ (find-class 'T))
+(defconstant +the-slot-definition-class+ (find-class 'slot-definition))
 (defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
 (defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
@@ -262 +263 @@
   `(function (lambda () ,initform)))
 
+(defun slot-definition-allocation (slot-definition)
+  (%slot-definition-allocation slot-definition))
+
+(defun slot-definition-initargs (slot-definition)
+  (%slot-definition-initargs slot-definition))
+
+(defun slot-definition-initform (slot-definition)
+  (%slot-definition-initform slot-definition))
+
+(defun slot-definition-initfunction (slot-definition)
+  (%slot-definition-initfunction slot-definition))
+
+(defun slot-definition-name (slot-definition)
+  (%slot-definition-name slot-definition))
+
 (defun init-slot-definition (slot &key name
            (initargs ())
@@ -328 +344 @@
         (shared-slots '()))
     (dolist (slot (class-slots class))
-      (case (%slot-definition-allocation slot)
+      (case (slot-definition-allocation slot)
         (:instance
          (set-slot-definition-location slot length)
          (incf length)
-         (push (%slot-definition-name slot) instance-slots))
+         (push (slot-definition-name slot) instance-slots))
         (:class
          (unless (%slot-definition-location slot)
@@ -338 +354 @@
              (set-slot-definition-location slot
                                            (if (eq allocation-class class)
-                                               (cons (%slot-definition-name slot) +slot-unbound+)
-                                               (slot-location allocation-class (%slot-definition-name slot))))))
+                                               (cons (slot-definition-name slot) +slot-unbound+)
+                                               (slot-location allocation-class (slot-definition-name slot))))))
          (push (%slot-definition-location slot) shared-slots))))
     (when old-layout
@@ -347 +363 @@
                (old-location (layout-slot-location old-layout slot-name)))
           (unless old-location
-            (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name))
-                   (initfunction (%slot-definition-initfunction slot-definition)))
+            (let* ((slot-definition (find slot-name (class-slots class) :key #'slot-definition-name))
+                   (initfunction (slot-definition-initfunction slot-definition)))
               (when initfunction
                 (setf (cdr location) (funcall initfunction))))))))
@@ -450 +466 @@
                                (class-precedence-list class)))
          (all-names (remove-duplicates
-                     (mapcar #'%slot-definition-name all-slots))))
+                     (mapcar #'slot-definition-name all-slots))))
     (mapcar #'(lambda (name)
                (funcall
@@ -458 +474 @@
                 class
                 (remove name all-slots
-                        :key #'%slot-definition-name
+                        :key #'slot-definition-name
                         :test-not #'eq)))
             all-names)))
@@ -464 +480 @@
 (defun std-compute-effective-slot-definition (class direct-slots)
   (let ((initer (find-if-not #'null direct-slots
-                             :key #'%slot-definition-initfunction)))
+                             :key #'slot-definition-initfunction)))
     (make-effective-slot-definition
      class
-     :name (%slot-definition-name (car direct-slots))
+     :name (slot-definition-name (car direct-slots))
      :initform (if initer
-                   (%slot-definition-initform initer)
+                   (slot-definition-initform initer)
                    nil)
      :initfunction (if initer
-                       (%slot-definition-initfunction initer)
+                       (slot-definition-initfunction initer)
                        nil)
      :initargs (remove-duplicates
-                (mapappend #'%slot-definition-initargs
+                (mapappend #'slot-definition-initargs
                            direct-slots))
-     :allocation (%slot-definition-allocation (car direct-slots))
+     :allocation (slot-definition-allocation (car direct-slots))
      :allocation-class (%slot-definition-allocation-class (car direct-slots)))))
 
@@ -488 +504 @@
 (defun find-slot-definition (class slot-name)
   (dolist (slot (class-slots class) nil)
-    (when (eq slot-name (%slot-definition-name slot))
+    (when (eq slot-name (slot-definition-name slot))
       (return slot))))
 
@@ -538 +554 @@
 (defun std-slot-exists-p (instance slot-name)
   (not (null (find slot-name (class-slots (class-of instance))
-                   :key #'%slot-definition-name))))
+                   :key #'slot-definition-name))))
 
 (defun slot-exists-p (object slot-name)
@@ -546 +562 @@
 
 (defun instance-slot-p (slot)
-  (eq (%slot-definition-allocation slot) :instance))
+  (eq (slot-definition-allocation slot) :instance))
 
 (defun make-instance-standard-class (metaclass
@@ -588 +604 @@
     (dolist (direct-slot slots)
       (dolist (reader (%slot-definition-readers direct-slot))
-        (add-reader-method class reader (%slot-definition-name direct-slot)))
+        (add-reader-method class reader (slot-definition-name direct-slot)))
       (dolist (writer (%slot-definition-writers direct-slot))
-        (add-writer-method class writer (%slot-definition-name direct-slot)))))
+        (add-writer-method class writer (slot-definition-name direct-slot)))))
   (setf (class-direct-default-initargs class) direct-default-initargs)
   (funcall (if (eq (class-of class) +the-standard-class+)
@@ -2161 +2177 @@
 (defun valid-initarg-p (initarg slots)
   (dolist (slot slots nil)
-    (let ((valid-initargs (%slot-definition-initargs slot)))
+    (let ((valid-initargs (slot-definition-initargs slot)))
       (when (memq initarg valid-initargs)
         (return t)))))
@@ -2218 +2234 @@
        :format-arguments (list initarg))))
   (dolist (slot (class-slots (class-of instance)))
-    (let ((slot-name (%slot-definition-name slot)))
+    (let ((slot-name (slot-definition-name slot)))
       (multiple-value-bind (init-key init-value foundp)
-          (get-properties all-keys (%slot-definition-initargs slot))
+          (get-properties all-keys (slot-definition-initargs slot))
         (if foundp
             (setf (std-slot-value instance slot-name) init-value)
             (unless (std-slot-boundp instance slot-name)
-              (let ((initfunction (%slot-definition-initfunction slot)))
+              (let ((initfunction (slot-definition-initfunction slot)))
                 (when (and initfunction (or (eq slot-names t)
                                             (memq slot-name slot-names)))
@@ -2261 +2277 @@
     (dolist (new-slot new-slots)
       (when (instance-slot-p new-slot)
-        (let* ((slot-name (%slot-definition-name new-slot))
-               (old-slot (find slot-name old-slots :key #'%slot-definition-name)))
+        (let* ((slot-name (slot-definition-name new-slot))
+               (old-slot (find slot-name old-slots :key #'slot-definition-name)))
           ;; "The values of slots specified as shared in the class CFROM and as
           ;; local in the class CTO are retained."
@@ -2285 +2301 @@
          (remove-if #'(lambda (slot-name)
                        (slot-exists-p old slot-name))
-                    (mapcar #'%slot-definition-name
+                    (mapcar #'slot-definition-name
                             (class-slots (class-of new))))))
     (check-initargs new added-slots initargs)
@@ -2376 +2392 @@
 ;;; Slot definition accessors
 
-(export '(slot-definition-allocation 
+(mapcar (lambda (sym)
+    (fmakunbound sym) ;;we need to redefine them as GFs
+    (export sym))
+  '(slot-definition-allocation 
     slot-definition-initargs
     slot-definition-initform
@@ -2384 +2403 @@
 (defgeneric slot-definition-allocation (slot-definition)
   (:method ((slot-definition slot-definition))
-    (%slot-definition-allocation slot-definition)))
+    (let ((cl (class-of slot-definition)))
+      (case cl
+  ((+the-slot-definition-class+
+    +the-direct-slot-definition-class+
+    +the-effective-slot-definition-class+)
+   (%slot-definition-allocation slot-definition))
+  (t (slot-value slot-definition 'sys::allocation))))))
 
 (defgeneric slot-definition-initargs (slot-definition)
   (:method ((slot-definition slot-definition))
-    (%slot-definition-initargs slot-definition)))
+    (let ((cl (class-of slot-definition)))
+      (case cl
+  ((+the-slot-definition-class+
+    +the-direct-slot-definition-class+
+    +the-effective-slot-definition-class+)
+   (%slot-definition-initargs slot-definition))
+  (t (slot-value slot-definition 'sys::initargs))))))
 
 (defgeneric slot-definition-initform (slot-definition)
   (:method ((slot-definition slot-definition))
-    (%slot-definition-initform slot-definition)))
+    (let ((cl (class-of slot-definition)))
+      (case cl
+  ((+the-slot-definition-class+
+    +the-direct-slot-definition-class+
+    +the-effective-slot-definition-class+)
+   (%slot-definition-initform slot-definition))
+  (t (slot-value slot-definition 'sys::initform))))))
 
 (defgeneric slot-definition-initfunction (slot-definition)
   (:method ((slot-definition slot-definition))
-    (%slot-definition-initfunction slot-definition)))
+    (let ((cl (class-of slot-definition)))
+      (case cl
+  ((+the-slot-definition-class+
+    +the-direct-slot-definition-class+
+    +the-effective-slot-definition-class+)
+   (%slot-definition-initfunction slot-definition))
+  (t (slot-value slot-definition 'sys::initfunction))))))
 
 (defgeneric slot-definition-name (slot-definition)
   (:method ((slot-definition slot-definition))
-    (%slot-definition-name slot-definition)))
+    (let ((cl (class-of slot-definition)))
+      (case cl
+  ((+the-slot-definition-class+
+    +the-direct-slot-definition-class+
+    +the-effective-slot-definition-class+)
+   (%slot-definition-name slot-definition))
+  (t (slot-value slot-definition 'sys::name))))))
 
 ;;; No %slot-definition-type.