98 lines
2.0 KiB
Racket
98 lines
2.0 KiB
Racket
#lang racket
|
|
|
|
(require (rename-in racket/class [send old-send] [new old-new]))
|
|
(require (for-syntax (rename-in roos [%-> old->])))
|
|
(require (rename-in roos [%-> old->]))
|
|
|
|
(provide (all-from-out roos)
|
|
(all-from-out racket/class)
|
|
%-> send new
|
|
)
|
|
|
|
(define-syntax send
|
|
(syntax-rules ()
|
|
((_ obj method)
|
|
(if (roos-object? obj)
|
|
(old-> obj method)
|
|
(old-send obj method)))
|
|
((_ obj method a ...)
|
|
(if (roos-object? obj)
|
|
(old-> obj method a ...)
|
|
(old-send obj method a ...)))
|
|
))
|
|
|
|
|
|
|
|
(define-syntax %->
|
|
(syntax-rules ()
|
|
((_ obj method)
|
|
(if (roos-object? obj)
|
|
(old-> obj method)
|
|
(old-send obj method)))
|
|
((_ obj method a ...)
|
|
(if (roos-object? obj)
|
|
(old-> obj method a ...)
|
|
(old-send obj method a ...)))
|
|
))
|
|
|
|
(define-syntax new*
|
|
(syntax-rules (v)
|
|
((_ cl (x y) ...)
|
|
(old-new cl (x y) ...))
|
|
((_ cl x ...)
|
|
(old-new cl (v x) ...))
|
|
))
|
|
|
|
(define-syntax new
|
|
(syntax-rules ()
|
|
((_ cl)
|
|
(if (roos-class? cl)
|
|
(roos-new cl)
|
|
(old-new cl)))
|
|
((_ cl a ...)
|
|
(if (roos-class? cl)
|
|
(roos-new cl a ...)
|
|
(new* cl a ...)))
|
|
))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Testing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(define (t% x)
|
|
(class object%
|
|
(init-field (y* x))
|
|
(define/public (y) y*)
|
|
(define/public (y! x) (set! y* x))
|
|
(define/public (f a) (* (send this y) a))
|
|
(super-new)
|
|
))
|
|
|
|
(def-roos (t x) this (supers)
|
|
(y x)
|
|
((f a) (* (%-> this y) a))
|
|
)
|
|
|
|
(check-true
|
|
(let ((cl (t% 5)))
|
|
(let ((o (new cl)))
|
|
(= (send o f 2) 10))))
|
|
|
|
(check-true
|
|
(let ((cl (t% 6)))
|
|
(let ((o (new cl)))
|
|
(= (%-> o f 3) 18))))
|
|
|
|
(check-true
|
|
(let ((o (new t 8)))
|
|
(= (%-> o f 4) 32)))
|
|
|
|
(check-true
|
|
(= (send (new t 4) f 2) 8))
|
|
)
|
|
|