147 lines
4.0 KiB
Racket
147 lines
4.0 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/syntax)
|
|
(provide roos ->)
|
|
|
|
(define-syntax ->
|
|
(syntax-rules ()
|
|
((_ obj method)
|
|
(obj 'method))
|
|
((_ obj method arg ...)
|
|
(obj 'method arg ...))))
|
|
|
|
(define-syntax roos-def
|
|
(syntax-rules ()
|
|
((_ h ((a) expr ...))
|
|
(begin
|
|
(define (a) expr ...)
|
|
(hash-set! h 'a a)))
|
|
((_ h ((a b) expr ...))
|
|
(begin
|
|
(define (a b) expr ...)
|
|
(hash-set! h 'a a)))
|
|
((_ h ((a b ...) expr ...))
|
|
(begin
|
|
(define (a b ...) expr ...)
|
|
(hash-set! h 'a a)))
|
|
((_ h ((a . f) expr ...))
|
|
(begin
|
|
(define (a . f) expr ...)
|
|
(hash-set! h 'a a)))
|
|
((_ h ((a b . f) expr ...))
|
|
(begin
|
|
(define (a b . f) expr ...)
|
|
(hash-set! h 'a a)))
|
|
((_ h ((a b ... . f) expr ...))
|
|
(begin
|
|
(define (a b ... . f) expr ...)
|
|
(hash-set! h 'a a)))
|
|
((_ h (a b))
|
|
(begin
|
|
(define a b)
|
|
(hash-set! h 'a (lambda () a))
|
|
(hash-set! h (string->symbol (format "~a!" 'a)) (lambda (v) (set! a v)))))
|
|
))
|
|
|
|
(define-syntax roos-supers
|
|
(syntax-rules ()
|
|
((_ self supers ())
|
|
(hash-set! self '@supers@ (list)))
|
|
((_ self supers ((a)))
|
|
(hash-set! self '@supers@ (list (a))))
|
|
((_ self supers ((a b ...)))
|
|
(hash-set! self '@supers@ (list (a b ...))))
|
|
((_ self supers (x y ...))
|
|
(hash-set! self '@supers@ (list x y ...)))
|
|
))
|
|
|
|
(define-syntax roos-err
|
|
(syntax-rules ()
|
|
((_ name msg)
|
|
(error (format "~a: ~a" name msg)))))
|
|
|
|
(define (roos-call hash supers f-name args)
|
|
(let ((f (hash-ref hash f-name '@roos-undefined@)))
|
|
(if (eq? f '@roos-undefined@)
|
|
(if (null? supers)
|
|
(roos-err f-name "Method or Attribute not defined")
|
|
(roos-call ((car supers) '@roos@) (cdr supers) f-name args))
|
|
(apply f args))))
|
|
|
|
(define-syntax roos-supers-def
|
|
(syntax-rules ()
|
|
((_ supers @roos@ @super-starter@ invokes)
|
|
(define supers (lambda (f-name . args)
|
|
(roos-call @super-starter@ (hash-ref @roos@ '@supers@) f-name args))))))
|
|
|
|
(define-syntax roos-body
|
|
(syntax-rules ()
|
|
((_ self (supers . super-invokes) b ...)
|
|
(begin
|
|
(define @roos@ (make-hash))
|
|
(define @super-starter@ (make-hash))
|
|
(define self (lambda (f-name . args)
|
|
(roos-call @roos@ (hash-ref @roos@ '@supers@) f-name args)))
|
|
(roos-supers-def supers @roos@ @super-starter@ super-invokes)
|
|
(hash-set! @roos@ '@roos@ (lambda () @roos@))
|
|
(hash-set! @roos@ '@set-self@ (lambda (derived-self)
|
|
(set! self derived-self)
|
|
(for-each (lambda (super)
|
|
(super '@set-self@ self))
|
|
(hash-ref @roos@ '@supers@))))
|
|
(roos-supers @roos@ supers super-invokes)
|
|
(roos-def @roos@ b)
|
|
...
|
|
(self '@set-self@ self)
|
|
self))))
|
|
|
|
(define-syntax roos
|
|
(syntax-rules ()
|
|
((_ (a ...) self (supers ...) b ...)
|
|
(begin
|
|
(define (a ...)
|
|
(roos-body self (supers ...) b ...))))
|
|
((_ (a ... . b) self (supers ...) c ...)
|
|
(begin
|
|
(define (a ... . b)
|
|
(roos-body self (supers ...) c ...))))
|
|
))
|
|
|
|
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(test-case
|
|
"Simple ROOS declaration and usage"
|
|
(roos (t1) this (supers) (a 10))
|
|
(let ((obj (t1)))
|
|
(check-true (= (-> obj a) 10))
|
|
(-> obj a! 12)
|
|
(check-true (= (-> obj a) 12))))
|
|
|
|
(test-case
|
|
"ROOS declaration with supers"
|
|
(roos (a x) this (supers)
|
|
(y (+ x 4))
|
|
((g a) (* a (-> this y))))
|
|
(roos (b) this (supers (a 2))
|
|
(y 55)
|
|
((v . a)
|
|
(if (null? a)
|
|
(-> supers y)
|
|
(begin
|
|
(-> supers y! (car a))
|
|
(-> supers y)))))
|
|
(let ((bb (b)))
|
|
(check-true (= (-> bb y) 55))
|
|
(check-true (= (-> bb g 2) 110))
|
|
(check-true (= (-> bb v) 6))
|
|
(check-true (= (-> bb v 10) 10))
|
|
(check-true (= (-> bb g 3) 165))
|
|
(-> bb y! 10)
|
|
(check-true (= (-> bb g 2) 20))))
|
|
|
|
)
|
|
|