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

* oop/goops.scm (define-class): Make sure that define-class will

Browse source 
continue to work when mmacros are expanded before execution.

* test-suite/tests/goops.test: Added tests for define-class.
This commit is contained in:
Dirk Herrmann 2002-07-13 08:18:35 +00:00
parent 4f6f9ae3d3
commit 9f04540330
4 changed files with 35 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

5
oop/ChangeLog
View file

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

28
oop/goops.scm
View file

@ -235,23 +235,17 @@
`(begin
;; define accessors
,@(pre-definitions (slots exp) env)
,(if (defined? name env)
;; redefine an old class
`(define ,name
(let ((old ,name)
(new (class ,@(cddr exp) #:name ',name)))
(if (and (is-a? old <class>)
;; Prevent redefinition of non-objects
(memq <object>
(class-precedence-list old)))
(class-redefinition old new)
new)))
;; define a new class
`(define ,name
(class ,@(cddr exp) #:name ',name)))))))))))
;; update the current-module
(let* ((class (class ,@(cddr exp) #:name ',name))
(var (module-ensure-local-variable!
(current-module) ',name))
(old (and (variable-bound? var)
(variable-ref var))))
(if (and old
(is-a? old <class>)
(memq <object> (class-precedence-list old)))
(variable-set! var (class-redefinition old class))
(variable-set! var class)))))))))))
(define standard-define-class define-class)