summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-10-24 11:38:32 +0200
committerAndy Wingo <wingo@pobox.com>2008-10-25 22:58:48 +0200
commitae9ce4b786dd76d85061c5a3ceb3bb96b5ba6115 (patch)
tree3871958d447edde4e9a96ca07b3142d1ea2a93f9
parent20bdc71054e6917442097e18de208ca8db89b5fd (diff)
downloadguile-ae9ce4b786dd76d85061c5a3ceb3bb96b5ba6115.tar.gz
defmacroize (oop goops accessors), (oop goops save)
* oop/goops/accessors.scm (define-class-with-accessors) (define-class-with-accessors-keywords): Turn into defmacros. * oop/goops/save.scm (readable, restore, write-component): Turn into defmacros. Both of these changes are untested, unfortunately.
-rw-r--r--oop/goops/accessors.scm102
-rw-r--r--oop/goops/save.scm36
2 files changed, 62 insertions, 76 deletions
diff --git a/oop/goops/accessors.scm b/oop/goops/accessors.scm
index 1451f58ce..a7baa5c62 100644
--- a/oop/goops/accessors.scm
+++ b/oop/goops/accessors.scm
@@ -23,59 +23,51 @@
:export (define-class-with-accessors
define-class-with-accessors-keywords))
-(define define-class-with-accessors
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp))
- (supers (caddr exp))
- (slots (cdddr exp))
- (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 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 define-class-with-accessors-keywords
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp))
- (supers (caddr exp))
- (slots (cdddr exp))
- (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))))))
+(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))))
diff --git a/oop/goops/save.scm b/oop/goops/save.scm
index e9c8e00eb..4d64da8bb 100644
--- a/oop/goops/save.scm
+++ b/oop/goops/save.scm
@@ -114,10 +114,8 @@
(not readables))
(define readables (make-weak-key-hash-table 61)))
-(define readable
- (procedure->memoizing-macro
- (lambda (exp env)
- `(make-readable ,(cadr exp) ',(copy-tree (cadr exp))))))
+(define-macro (readable exp)
+ `(make-readable ,exp ',(copy-tree exp)))
(define (make-readable obj expr)
(hashq-set! readables obj expr)
@@ -377,16 +375,14 @@
(class-slots class)
(slot-ref class 'getters-n-setters)))
-(define restore
- (procedure->memoizing-macro
- (lambda (exp env)
- "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
- `(let ((o (,%allocate-instance ,(cadr exp) '())))
- (for-each (lambda (name val)
- (,slot-set! o name val))
- ',(caddr exp)
- (list ,@(cdddr exp)))
- o))))
+(define-macro (restore class slots . exps)
+ "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
+ `(let ((o ((@@ (oop goops) %allocate-instance) ,class '())))
+ (for-each (lambda (name val)
+ (slot-set! o name val))
+ ',slots
+ (list ,@exps))
+ o))
(define-method (enumerate! (o <object>) env)
(get-set-for-each (lambda (get set)
@@ -621,13 +617,11 @@
;;; write-component OBJECT PATCHER FILE ENV
;;;
-(define write-component
- (procedure->memoizing-macro
- (lambda (exp env)
- `(or (write-component-procedure ,(cadr exp) ,@(cdddr exp))
- (begin
- (display #f ,(cadddr exp))
- (add-patcher! ,(caddr exp) env))))))
+(define-macro (write-component object patcher file env)
+ `(or (write-component-procedure ,object ,file ,env)
+ (begin
+ (display #f ,file)
+ (add-patcher! ,patcher ,env))))
;;;
;;; Main engine