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 :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)) ,@(map-in-order
(slots (cdddr exp)) (lambda (slot)
(eat? #f)) (cond (eat?
`(standard-define-class ,name ,supers (set! eat? #f)
,@(map-in-order slot)
(lambda (slot) ((keyword? slot)
(cond (eat? (set! eat? #t)
(set! eat? #f) slot)
slot) ((pair? slot)
((keyword? slot) (if (get-keyword #:accessor (cdr slot) #f)
(set! eat? #t) slot
slot) (let ((name (car slot)))
((pair? slot) `(,name #:accessor ,name ,@(cdr slot)))))
(if (get-keyword #:accessor (cdr slot) #f) (else
slot `(,slot #:accessor ,slot))))
(let ((name (car slot))) slots))))
`(,name #:accessor ,name ,@(cdr slot)))))
(else
`(,slot #:accessor ,slot))))
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)) ,@(map-in-order
(slots (cdddr exp)) (lambda (slot)
(eat? #f)) (cond (eat?
`(standard-define-class ,name ,supers (set! eat? #f)
,@(map-in-order slot)
(lambda (slot) ((keyword? slot)
(cond (eat? (set! eat? #t)
(set! eat? #f) slot)
slot) ((pair? slot)
((keyword? slot) (let ((slot
(set! eat? #t) (if (get-keyword #:accessor (cdr slot) #f)
slot) slot
((pair? slot) (let ((name (car slot)))
(let ((slot `(,name #:accessor ,name ,@(cdr slot))))))
(if (get-keyword #:accessor (cdr slot) #f) (if (get-keyword #:init-keyword (cdr slot) #f)
slot slot
(let ((name (car slot))) (let* ((name (car slot))
`(,name #:accessor ,name ,@(cdr slot)))))) (keyword (symbol->keyword name)))
(if (get-keyword #:init-keyword (cdr slot) #f) `(,name #:init-keyword ,keyword ,@(cdr slot))))))
slot (else
(let* ((name (car slot)) `(,slot #:accessor ,slot
(keyword (symbol->keyword name))) #:init-keyword ,(symbol->keyword slot)))))
`(,name #:init-keyword ,keyword ,@(cdr slot)))))) slots))))
(else
`(,slot #:accessor ,slot
#:init-keyword ,(symbol->keyword slot)))))
slots))))))

36
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 "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
(lambda (exp env) `(let ((o ((@@ (oop goops) %allocate-instance) ,class '())))
"(restore CLASS (SLOT-NAME1 ...) EXP1 ...)" (for-each (lambda (name val)
`(let ((o (,%allocate-instance ,(cadr exp) '()))) (slot-set! o name val))
(for-each (lambda (name val) ',slots
(,slot-set! o name val)) (list ,@exps))
',(caddr exp) o))
(list ,@(cdddr exp)))
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) (begin
`(or (write-component-procedure ,(cadr exp) ,@(cdddr exp)) (display #f ,file)
(begin (add-patcher! ,patcher ,env))))
(display #f ,(cadddr exp))
(add-patcher! ,(caddr exp) env))))))
;;; ;;;
;;; Main engine ;;; Main engine