150 lines
5 KiB
Scheme
150 lines
5 KiB
Scheme
|
(import
|
||
|
(scheme)
|
||
|
(srfi 1)
|
||
|
(hermes))
|
||
|
|
||
|
(define-syntax make-getter-setter
|
||
|
(syntax-rules ()
|
||
|
((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER)
|
||
|
(make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER PURE-GETTER))
|
||
|
((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER SETABLE-GETTER)
|
||
|
(case-lambda
|
||
|
|
||
|
((self resend getter VALUE)
|
||
|
(self 'delete-slot! getter)
|
||
|
(self 'set-immediate-slot-list!
|
||
|
(alist-cons getter
|
||
|
(list #f TYPE)
|
||
|
(self 'immediate-slot-list)))
|
||
|
(self 'add-message! getter PURE-GETTER (eq? TYPE 'parent)))
|
||
|
|
||
|
((self resend getter setter VALUE)
|
||
|
(self 'delete-slot! getter)
|
||
|
(self 'delete-slot! setter)
|
||
|
(self 'set-immediate-slot-list!
|
||
|
(alist-cons getter
|
||
|
(list setter TYPE)
|
||
|
(self 'immediate-slot-list)))
|
||
|
(self 'add-message! getter SETABLE-GETTER (eq? TYPE 'parent))
|
||
|
(self 'add-message! setter
|
||
|
(lambda (self2 resend new)
|
||
|
(if (eq? self2 self)
|
||
|
(set! VALUE new)
|
||
|
(self2 'MESSAGE getter setter new)))))))))
|
||
|
|
||
|
(define (make-prometheus-root-object)
|
||
|
(let ((o (make-hermes-object)))
|
||
|
(o 'add-message! 'clone root-clone)
|
||
|
(o 'add-message! 'message-not-understood root-message-not-understood)
|
||
|
(o 'add-message! 'ambiguous-message-send root-ambiguous-message-send)
|
||
|
(o 'add-message! 'immediate-slot-list root-immediate-slot-list)
|
||
|
(o 'add-message! 'set-immediate-slot-list! root-set-immediate-slot-list!)
|
||
|
(o 'add-message! 'add-value-slot! root-add-value-slot!)
|
||
|
(o 'add-message! 'add-method-slot! root-add-method-slot!)
|
||
|
(o 'add-message! 'add-parent-slot! root-add-parent-slot!)
|
||
|
(o 'add-message! 'delete-slot! root-delete-slot!)
|
||
|
o))
|
||
|
|
||
|
(define (root-clone self resend)
|
||
|
(let ((child (make-hermes-object)))
|
||
|
(child 'add-message! 'parent
|
||
|
(lambda (self2 resend)
|
||
|
self)
|
||
|
#t)
|
||
|
(child 'add-message! 'immediate-slot-list
|
||
|
(lambda (self2 resend)
|
||
|
'((parent #f parent))))
|
||
|
child))
|
||
|
|
||
|
(define root-add-value-slot!
|
||
|
(make-getter-setter 'add-value-slot! value 'value
|
||
|
(lambda (self resend)
|
||
|
value)))
|
||
|
|
||
|
(define root-add-method-slot!
|
||
|
(make-getter-setter 'add-method-slot! value 'method
|
||
|
value
|
||
|
(lambda (self resend . args)
|
||
|
(apply value self resend args))))
|
||
|
|
||
|
(define root-add-parent-slot!
|
||
|
(make-getter-setter 'add-parent-slot! value 'parent
|
||
|
(lambda (self resend)
|
||
|
value)))
|
||
|
|
||
|
(define (root-delete-slot! self resend getter)
|
||
|
(self 'set-immediate-slot-list!
|
||
|
(let loop ((alis (self 'immediate-slot-list)))
|
||
|
(cond
|
||
|
((null? alis)
|
||
|
'())
|
||
|
((eq? getter (caar alis))
|
||
|
(self 'delete-message! (cadar alis))
|
||
|
(loop (cdr alis)))
|
||
|
(else
|
||
|
(cons (car alis)
|
||
|
(loop (cdr alis)))))))
|
||
|
(self 'delete-message! getter))
|
||
|
|
||
|
(define (root-immediate-slot-list self resend)
|
||
|
'((clone #f #f)
|
||
|
(message-not-understood #f #f)
|
||
|
(ambiguous-message-send #f #f)
|
||
|
(immediate-slot-list set-immediate-slot-list! #f)
|
||
|
(add-value-slot! #f #f)
|
||
|
(add-method-slot! #f #f)
|
||
|
(add-parent-slot! #f #f)
|
||
|
(delete-slot! #f #f)))
|
||
|
|
||
|
(define (root-set-immediate-slot-list! self resend new)
|
||
|
(self 'add-message! 'immediate-slot-list
|
||
|
(lambda (self resend)
|
||
|
new)))
|
||
|
|
||
|
(define (root-message-not-understood self resend message args)
|
||
|
(error "Message not understood" self message args))
|
||
|
|
||
|
(define (root-ambiguous-message-send self resend message args)
|
||
|
(error "Message ambiguous" self message args))
|
||
|
|
||
|
(define *the-root-object* (make-prometheus-root-object))
|
||
|
|
||
|
(define-syntax define-method
|
||
|
(syntax-rules ()
|
||
|
((_ (obj 'message self resend args ...)
|
||
|
body1 body ...)
|
||
|
(obj 'add-method-slot! 'message
|
||
|
(lambda (self resend args ...)
|
||
|
body1 body ...)))))
|
||
|
|
||
|
(define-syntax define-object
|
||
|
(syntax-rules ()
|
||
|
((_ name (creation-parent (parent-name parent-object) ...)
|
||
|
slots ...)
|
||
|
(define name (let ((o (creation-parent 'clone)))
|
||
|
(o 'add-parent-slot! 'parent-name parent-object)
|
||
|
...
|
||
|
(define-object/add-slots! o slots ...)
|
||
|
o)))))
|
||
|
|
||
|
(define-syntax define-object/add-slots!
|
||
|
(syntax-rules ()
|
||
|
((_ o)
|
||
|
(values))
|
||
|
((_ o ((method-name . method-args) body ...)
|
||
|
slots ...)
|
||
|
(begin
|
||
|
(o 'add-method-slot! 'method-name (lambda method-args
|
||
|
body ...))
|
||
|
(define-object/add-slots! o slots ...)))
|
||
|
((_ o (slot-getter slot-setter slot-value)
|
||
|
slots ...)
|
||
|
(begin
|
||
|
(o 'add-value-slot! 'slot-getter 'slot-setter slot-value)
|
||
|
(define-object/add-slots! o slots ...)))
|
||
|
((_ o (slot-getter slot-value)
|
||
|
slots ...)
|
||
|
(begin
|
||
|
(o 'add-value-slot! 'slot-getter slot-value)
|
||
|
(define-object/add-slots! o slots ...)))))
|