\f
+static SCM var_slot_ref_using_class = SCM_BOOL_F;
+static SCM var_slot_set_using_class_x = SCM_BOOL_F;
+static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
+static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
+
SCM scm_no_applicable_method = SCM_BOOL_F;
SCM var_get_keyword = SCM_BOOL_F;
void
scm_init_deprecated_goops (void)
{
+ var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
+ var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
+ var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
+ var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
+
scm_no_applicable_method =
scm_variable_ref (scm_c_lookup ("no-applicable-method"));
return scm_make_standard_class (meta, name, dsupers, dslots);
}
+/* Scheme will issue the deprecation warning for these. */
+SCM
+scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
+{
+ return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
+ class, obj, slot_name);
+}
+
+SCM
+scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
+{
+ return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
+ class, obj, slot_name, value);
+}
+
+SCM
+scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
+{
+ return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
+ class, obj, slot_name);
+}
+
+SCM
+scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
+{
+ return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
+ class, obj, slot_name);
+}
+
\f
SCM_DEPRECATED SCM scm_find_method (SCM l);
SCM_DEPRECATED SCM scm_basic_make_class (SCM c, SCM name, SCM dsupers, SCM dslots);
SCM_DEPRECATED SCM scm_get_keyword (SCM kw, SCM initargs, SCM default_value);
+SCM_DEPRECATED SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name);
+SCM_DEPRECATED SCM scm_slot_set_using_class_x (SCM cls, SCM obj, SCM slot_name, SCM value);
+SCM_DEPRECATED SCM scm_slot_bound_using_class_p (SCM cls, SCM obj, SCM slot_name);
+SCM_DEPRECATED SCM scm_slot_exists_using_class_p (SCM cls, SCM obj, SCM slot_name);
\f
static SCM var_method_specializers = SCM_BOOL_F;
static SCM var_method_procedure = SCM_BOOL_F;
-static SCM var_slot_ref_using_class = SCM_BOOL_F;
-static SCM var_slot_set_using_class_x = SCM_BOOL_F;
-static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
-static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
-
static SCM var_slot_ref = SCM_BOOL_F;
static SCM var_slot_set_x = SCM_BOOL_F;
static SCM var_slot_bound_p = SCM_BOOL_F;
\f
-SCM
-scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
-{
- return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
- class, obj, slot_name);
-}
-
-SCM
-scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
-{
- return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
- class, obj, slot_name, value);
-}
-
-SCM
-scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
-{
- return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
- class, obj, slot_name);
-}
-
-SCM
-scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
-{
- return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
- class, obj, slot_name);
-}
-
SCM
scm_slot_ref (SCM obj, SCM slot_name)
{
/* For SCM_SUBCLASSP. */
var_class_precedence_list = scm_c_lookup ("class-precedence-list");
- var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
- var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
- var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
- var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
-
var_slot_ref = scm_c_lookup ("slot-ref");
var_slot_set_x = scm_c_lookup ("slot-set!");
var_slot_bound_p = scm_c_lookup ("slot-bound?");
SCM_API SCM scm_method_generic_function (SCM obj);
SCM_API SCM scm_method_specializers (SCM obj);
SCM_API SCM scm_method_procedure (SCM obj);
-SCM_API SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name);
-SCM_API SCM scm_slot_set_using_class_x (SCM cls, SCM obj, SCM slot_name, SCM value);
-SCM_API SCM scm_slot_bound_using_class_p (SCM cls, SCM obj, SCM slot_name);
-SCM_API SCM scm_slot_exists_using_class_p (SCM cls, SCM obj, SCM slot_name);
SCM_API SCM scm_slot_bound_p (SCM obj, SCM slot_name);
SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name);
SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst);
goops-error
min-fixnum max-fixnum
- instance? slot-ref-using-class
- slot-set-using-class! slot-bound-using-class?
- slot-exists-using-class? slot-ref slot-set! slot-bound?
+ instance?
+ slot-ref slot-set! slot-bound? slot-exists?
class-name class-direct-supers class-direct-subclasses
class-direct-methods class-direct-slots class-precedence-list
class-slots
method-specializers method-formals
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
- slot-exists? make find-method get-keyword)
+ make find-method get-keyword)
#:no-backtrace)
(and (assq slot-name (struct-ref class class-index-getters-n-setters))
#t))
-(define (check-slot-args class obj slot-name)
- (unless (class? class)
- (scm-error 'wrong-type-arg #f "Not a class: ~S"
- (list class) #f))
- (unless (instance? obj)
- (scm-error 'wrong-type-arg #f "Not an instance: ~S"
- (list 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)
- (check-slot-args class obj slot-name)
- (let ((val (get-slot-value-using-name class obj slot-name)))
- (if (unbound? val)
- (slot-unbound class obj slot-name)
- val)))
-
-(define (slot-set-using-class! class obj slot-name value)
- (check-slot-args class obj slot-name)
- (set-slot-value-using-name! class obj slot-name value))
-
-(define (slot-bound-using-class? class obj slot-name)
- (check-slot-args class obj slot-name)
- (not (unbound? (get-slot-value-using-name class obj slot-name))))
-
-(define (slot-exists-using-class? class obj slot-name)
- (check-slot-args class obj slot-name)
- (test-slot-existence class obj slot-name))
-
;;;
;;; Before we go on, some notes about class redefinition. In GOOPS,
;;; classes can be redefined. Redefinition of a class marks the class
(list slot-name) #f))
(test-slot-existence (class-of obj) obj slot-name))
+(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