mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 08:40:19 +02:00
Code Activity

* oop/goops.scm (define-generic, define-accessor): Make sure that

Browse source 
define-generic and define-accessor will continue to work when
mmacros are expanded before execution.

* test-suite/tests/goops.test: Added tests for define-generic and
define-accessor.
This commit is contained in:
Dirk Herrmann 2002-07-13 09:44:39 +00:00
parent 9f04540330
commit 33e04d5492
4 changed files with 81 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

6
oop/ChangeLog
View file

@ -1,3 +1,9 @@
2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
* goops.scm (define-generic, define-accessor): Make sure that
define-generic and define-accessor will continue to work when
mmacros are expanded before execution.
2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
* goops.scm (define-class): Make sure that define-class will

29
oop/goops.scm
View file

@ -360,12 +360,13 @@
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" name))
((and (top-level-env? env)
(defined? name env))
`(define ,name
(if (is-a? ,name <generic>)
(make <generic> #:name ',name)
(ensure-generic ,name ',name))))
((top-level-env? env)
`(let* ((var (module-ensure-local-variable!
(current-module) ',name))
(old (and (variable-bound? var) (variable-ref var))))
(if (or (not old) (is-a? old <generic>))
(variable-set! var (make <generic> #:name ',name))
(variable-set! var (ensure-generic old ',name)))))
(else
`(define ,name (make <generic> #:name ',name))))))))
@ -391,13 +392,15 @@
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" name))
((and (top-level-env? env)
(defined? name env))
`(define ,name
(if (and (is-a? ,name <generic-with-setter>)
(is-a? (setter ,name) <generic>))
(make-accessor ',name)
(ensure-accessor ,name ',name))))
((top-level-env? env)
`(let* ((var (module-ensure-local-variable!
(current-module) ',name))
(old (and (variable-bound? var) (variable-ref var))))
(if (or (not old)
(and (is-a? old <generic-with-setter>)
(is-a? (setter old) <generic>)))
(variable-set! var (make-accessor ',name))
(variable-set! var (ensure-accessor old ',name)))))
(else
`(define ,name (make-accessor ',name))))))))