mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30:34 +02:00
Code Activity

defmacroize (oop goops accessors), (oop goops save)

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2008-10-24 11:38:32 +02:00
parent 20bdc71054
commit ae9ce4b786
2 changed files with 62 additions and 76 deletions
Download patch file Download diff file Expand all files Collapse all files

28
oop/goops/accessors.scm
View file

@ -23,14 +23,10 @@
:export (define-class-with-accessors :export (define-class-with-accessors
define-class-with-accessors-keywords)) define-class-with-accessors-keywords))
(define define-class-with-accessors (define-macro (define-class-with-accessors name supers . slots)
(procedure->memoizing-macro (let ((eat? #f))
(lambda (exp env) `(standard-define-class
(let ((name (cadr exp)) ,name ,supers
(supers (caddr exp))
(slots (cdddr exp))
(eat? #f))
`(standard-define-class ,name ,supers
,@(map-in-order ,@(map-in-order
(lambda (slot) (lambda (slot)
(cond (eat? (cond (eat?
@ -46,16 +42,12 @@
`(,name #:accessor ,name ,@(cdr slot))))) `(,name #:accessor ,name ,@(cdr slot)))))
(else (else
`(,slot #:accessor ,slot)))) `(,slot #:accessor ,slot))))
slots)))))) slots))))
(define define-class-with-accessors-keywords (define-macro (define-class-with-accessors-keywords name supers . slots)
(procedure->memoizing-macro (let ((eat? #f))
(lambda (exp env) `(standard-define-class
(let ((name (cadr exp)) ,name ,supers
(supers (caddr exp))
(slots (cdddr exp))
(eat? #f))
`(standard-define-class ,name ,supers
,@(map-in-order ,@(map-in-order
(lambda (slot) (lambda (slot)
(cond (eat? (cond (eat?
@ -78,4 +70,4 @@
(else (else
`(,slot #:accessor ,slot `(,slot #:accessor ,slot
#:init-keyword ,(symbol->keyword slot))))) #:init-keyword ,(symbol->keyword slot)))))
slots)))))) slots))))

30
oop/goops/save.scm
View file

@ -114,10 +114,8 @@
(not readables)) (not readables))
(define readables (make-weak-key-hash-table 61))) (define readables (make-weak-key-hash-table 61)))
(define readable (define-macro (readable exp)
(procedure->memoizing-macro `(make-readable ,exp ',(copy-tree exp)))
(lambda (exp env)
`(make-readable ,(cadr exp) ',(copy-tree (cadr exp))))))
(define (make-readable obj expr) (define (make-readable obj expr)
(hashq-set! readables obj expr) (hashq-set! readables obj expr)
@ -377,16 +375,14 @@
(class-slots class) (class-slots class)
(slot-ref class 'getters-n-setters))) (slot-ref class 'getters-n-setters)))
(define restore (define-macro (restore class slots . exps)
(procedure->memoizing-macro
(lambda (exp env)
"(restore CLASS (SLOT-NAME1 ...) EXP1 ...)" "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
`(let ((o (,%allocate-instance ,(cadr exp) '()))) `(let ((o ((@@ (oop goops) %allocate-instance) ,class '())))
(for-each (lambda (name val) (for-each (lambda (name val)
(,slot-set! o name val)) (slot-set! o name val))
',(caddr exp) ',slots
(list ,@(cdddr exp))) (list ,@exps))
o)))) o))
(define-method (enumerate! (o <object>) env) (define-method (enumerate! (o <object>) env)
(get-set-for-each (lambda (get set) (get-set-for-each (lambda (get set)
@ -621,13 +617,11 @@
;;; write-component OBJECT PATCHER FILE ENV ;;; write-component OBJECT PATCHER FILE ENV
;;; ;;;
(define write-component (define-macro (write-component object patcher file env)
(procedure->memoizing-macro `(or (write-component-procedure ,object ,file ,env)
(lambda (exp env)
`(or (write-component-procedure ,(cadr exp) ,@(cdddr exp))
(begin (begin
(display #f ,(cadddr exp)) (display #f ,file)
(add-patcher! ,(caddr exp) env)))))) (add-patcher! ,patcher ,env))))
;;; ;;;
;;; Main engine ;;; Main engine