mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
* 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.
This commit is contained in:
parent
3742da68b2
commit
c31142eefd
2 changed files with 56 additions and 20 deletions
|
@ -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>
|
2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||||
|
|
||||||
* goops.scm (merge-generics): Make sure not to merge a gf with
|
* goops.scm (merge-generics): Make sure not to merge a gf with
|
||||||
|
|
|
@ -61,6 +61,10 @@
|
||||||
make-generic ensure-generic
|
make-generic ensure-generic
|
||||||
make-extended-generic
|
make-extended-generic
|
||||||
make-accessor ensure-accessor
|
make-accessor ensure-accessor
|
||||||
|
process-class-pre-define-generic
|
||||||
|
process-class-pre-define-accessor
|
||||||
|
process-define-generic
|
||||||
|
process-define-accessor
|
||||||
make-method add-method!
|
make-method add-method!
|
||||||
object-eqv? object-equal?
|
object-eqv? object-equal?
|
||||||
class-slot-ref class-slot-set! slot-unbound slot-missing
|
class-slot-ref class-slot-set! slot-unbound slot-missing
|
||||||
|
@ -180,15 +184,26 @@
|
||||||
(define (define-class-pre-definition keyword exp env)
|
(define (define-class-pre-definition keyword exp env)
|
||||||
(case keyword
|
(case keyword
|
||||||
((#:getter #:setter)
|
((#:getter #:setter)
|
||||||
(if (defined? exp env)
|
`(process-class-pre-define-generic ',exp))
|
||||||
`(define ,exp (ensure-generic ,exp ',exp))
|
|
||||||
`(define ,exp (make-generic ',exp))))
|
|
||||||
((#:accessor)
|
((#:accessor)
|
||||||
(if (defined? exp env)
|
`(process-class-pre-define-accessor ',exp))
|
||||||
`(define ,exp (ensure-accessor ,exp ',exp))
|
|
||||||
`(define ,exp (make-accessor ',exp))))
|
|
||||||
(else #f)))
|
(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.
|
;;; This code should be implemented in C.
|
||||||
;;;
|
;;;
|
||||||
(define define-class
|
(define define-class
|
||||||
|
@ -365,15 +380,20 @@
|
||||||
(cond ((not (symbol? name))
|
(cond ((not (symbol? name))
|
||||||
(goops-error "bad generic function name: ~S" name))
|
(goops-error "bad generic function name: ~S" name))
|
||||||
((top-level-env? env)
|
((top-level-env? env)
|
||||||
`(let* ((var (module-ensure-local-variable!
|
`(process-define-generic ',name))
|
||||||
(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
|
(else
|
||||||
`(define ,name (make <generic> #:name ',name))))))))
|
`(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
|
(define define-extended-generic
|
||||||
(procedure->memoizing-macro
|
(procedure->memoizing-macro
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
|
@ -462,17 +482,21 @@
|
||||||
(cond ((not (symbol? name))
|
(cond ((not (symbol? name))
|
||||||
(goops-error "bad accessor name: ~S" name))
|
(goops-error "bad accessor name: ~S" name))
|
||||||
((top-level-env? env)
|
((top-level-env? env)
|
||||||
`(let* ((var (module-ensure-local-variable!
|
`(process-define-accessor ',name))
|
||||||
(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)))))
|
|
||||||
(else
|
(else
|
||||||
`(define ,name (make-accessor ',name))))))))
|
`(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)
|
(define (make-setter-name name)
|
||||||
(string->symbol (string-append "setter:" (symbol->string name))))
|
(string->symbol (string-append "setter:" (symbol->string name))))
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue