(module x-roos mzscheme
(provide c-roos-new
c-roos-add-member
c-roos-new-super
c-roos-add-proxy
c-roos-call-member
c-roos-get-member
c-roos-supers-for-each
c-roos-class-is
c-roos-class
c-roos-is-object
object?
c-roos-set-this
c-roos-invalidate
c-roos-is-valid
c-roos-valid?
c-roos-id
roos-id
)
(define ROOS-ID 0)
(define-syntax %error
(syntax-rules ()
((%error a1 ...)
(error (string-append "x-roos.scm:" (format "~a" a1) ...)))))
(define-struct %ROOS (object-type object-valid
supers proxies
public-members private-members
class-name
this-setter
this
id
scache
cache
))
(define-syntax IS-ROOS-SUPER
(syntax-rules ()
((_ obj)
(eq? (%ROOS-object-type obj) 'super))))
(define-syntax IS-ROOS-OBJECT
(syntax-rules ()
((_ obj)
(%ROOS? obj))))
(define-syntax IS-ROOS-VALID
(syntax-rules ()
((_ obj)
(%ROOS-object-valid obj))))
(define-syntax CHECK-IS-NOT-SUPER
(syntax-rules ()
((_ function object)
(if (IS-ROOS-SUPER object)
(%error function ": cannot act on a !ROOS super object")))))
(define-syntax CHECK-IS-OBJECT
(syntax-rules ()
((_ function object)
(if (not (IS-ROOS-OBJECT object))
(%error function ": expects argument of type !ROOS")))))
(define-syntax CHECK-ROOS-VALID
(syntax-rules ()
((_ function object)
(if (not (IS-ROOS-VALID object))
(%error function ": object has been invalidated")))))
(define-syntax CHECK-IS-CLOSURE
(syntax-rules ()
((_ function var)
(if (not (procedure? var))
(%error function ": expects procedure here")))))
(define-syntax CHECK-IS-PUB-PRIV
(syntax-rules ()
((_ function var)
(if (not (or (eq? var 'public) (eq? var 'private)))
(%error function ": expects 'public or 'private here")))))
(define-syntax CHECK-IS-MEMBER-NAME
(syntax-rules ()
((_ function var)
(if (not (symbol? var))
(%error function ": expects a symbol here")))))
(define-syntax CHECK-IS-SYMBOL
(syntax-rules ()
((_ a1 ...)
(CHECK-IS-MEMBER-NAME a1 ...))))
(define-syntax ROOS-CHECKS-1
(syntax-rules ()
((_ function (var (f1 ...)))
(begin
(f1 function var)
...))))
(define-syntax ROOS-CHECKS
(syntax-rules ()
((_ function checks)
#t)
((_ function checks1 . (r1 ...))
(begin
#t
))))
(define (INVALID-THIS-SETTER . args)
(%error "This setter not applicable"))
(define (c-roos-new _class-name _this-setter _supers)
(set! ROOS-ID (+ ROOS-ID 1)) (make-%ROOS 'this #t
_supers '()
(list) (list)
_class-name
_this-setter
#f
ROOS-ID
(make-hash-table) (make-hash-table)))
(define (c-roos-new-super object)
(ROOS-CHECKS 'c-roos-new-super
(object (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER)))
(let ((super (c-roos-new (%ROOS-class-name object)
INVALID-THIS-SETTER
'())))
(set-%ROOS-object-type! super 'super)
(set-%ROOS-this! super object)
super))
(define (c-roos-supers-for-each object closure)
(ROOS-CHECKS 'c-roos-supers-for-each
(object (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER))
(closure (CHECK-IS-CLOSURE)))
(for-each closure (%ROOS-supers object))
object)
(define (c-roos-add-member object type name closure)
(ROOS-CHECKS 'c-roos-add-member
(object (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER))
(type (CHECK-IS-PUB-PRIV))
(name (CHECK-IS-MEMBER-NAME))
(closure (CHECK-IS-CLOSURE)))
(if (eq? type 'public)
(set-%ROOS-public-members! object (cons (cons name closure) (%ROOS-public-members object)))
(set-%ROOS-private-members! object (cons (cons name closure) (%ROOS-private-members object))))
object)
(define (c-roos-add-proxy object object-to-proxy)
(ROOS-CHECKS 'c-roos-add-proxy
(object (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER))
(object-to-proxy
(CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER)))
(set-%ROOS-proxies! object (cons object-to-proxy (%ROOS-proxies object)))
object)
(define (c-roos-false) #f)
(define (c-roos-find-member object name only-in-supers)
(define (c-roos-find-in-objlist supers name)
(if (null? supers)
#f
(let ((member (c-roos-find-member (car supers) name #f)))
(if (eq? member #f)
(c-roos-find-in-objlist (cdr supers) name)
member))))
(let ((m (if only-in-supers
(hash-table-get (%ROOS-scache object) name c-roos-false)
(hash-table-get (%ROOS-cache object) name c-roos-false))))
(if m
m
(let ((member (if only-in-supers
#f
(let ((pub (assq name (%ROOS-public-members object))))
(if (eq? pub #f)
(let ((priv (assq name (%ROOS-private-members object))))
(if (not (eq? priv #f))
(%error 'c-roos-find-member ":member function " name " is private (object of class " (c-roos-class object) ")")
#f))
pub)))))
(if (eq? member #f)
(let ((member (c-roos-find-in-objlist (%ROOS-supers object) name)))
(if (eq? member #f)
(c-roos-find-in-objlist (%ROOS-proxies object) name)
(begin
(hash-table-put! (if only-in-supers (%ROOS-scache object) (%ROOS-cache object)) name member)
member)))
(begin
(hash-table-put! (if only-in-supers (%ROOS-scache object) (%ROOS-cache object)) name (cdr member))
(cdr member))))
)))
(define (c-roos-call-member object name . args)
(ROOS-CHECKS 'c-roos-call-member
(object (CHECK-IS-OBJECT CHECK-ROOS-VALID))
(name (CHECK-IS-MEMBER-NAME)))
(let ((member (if (IS-ROOS-SUPER object)
(c-roos-find-member (%ROOS-this object) name #t)
(c-roos-find-member object name #f))))
(if (eq? member #f)
(%error 'c-roos-call-member (format ": cannot find member ~a for object of type ~a" name (c-roos-class object)))
(apply member args))))
(define (c-roos-get-member object name)
(ROOS-CHECKS 'c-roos-get-member
(object (CHECK-IS-OBJECT CHECK-ROOS-VALID))
(name (CHECK-IS-MEMBER-NAME)))
(let ((member (if (IS-ROOS-SUPER object)
(c-roos-find-member (%ROOS-this object) name #t)
(c-roos-find-member object name #f))))
(if (eq? member #f)
(%error 'c-roos-call-member ": cannot find member " name " for object of class " (c-roos-class object))
member)))
(define (c-class-is-intern object class-name)
(define (g supers class-name)
(if (null? supers)
#f
(if (c-class-is-intern (car supers) class-name)
#t
(g (cdr supers) class-name))))
(if (eq? (%ROOS-class-name object) class-name)
#t
(g (%ROOS-supers object) class-name)))
(define (c-roos-class-is object class-name)
(ROOS-CHECKS 'c-roos-class-is
(object (CHECK-IS-OBJECT CHECK-ROOS-VALID))
(class-name (CHECK-IS-SYMBOL)))
(c-class-is-intern (if (IS-ROOS-SUPER object)
(%ROOS-this object)
object)
class-name))
(define (c-roos-is-object obj) (IS-ROOS-OBJECT obj))
(define (object? obj) (IS-ROOS-OBJECT obj))
(define (c-roos-is-valid object)
(ROOS-CHECKS 'c-roos-is-valid
(object (CHECK-IS-OBJECT)))
(IS-ROOS-VALID (if (IS-ROOS-SUPER object)
(%ROOS-this object)
object)))
(define c-roos-valid? c-roos-is-valid)
(define (c-roos-invalidate object)
(ROOS-CHECKS 'c-roos-invalidate
(object (CHECK-IS-OBJECT CHECK-ROOS-VALID)))
(set-%ROOS-supers! object '())
(set-%ROOS-proxies! object '())
(set-%ROOS-this-setter! object #f)
(set-%ROOS-public-members! object #f)
(set-%ROOS-private-members! object #f)
(set-%ROOS-object-valid! object #f)
(set-%ROOS-scache! object #f)
(set-%ROOS-cache! object #f))
(define (c-roos-class object)
(ROOS-CHECKS 'c-roos-class
(object (CHECK-IS-OBJECT)))
(if (IS-ROOS-SUPER object)
(set! object (%ROOS-this object)))
(ROOS-CHECKS 'c-roos-class
(object (CHECK-ROOS-VALID)))
(let ((super-name-list (map c-roos-class (%ROOS-supers object))))
(list (%ROOS-class-name object) super-name-list)))
(define (c-roos-set-this object this)
(define (g supers)
(if (null? supers)
object
(begin
(c-roos-set-this (car supers) this)
(g (cdr supers)))))
(ROOS-CHECKS 'c-roos-set-this
(object (CHECK-IS-OBJECT CHECK-IS-NOT-SUPER CHECK-ROOS-VALID))
(this (CHECK-IS-OBJECT CHECK-IS-NOT-SUPER CHECK-ROOS-VALID)))
((%ROOS-this-setter object) this)
(g (%ROOS-supers object)))
(define (roos-id object)
(%ROOS-id object))
(define c-roos-id roos-id)
)