mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-13 01:00:21 +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

102
oop/goops/accessors.scm
View file

@ -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))))

36
oop/goops/save.scm
View file

@ -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