+
+\f
+
+;;;
+;;; Slot access.
+;;;
+;;; Before we go on, some notes about class redefinition. In GOOPS,
+;;; classes can be redefined. Redefinition of a class marks the class
+;;; as invalid, and instances will be lazily migrated over to the new
+;;; representation as they are accessed. Migration happens when
+;;; `class-of' is called on an instance. For more technical details on
+;;; object redefinition, see struct.h.
+;;;
+;;; In the following interfaces, class-of handles the redefinition
+;;; protocol. I would think though that there is some thread-unsafety
+;;; here though as the { class, object data } pair needs to be accessed
+;;; atomically, not the { class, object } pair.
+;;;
+(define-inlinable (%class-slot-definition class slot-name kt kf)
+ (let lp ((slots (struct-ref class class-index-slots)))
+ (match slots
+ ((slot . slots)
+ (if (eq? (%slot-definition-name slot) slot-name)
+ (kt slot)
+ (lp slots)))
+ (_ (kf)))))
+
+(define (class-slot-definition class slot-name)
+ (unless (class? class)
+ (scm-error 'wrong-type-arg #f "Not a class: ~S" (list class) #f))
+ (%class-slot-definition class slot-name
+ (lambda (slot) slot)
+ (lambda () #f)))
+
+(define (slot-ref obj slot-name)
+ "Return the value from @var{obj}'s slot with the nam var{slot_name}."
+ (let ((class (class-of obj)))
+ (define (slot-value slot)
+ (cond
+ ((%slot-definition-slot-ref slot)
+ => (lambda (slot-ref) (slot-ref obj)))
+ (else
+ (struct-ref obj (%slot-definition-index slot)))))
+ (define (have-slot slot)
+ (let ((val (slot-value slot)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let ((val (slot-missing class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (%class-slot-definition class slot-name have-slot no-slot)))
+
+(define (slot-set! obj slot-name value)
+ "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
+ (let ((class (class-of obj)))
+ (define (have-slot slot)
+ (cond
+ ((%slot-definition-slot-set! slot)
+ => (lambda (slot-set!) (slot-set! obj value)))
+ (else
+ (struct-set! obj (%slot-definition-index slot) value))))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (slot-missing class obj slot-name value))
+
+ (%class-slot-definition class slot-name have-slot no-slot)))
+
+(define (slot-bound? obj slot-name)
+ "Return the value from @var{obj}'s slot with the nam var{slot_name}."
+ (let ((class (class-of obj)))
+ (define (slot-value slot)
+ (cond
+ ((%slot-definition-slot-ref slot)
+ => (lambda (slot-ref) (slot-ref obj)))
+ (else
+ (struct-ref obj (%slot-definition-index slot)))))
+ (define (have-slot slot)
+ (not (unbound? (slot-value slot))))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let ((val (slot-missing class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (%class-slot-definition class slot-name have-slot no-slot)))
+
+(define (slot-exists? obj slot-name)
+ "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
+ (define (have-slot slot) #t)
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ #f)
+ (%class-slot-definition (class-of obj) slot-name have-slot no-slot))
+
+(begin-deprecated
+ (define (check-slot-args class obj slot-name)
+ (unless (eq? class (class-of obj))
+ (scm-error 'wrong-type-arg #f "~S is not the class of ~S"
+ (list class obj) #f))
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f)))
+
+ (define (slot-ref-using-class class obj slot-name)
+ (issue-deprecation-warning "slot-ref-using-class is deprecated. "
+ "Use slot-ref instead.")
+ (check-slot-args class obj slot-name)
+ (slot-ref obj slot-name))
+
+ (define (slot-set-using-class! class obj slot-name value)
+ (issue-deprecation-warning "slot-set-using-class! is deprecated. "
+ "Use slot-set! instead.")
+ (check-slot-args class obj slot-name)
+ (slot-set! obj slot-name value))
+
+ (define (slot-bound-using-class? class obj slot-name)
+ (issue-deprecation-warning "slot-bound-using-class? is deprecated. "
+ "Use slot-bound? instead.")
+ (check-slot-args class obj slot-name)
+ (slot-bound? obj slot-name))
+
+ (define (slot-exists-using-class? class obj slot-name)
+ (issue-deprecation-warning "slot-exists-using-class? is deprecated. "
+ "Use slot-exists? instead.")
+ (check-slot-args class obj slot-name)
+ (slot-exists? obj slot-name)))
+
+
+\f
+
+;;;
+;;; Method accessors.
+;;;
+(define (method-generic-function obj)
+ "Return the generic function for the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'generic-function))
+
+(define (method-specializers obj)
+ "Return specializers of the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'specializers))
+
+(define (method-procedure obj)
+ "Return the procedure of the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'procedure))
+
+
+\f
+
+;;;
+;;; Generic functions!
+;;;