12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273 |
- (define-module (oop goops accessors)
- :use-module (oop goops)
- :re-export (standard-define-class)
- :export (define-class-with-accessors
- define-class-with-accessors-keywords))
- (define-macro (define-class-with-accessors name supers . slots)
- (let ((eat? #f))
- `(standard-define-class
- ,name ,supers
- ,@(map-in-order
- (lambda (slot)
- (cond (eat?
- (set! eat? #f)
- slot)
- ((keyword? slot)
- (set! eat? #t)
- slot)
- ((pair? slot)
- (if (get-keyword #:accessor (cdr slot) #f)
- slot
- (let ((name (car slot)))
- `(,name #:accessor ,name ,@(cdr slot)))))
- (else
- `(,slot #:accessor ,slot))))
- slots))))
- (define-macro (define-class-with-accessors-keywords name supers . slots)
- (let ((eat? #f))
- `(standard-define-class
- ,name ,supers
- ,@(map-in-order
- (lambda (slot)
- (cond (eat?
- (set! eat? #f)
- slot)
- ((keyword? slot)
- (set! eat? #t)
- slot)
- ((pair? slot)
- (let ((slot
- (if (get-keyword #:accessor (cdr slot) #f)
- slot
- (let ((name (car slot)))
- `(,name #:accessor ,name ,@(cdr slot))))))
- (if (get-keyword #:init-keyword (cdr slot) #f)
- slot
- (let* ((name (car slot))
- (keyword (symbol->keyword name)))
- `(,name #:init-keyword ,keyword ,@(cdr slot))))))
- (else
- `(,slot #:accessor ,slot
- #:init-keyword ,(symbol->keyword slot)))))
- slots))))
|