X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=60d3cec6c796fb2da5c9a043833091252abbd42f;hb=f4820c2cd6eb6af8f21312e2e2ca19af42de4be6;hp=e23b889dbd4d87fd5aa0859322826f4bf85cabbd;hpb=7a7a5268d45a213d425228e87c9ecc9f79bd7858;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index e23b889..60d3cec 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -30,25 +30,26 @@ ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING ;; behaviour for non-slot-objects too? (reader - (values '(object) '(slot-object) 'standard-reader-method + (values '(object) '(slot-object) 'global-reader-method (make-std-reader-method-function 'slot-object slot-name) "automatically-generated reader method")) (writer - (values '(new-value object) '(t slot-object) 'standard-writer-method + (values '(new-value object) '(t slot-object) 'global-writer-method (make-std-writer-method-function 'slot-object slot-name) "automatically-generated writer method")) (boundp - (values '(object) '(slot-object) 'standard-boundp-method + (values '(object) '(slot-object) 'global-boundp-method (make-std-boundp-method-function 'slot-object slot-name) "automatically-generated boundp method"))) (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list))) - (add-method gf (make-a-method method-class () lambda-list specializers - initargs doc slot-name))))) + (add-method gf (make-a-method method-class + () lambda-list specializers + initargs doc :slot-name slot-name))))) t) (defmacro accessor-slot-value (object slot-name) (aver (constantp slot-name)) - (let* ((slot-name (eval slot-name)) + (let* ((slot-name (constant-form-value slot-name)) (reader-name (slot-reader-name slot-name))) `(let ((.ignore. (load-time-value (ensure-accessor 'reader ',reader-name ',slot-name)))) @@ -60,7 +61,7 @@ (aver (constantp slot-name)) (setq object (macroexpand object env)) (setq slot-name (macroexpand slot-name env)) - (let* ((slot-name (eval slot-name)) + (let* ((slot-name (constant-form-value slot-name)) (bindings (unless (or (constantp new-value) (atom new-value)) (let ((object-var (gensym))) (prog1 `((,object-var ,object)) @@ -80,7 +81,7 @@ (defmacro accessor-slot-boundp (object slot-name) (aver (constantp slot-name)) - (let* ((slot-name (eval slot-name)) + (let* ((slot-name (constant-form-value slot-name)) (boundp-name (slot-boundp-name slot-name))) `(let ((.ignore. (load-time-value (ensure-accessor 'boundp ',boundp-name ',slot-name)))) @@ -402,86 +403,45 @@ (boundp (lambda (instance) (emf-funcall sdfun class instance slotd)))) `(,name ,(class-name class) ,(slot-definition-name slotd))))) - -(defun make-internal-reader-method-function (class-name slot-name) - (list* :method-spec `(internal-reader-method ,class-name ,slot-name) - (make-method-function - (lambda (instance) - (let ((wrapper (get-instance-wrapper-or-nil instance))) - (if wrapper - (let* ((class (wrapper-class* wrapper)) - (index (or (instance-slot-index wrapper slot-name) - (assq slot-name - (wrapper-class-slots wrapper))))) - (typecase index - (fixnum - (let ((value (clos-slots-ref (get-slots instance) - index))) - (if (eq value +slot-unbound+) - (values (slot-unbound (class-of instance) - instance - slot-name)) - value))) - (cons - (let ((value (cdr index))) - (if (eq value +slot-unbound+) - (values (slot-unbound (class-of instance) - instance - slot-name)) - value))) - (t - (error "~@" - class slot-name)))) - (slot-value instance slot-name))))))) (defun make-std-reader-method-function (class-name slot-name) - (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree + (let* ((initargs (copy-tree (make-method-function (lambda (instance) (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) + (bug "Please report this") (instance) (instance-slots)) (instance-read-internal - .pv. instance-slots 1 + .pv. instance-slots 0 (slot-value instance slot-name)))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) + (setf (getf (getf initargs 'plist) :slot-name-lists) (list (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) - (list* :method-spec `(reader-method ,class-name ,slot-name) - initargs))) + initargs)) (defun make-std-writer-method-function (class-name slot-name) - (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree + (let* ((initargs (copy-tree (make-method-function (lambda (nv instance) (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) + (bug "Please report this") (instance) (instance-slots)) (instance-write-internal - .pv. instance-slots 1 nv + .pv. instance-slots 0 nv (setf (slot-value instance slot-name) nv)))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) + (setf (getf (getf initargs 'plist) :slot-name-lists) (list nil (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) - (list* :method-spec `(writer-method ,class-name ,slot-name) - initargs))) + initargs)) (defun make-std-boundp-method-function (class-name slot-name) - (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree + (let* ((initargs (copy-tree (make-method-function (lambda (instance) (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) + (bug "Please report this") (instance) (instance-slots)) (instance-boundp-internal - .pv. instance-slots 1 + .pv. instance-slots 0 (slot-boundp instance slot-name)))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) + (setf (getf (getf initargs 'plist) :slot-name-lists) (list (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) - (list* :method-spec `(boundp-method ,class-name ,slot-name) - initargs))) + initargs))