(import (scheme) (scheme case-lambda) (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) (void)) ((_ 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 ...)))))