diff options
author | Andy Wingo <wingo@pobox.com> | 2008-10-24 11:38:32 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-10-25 22:58:48 +0200 |
commit | ae9ce4b786dd76d85061c5a3ceb3bb96b5ba6115 (patch) | |
tree | 3871958d447edde4e9a96ca07b3142d1ea2a93f9 | |
parent | 20bdc71054e6917442097e18de208ca8db89b5fd (diff) | |
download | guile-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.scm | 102 | ||||
-rw-r--r-- | oop/goops/save.scm | 36 |
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 |