mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-15 18:20:42 +02:00
Code Activity

define-generic, define-accessor are defmacros too

Browse source 
* oop/goops.scm (define-generic, define-accessor): Define as defmacros. I
  find their semantics to be a bit odd, though -- but the test case
  checks for this behavior, so we'll follow the test cases.
This commit is contained in:
Andy Wingo 2008-10-23 14:24:57 +02:00
parent d31c5d197d
commit 1d83f47eb0
1 changed files with 33 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

81
oop/goops.scm
View file

@ -37,10 +37,6 @@
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
@ -283,42 +279,24 @@
;;; {Generic functions and accessors} ;;; {Generic functions and accessors}
;;; ;;;
(define define-generic ;; Apparently the desired semantics are that we extend previous
(procedure->memoizing-macro ;; procedural definitions, but that if `name' was already a generic, we
(lambda (exp env) ;; overwrite its definition.
(let ((name (cadr exp))) (define-macro (define-generic name)
(cond ((not (symbol? name)) (if (not (symbol? name))
(goops-error "bad generic function name: ~S" name)) (goops-error "bad generic function name: ~S" name))
((top-level-env? env) `(define ,name
`(process-define-generic ',name)) (if (and (defined? ',name) (is-a? ,name <generic>))
(else (make <generic> #:name ',name)
`(define ,name (make <generic> #:name ',name)))))))) (ensure-generic (if (defined? ',name) ,name #f) ',name))))
(define (process-define-generic name) (define-macro (define-extended-generic name val)
(let ((var (module-ensure-local-variable! (current-module) name))) (if (not (symbol? 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)
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" name)) (goops-error "bad generic function name: ~S" name))
((null? (cddr exp)) `(define ,name (make-extended-generic ,val ',name)))
(goops-error "missing expression"))
(else (define-macro (define-extended-generics names . args)
`(define ,name (make-extended-generic ,(caddr exp) ',name)))))))) (let ((prefixes (get-keyword #:prefix args #f)))
(define define-extended-generics
(procedure->memoizing-macro
(lambda (exp env)
(let ((names (cadr exp))
(prefixes (get-keyword #:prefix (cddr exp) #f)))
(if prefixes (if prefixes
`(begin `(begin
,@(map (lambda (name) ,@(map (lambda (name)
@ -327,7 +305,7 @@
(symbol-append prefix name)) (symbol-append prefix name))
prefixes)))) prefixes))))
names)) names))
(goops-error "no prefixes supplied")))))) (goops-error "no prefixes supplied"))))
(define (make-generic . name) (define (make-generic . name)
(let ((name (and (pair? name) (car name)))) (let ((name (and (pair? name) (car name))))
@ -385,27 +363,14 @@
(make <generic> #:name name #:default old-definition)) (make <generic> #:name name #:default old-definition))
(else (make <generic> #:name name))))) (else (make <generic> #:name name)))))
(define define-accessor ;; same semantics as <generic>
(procedure->memoizing-macro (define-macro (define-accessor name)
(lambda (exp env) (if (not (symbol? name))
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" name)) (goops-error "bad accessor name: ~S" name))
((top-level-env? env) `(define ,name
`(process-define-accessor ',name)) (if (and (defined? ',name) (is-a? ,name <accessor>))
(else (make <accessor> #:name ',name)
`(define ,name (make-accessor ',name)))))))) (ensure-accessor (if (defined? ',name) ,name #f) ',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))))