GOOPS: Deprecate "using-class" procs like slot-ref-using-class

* libguile/deprecated.h:
* libguile/goops.c:
* libguile/goops.h:
* libguile/deprecated.c (scm_slot_ref_using_class):
  (scm_slot_set_using_class_x):
  (scm_slot_bound_using_class_p):
  (scm_slot_exists_using_class_p): Deprecate.

* module/oop/goops.scm (slot-ref-using-class, slot-set-using-class!)
  (slot-bound-using-class?, slot-exists-using-class?): Deprecate.
  Change to check that `class' is indeed the class of `obj', as
  required, and then dispatch to slot-ref et al.

libguile/deprecated.c

@@ -93,6 +93,11 @@ scm_memory_error (const char *subr)
 
 
 
+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;
@@ -130,6 +135,11 @@ SCM *scm_port_class, *scm_smob_class;
 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"));
 
@@ -446,6 +456,35 @@ scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
   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);
+}
+
 
 
 

libguile/deprecated.h

@@ -212,6 +212,10 @@ SCM_DEPRECATED SCM scm_compute_applicable_methods (SCM gf, SCM args, long len, i
 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);
 
 
 

libguile/goops.c

@@ -91,11 +91,6 @@ static SCM var_method_generic_function = SCM_BOOL_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;
@@ -454,34 +449,6 @@ SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
 
 
 
-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)
 {
@@ -977,11 +944,6 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
   /* 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?");

libguile/goops.h

@@ -116,10 +116,6 @@ SCM_API SCM scm_generic_function_methods (SCM obj);
 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);

module/oop/goops.scm

@@ -122,9 +122,8 @@
             goops-error
             min-fixnum max-fixnum
 
-            instance?  slot-ref-using-class
+            instance?
-            slot-set-using-class! slot-bound-using-class?
+            slot-ref slot-set! slot-bound? slot-exists?
-            slot-exists-using-class? slot-ref slot-set! slot-bound?
             class-name class-direct-supers class-direct-subclasses
             class-direct-methods class-direct-slots class-precedence-list
             class-slots
@@ -133,7 +132,7 @@
             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)
 
 
@@ -851,36 +850,6 @@ followed by its associated value.  If @var{l} does not hold a value for
   (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
@@ -927,6 +896,39 @@ followed by its associated value.  If @var{l} does not hold a value for
                (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)))
+