Commit ba8feb0f authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Added standard-instance-access and funcallable-standard-instance-access to...

Added standard-instance-access and funcallable-standard-instance-access to LispWorks, due to popular request.

darcs-hash:4977ab122206c49fbdb06b55f915aaae7c7bf1ec
parent a089746c
......@@ -156,7 +156,7 @@
#:extract-specializer-names
#:finalize-inheritance
#:find-method-combination
#-lispworks #:funcallable-standard-instance-access
#:funcallable-standard-instance-access
#:generic-function-argument-precedence-order
#:generic-function-declarations
#:generic-function-lambda-list
......@@ -191,7 +191,7 @@
#:slot-value-using-class
#:specializer-direct-generic-functions
#:specializer-direct-methods
#-lispworks #:standard-instance-access
#:standard-instance-access
#:update-dependent
#:validate-superclass
#-lispworks4.3 #:writer-method-class))
......@@ -603,6 +603,34 @@
(defun fix-slot-initargs (initargs)
initargs)
;; Provide standard-instance-access and funcallable-standard-instance-access
(declaim (inline standard-instance-access
(setf standard-instance-access)))
(defun standard-instance-access (instance location)
(clos::fast-standard-instance-access instance location))
(defun (setf standard-instance-access) (new-value instance location)
(setf (clos::fast-standard-instance-access instance location) new-value))
(declaim (inline funcallable-instance-access))
(defun funcallable-instance-access (instance location &rest args)
(declare (dynamic-extent args))
(let* ((class (class-of instance))
(slot (find location (class-slots class)
:key #'slot-definition-location)))
(if slot
(apply #'clos::funcallable-instance-access instance (slot-definition-name slot) args)
(error "There is no slot with location ~S for instance ~S." location instance))))
(defun funcallable-standard-instance-access (instance location)
(funcallable-instance-access instance location))
(defun (setf funcallable-standard-instance-access) (new-value instance location)
(funcallable-instance-access instance location new-value))
(eval-when (:compile-toplevel :load-toplevel :execute)
(mp:without-preemption
(pushnew :closer-mop *features*)))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment