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

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

Browse source 
implicit redefines only happen on top level.

* goops.scm (define-class, define-generic, define-accessor),
goops/stklos.scm (define-class):  Use mmacros instead of macros.
This commit is contained in:
Dirk Herrmann 2002-07-08 20:40:32 +00:00
parent 658b35a01e
commit 9ffa41dbae
3 changed files with 18 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

8
oop/ChangeLog
View file

@ -1,3 +1,11 @@
2002-07-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
* goops.scm (define-generic, define-accessor): Make sure that
implicit redefines only happen on top level.
* goops.scm (define-class, define-generic, define-accessor),
goops/stklos.scm (define-class): Use mmacros instead of macros.
2002-07-07 Dirk Herrmann <D.Herrmann@tu-bs.de> 2002-07-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
* goops/save.scm (restore): Replaced "macro" by mmacro. * goops/save.scm (restore): Replaced "macro" by mmacro.

14
oop/goops.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; installed-scm-file
;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ;;;; Copyright (C) 1998,1999,2000,2001,2002 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by ;;;; it under the terms of the GNU General Public License as published by
@ -224,7 +224,7 @@
(name cadr) (name cadr)
(slots cdddr)) (slots cdddr))
(procedure->macro (procedure->memoizing-macro
(lambda (exp env) (lambda (exp env)
(cond ((not (top-level-env? env)) (cond ((not (top-level-env? env))
(goops-error "define-class: Only allowed at top level")) (goops-error "define-class: Only allowed at top level"))
@ -361,12 +361,13 @@
;;; ;;;
(define define-generic (define define-generic
(procedure->macro (procedure->memoizing-macro
(lambda (exp env) (lambda (exp env)
(let ((name (cadr exp))) (let ((name (cadr exp)))
(cond ((not (symbol? name)) (cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" name)) (goops-error "bad generic function name: ~S" name))
((defined? name env) ((and (top-level-env? env)
(defined? name env))
`(define ,name `(define ,name
(if (is-a? ,name <generic>) (if (is-a? ,name <generic>)
(make <generic> #:name ',name) (make <generic> #:name ',name)
@ -391,12 +392,13 @@
(else (make <generic> #:name name))))) (else (make <generic> #:name name)))))
(define define-accessor (define define-accessor
(procedure->macro (procedure->memoizing-macro
(lambda (exp env) (lambda (exp env)
(let ((name (cadr exp))) (let ((name (cadr exp)))
(cond ((not (symbol? name)) (cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" name)) (goops-error "bad accessor name: ~S" name))
((defined? name env) ((and (top-level-env? env)
(defined? name env))
`(define ,name `(define ,name
(if (and (is-a? ,name <generic-with-setter>) (if (and (is-a? ,name <generic-with-setter>)
(is-a? (setter ,name) <generic>)) (is-a? (setter ,name) <generic>))

4
oop/goops/stklos.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999 Free Software Foundation, Inc. ;;;; Copyright (C) 1999,2002 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by ;;;; it under the terms of the GNU General Public License as published by
@ -81,7 +81,7 @@
(supers caddr) (supers caddr)
(slots cadddr) (slots cadddr)
(rest cddddr)) (rest cddddr))
(procedure->macro (procedure->memoizing-macro
(lambda (exp env) (lambda (exp env)
(standard-define-class-transformer (standard-define-class-transformer
`(define-class ,(name exp) ,(supers exp) ,@(slots exp) `(define-class ,(name exp) ,(supers exp) ,@(slots exp)