Changeset 110

Timestamp:

Dec 12, 2003, 1:10:44 PM (21 years ago)

Author:

Gary Byers

Message:

New slot-value scheme. No more reader/writer dcode.

File:

• trunk/ccl/level-1/l1-dcode.lisp (modified) (1 diff)

trunk/ccl/level-1/l1-dcode.lisp

@@ -1818 +1818 @@
 
 
-
-
-
-(defun %%reader-dcode-no-lexpr (dt arg)
-  (locally (declare (optimize (speed 3)(safety 0)))
-    (let* ((gf (%gf-dispatch-table-gf dt))
-           (instance (if (%standard-instance-p arg) arg (%maybe-gf-instance arg))))
-      (unless instance
-        (let ((args-list (cons arg nil)))
-          (declare (dynamic-extent args-list))
-          (reader-trap-no-method gf args-list)))
-      (let* ((wrapper (instance.class-wrapper instance)))
-        (when (eql 0 (%wrapper-hash-index wrapper))
-          (update-obsolete-instance arg)
-          (setq wrapper (instance.class-wrapper instance))
-          (setq dt (%gf-dispatch-table gf))) ; may have changed
-        (let* ((mask (%gf-dispatch-table-mask dt))
-               (index (%ilogand mask (%wrapper-hash-index wrapper)))
-               table-wrapper flag)
-          (declare (fixnum index mask))
-          ;;(print (list 'first-index index wrapper))
-          (setq index (+ index index)) ; +2 ??
-          (loop
-            (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper)
-              (let* ((the-pos (%gf-dispatch-table-ref dt (the fixnum (1+ index)))))
-                (if (fixnump the-pos)
-                  (locally (declare (fixnum the-pos))
-                    (let* ((the-val (%svref (instance.slots instance) (the fixnum (+ the-pos 1)))))
-                      (if (eq the-val (%slot-unbound-marker))
-                        (return (slot-unbound 
-                                 (%wrapper-class wrapper) 
-                                 arg 
-                                 (%svref (%wrapper-instance-slots wrapper) the-pos)))
-                        (return the-val))))
-                  (let ((the-val (cdr the-pos)))
-                    (if (eq the-val (%slot-unbound-marker))
-                      (return (slot-unbound (%wrapper-class wrapper) arg (car the-pos)))
-                      (return the-val)))))
-              ; shit after here re class slots etc., forwarded instance
-              (progn
-                (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
-                  (if (or (neq table-wrapper (%unbound-marker-8))
-                          (eq 0 flag))
-                    (without-interrupts
-                     (return
-                      (let ((args-list (cons arg nil)))
-                        (declare (dynamic-extent args-list))
-                        (reader-trap-2 gf wrapper arg args-list))))
-                    (setq flag 0 index -2)))
-                (setq index (+ 2 index))))))))))
-
-(defun %%writer-dcode-no-lexpr (dt arg0 arg)
-  (locally (declare (optimize (speed 3)(safety 0)))
-    (let* ((gf (%gf-dispatch-table-gf dt))
-           (instance (if (%standard-instance-p arg) arg (%maybe-gf-instance arg))))
-      (unless instance
-        (let* ((tail (cons arg nil))
-               (args-list (cons arg0 tail)))
-          (declare (dynamic-extent args-list tail))
-          (reader-trap-no-method gf args-list)))
-      (let* ((wrapper (instance.class-wrapper instance)))
-        (when (eql 0 (%wrapper-hash-index wrapper))
-          (update-obsolete-instance arg)
-          (setq wrapper (instance.class-wrapper instance))
-          (setq dt (%gf-dispatch-table gf))) ; may have changed
-        (let* ((mask (%gf-dispatch-table-mask dt))
-               (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper))))
-               table-wrapper flag)
-          (declare (fixnum index mask))
-          (loop 
-            (if (neq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper)
-              (progn
-                (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
-                  (if (or (neq table-wrapper (%unbound-marker-8))
-                          (eql 0 flag))
-                    (without-interrupts
-                     (return
-                      (let* ((tail (cons arg nil))
-                             (args-list (cons arg0 tail)))
-                        (declare (dynamic-extent args-list tail))
-                        (reader-trap-2 gf wrapper arg args-list))))
-                    (setq flag 0 index -2)))
-                (setq index (+ 2 index)))
-              (let* ((the-pos (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
-                     (the-val arg0))
-                (if (fixnump the-pos)
-                  (locally (declare (fixnum the-pos))
-                    (return (setf (%svref (instance.slots instance) (the fixnum (+ the-pos 1)))
-                                  the-val)))
-                  (return (setf (cdr the-pos) the-val)))))))))))
-
-(defun reader-trap-no-method (gf args)
-  (if (listp args)
-    (apply #'no-applicable-method gf args)
-    (apply #'no-applicable-method gf (collect-lexpr-args args 0))))
-    
-
-(defun reader-trap-2 (gf wrapper instance args)
-  ;(declare (dynamic-extent args))
-  (let ((method (and wrapper (car (compute-applicable-methods gf args)))))
-    (if (not method)
-      (apply #'no-applicable-method gf args)
-      (let ((slots (%wrapper-instance-slots wrapper))
-            (slot-name (method-slot-name method)))
-        (when (eql 0 slots)
-          (error "Obsolete instance in reader-trap-2"))
-        (let ((idx (or (%vector-member slot-name slots)
-                       (let* ((slotd (find-slotd
-                                      slot-name
-                                      (class-slots (%wrapper-class wrapper)))))
-                         (if slotd (%slot-definition-location slotd))))))
-          (unless idx
-            (error "~s has no slot named ~s" instance slot-name))
-          (let ((table (%gf-dispatch-table gf)))
-            (multiple-value-bind (index obsolete-wrappers-p)
-                                 (find-gf-dispatch-table-index table wrapper)
-              (if index
-                (setf (%gf-dispatch-table-ref table index) wrapper
-                      (%gf-dispatch-table-ref table (%i+ index 1)) idx)
-                (grow-gf-dispatch-table gf wrapper idx obsolete-wrappers-p))))
-          (apply (%method.function method) args))))))
-
-
 ; Support CALL-METHOD in DEFINE-METHOD-COMBINATION
 (defun %%call-method* (method next-methods args)