mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

* goops.scm (process-class-pre-define-generic,

Browse source 
process-class-pre-define-accessor, process-define-generic,
process-define-accessor): New functions.
(define-class-pre-definition): Use
process-class-pre-define-generic and
process-class-pre-define-accessor; Make sure not to create a new
local variable if the variable has been imported.
(define-generic): Use process-define-generic.
(define-accessor): Use process-define-accessor.
This commit is contained in:
Mikael Djurfeldt 2003-03-17 13:53:58 +00:00
parent 3742da68b2
commit c31142eefd
2 changed files with 56 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

12
oop/ChangeLog
View file

@ -1,3 +1,15 @@
2003-03-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (process-class-pre-define-generic,
process-class-pre-define-accessor, process-define-generic,
process-define-accessor): New functions.
(define-class-pre-definition): Use
process-class-pre-define-generic and
process-class-pre-define-accessor; Make sure not to create a new
local variable if the variable has been imported.
(define-generic): Use process-define-generic.
(define-accessor): Use process-define-accessor.
2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (merge-generics): Make sure not to merge a gf with

64
oop/goops.scm
View file

@ -61,6 +61,10 @@
make-generic ensure-generic
make-extended-generic
make-accessor ensure-accessor
process-class-pre-define-generic
process-class-pre-define-accessor
process-define-generic
process-define-accessor
make-method add-method!
object-eqv? object-equal?
class-slot-ref class-slot-set! slot-unbound slot-missing
@ -180,15 +184,26 @@
(define (define-class-pre-definition keyword exp env)
(case keyword
((#:getter #:setter)
(if (defined? exp env)
`(define ,exp (ensure-generic ,exp ',exp))
`(define ,exp (make-generic ',exp))))
`(process-class-pre-define-generic ',exp))
((#:accessor)
(if (defined? exp env)
`(define ,exp (ensure-accessor ,exp ',exp))
`(define ,exp (make-accessor ',exp))))
`(process-class-pre-define-accessor ',exp))
(else #f)))
(define (process-class-pre-define-generic name)
(let ((var (module-variable (current-module) name)))
(if (not (and var
(variable-bound? var)
(is-a? (variable-ref var) <generic>)))
(process-define-generic name))))
(define (process-class-pre-define-accessor name)
(let ((var (module-variable (current-module) name)))
(if (not (and var
(variable-bound? var)
(or (is-a? (variable-ref var) <accessor>)
(is-a? (variable-ref var) <extended-generic-with-setter>))))
(process-define-accessor name))))
;;; This code should be implemented in C.
;;;
(define define-class
@ -365,15 +380,20 @@
(cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" 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)))))
`(process-define-generic ',name))
(else
`(define ,name (make <generic> #:name ',name))))))))
(define (process-define-generic name)
(let ((var (module-ensure-local-variable! (current-module) name)))
(if (or (not var)
(not (variable-bound? var))
(is-a? (variable-ref var) <generic>))
;; redefine if NAME isn't defined previously, or is another generic
(variable-set! var (make <generic> #:name name))
;; otherwise try to upgrade the object to a generic
(variable-set! var (ensure-generic (variable-ref var) name)))))
(define define-extended-generic
(procedure->memoizing-macro
(lambda (exp env)
@ -462,17 +482,21 @@
(cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" 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 <accessor>)
(is-a? (setter old) <generic>)))
(variable-set! var (make-accessor ',name))
(variable-set! var (ensure-accessor old ',name)))))
`(process-define-accessor ',name))
(else
`(define ,name (make-accessor ',name))))))))
(define (process-define-accessor name)
(let ((var (module-ensure-local-variable! (current-module) name)))
(if (or (not var)
(not (variable-bound? var))
(is-a? (variable-ref var) <accessor>)
(is-a? (variable-ref var) <extended-generic-with-setter>))
;; redefine if NAME isn't defined previously, or is another accessor
(variable-set! var (make-accessor name))
;; otherwise try to upgrade the object to an accessor
(variable-set! var (ensure-accessor (variable-ref var) name)))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))