mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 00:10:21 +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)

4
test-suite/ChangeLog
View file

@ -1,3 +1,7 @@
2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
* tests/goops.test: Added tests for define-class.
2002-05-07 Marius Vollmer <mvo@zagadka.ping.de>
* tests/numbers.test (/): Expect divison by an inexact zero to

15
test-suite/tests/goops.test
View file

@ -98,3 +98,18 @@
(pass-if "direct superclass"
(equal? (class-direct-supers <class>) (list <object>)))))
(with-test-prefix "defining classes"
(with-test-prefix "define-class"
(pass-if "creating a new binding"
(eval '(define <foo> #f) (current-module))
(eval '(undefine <foo>) (current-module))
(eval '(define-class <foo> ()) (current-module))
(eval '(is-a? <foo> <class>) (current-module)))
(pass-if "overwriting a binding to a non-class"
(eval '(define <foo> #f) (current-module))
(eval '(define-class <foo> ()) (current-module))
(eval '(is-a? <foo> <class>) (current-module)))))