mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-01-16 13:18:05 +01:00
parent 9539b20ba9
commit 2bcb278a30
5 changed files with 79 additions and 76 deletions
Download patch file Download diff file Expand all files Collapse all files

70
module/oop/goops.scm
View file

@ -122,9 +122,8 @@
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
@ -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)))