mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 21:10:27 +02:00
Code Activity

* tests/goops.test: New tests.

Browse source 
* goops.scm (equal?): Provide default method for `equal?'.
(compute-getters-n-setters): Check for bad init-thunks.

* eq.c (scm_equal_p): Turned into a primitive generic.

* snarf.h (SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1): New
macros.
This commit is contained in:
Mikael Djurfeldt 2003-04-17 17:50:57 +00:00
parent 95a0ecc3c7
commit 071d6b0ecc
8 changed files with 285 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

5
oop/ChangeLog
View file

@ -1,3 +1,8 @@
2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (equal?): Provide default method for `equal?'.
(compute-getters-n-setters): Check for bad init-thunks.
2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (compute-getter-method): For custom getter: Check

17
oop/goops.scm
View file

@ -658,6 +658,11 @@
;;; Methods to compare objects
;;;
(define-method (equal? x y) #f)
;;; These following two methods are for backward compatibility only.
;;; They are not called by the Guile interpreter.
;;;
(define-method (object-eqv? x y) #f)
(define-method (object-equal? x y) (eqv? x y))
@ -1039,8 +1044,14 @@
;;;
(define (compute-getters-n-setters class slots env)
(define (compute-slot-init-function s)
(or (slot-definition-init-thunk s)
(define (compute-slot-init-function name s)
(or (let ((thunk (slot-definition-init-thunk s)))
(and thunk
(if (not (and (closure? thunk)
(thunk? thunk)))
(goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
name class thunk))
thunk))
(let ((init (slot-definition-init-value s)))
(and (not (unbound? init))
(lambda () init)))))
@ -1080,7 +1091,7 @@
;; '() for other slots
(verify-accessors name g-n-s)
(cons name
(cons (compute-slot-init-function s)
(cons (compute-slot-init-function name s)
(if (or (integer? g-n-s)
(zero? size))
g-n-s