Documentation and meta functions
This commit is contained in:
2
info.rkt
2
info.rkt
@@ -1,7 +1,7 @@
|
||||
#lang info
|
||||
|
||||
(define pkg-authors '(hnmdijkema))
|
||||
(define version "0.1")
|
||||
(define version "0.2")
|
||||
(define license 'Apache-2.0)
|
||||
(define collection "roos")
|
||||
(define pkg-desc "An OO Framework for Racket")
|
||||
|
||||
73
main.rkt
73
main.rkt
@@ -1,7 +1,23 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/syntax)
|
||||
(provide roos ->)
|
||||
(provide roos -> roos-object? roos-class roos-class?)
|
||||
|
||||
(define (roos-object? obj)
|
||||
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(-> obj @roos-object?@)))
|
||||
|
||||
(define (roos-classname obj)
|
||||
(if (roos-object? obj)
|
||||
(-> obj @roos-classname@)
|
||||
(if (roos-class? obj)
|
||||
(obj '@roos-classname@)
|
||||
#f)))
|
||||
|
||||
(define (roos-class obj)
|
||||
(if (roos-object? obj)
|
||||
(-> obj @roos-class@)
|
||||
#f))
|
||||
|
||||
(define-syntax ->
|
||||
(syntax-rules ()
|
||||
@@ -76,7 +92,7 @@
|
||||
|
||||
(define-syntax roos-body
|
||||
(syntax-rules ()
|
||||
((_ self (supers . super-invokes) b ...)
|
||||
((_ class classname self (supers . super-invokes) b ...)
|
||||
(begin
|
||||
(define @roos@ (make-hash))
|
||||
(define @super-starter@ (make-hash))
|
||||
@@ -89,25 +105,66 @@
|
||||
(for-each (lambda (super)
|
||||
(super '@set-self@ self))
|
||||
(hash-ref @roos@ '@supers@))))
|
||||
(hash-set! @roos@ '@roos-classname@ (lambda () classname))
|
||||
(hash-set! @roos@ '@roos-class@ (lambda () class))
|
||||
(hash-set! @roos@ '@roos-object?@ (lambda () #t))
|
||||
(roos-supers @roos@ supers super-invokes)
|
||||
(roos-def @roos@ b)
|
||||
...
|
||||
(self '@set-self@ self)
|
||||
self))))
|
||||
|
||||
(define-syntax roos
|
||||
(define-syntax @roos-classname
|
||||
(syntax-rules ()
|
||||
((_ a . b)
|
||||
'a)))
|
||||
|
||||
(define-syntax @roos-class
|
||||
(syntax-rules ()
|
||||
((_ a . b)
|
||||
a)))
|
||||
|
||||
(define-syntax roos1
|
||||
(syntax-rules ()
|
||||
((_ (a ...) self (supers ...) b ...)
|
||||
(begin
|
||||
(define (a ...)
|
||||
(roos-body self (supers ...) b ...))))
|
||||
(roos-body (@roos-class a ...) (@roos-classname a ...) self (supers ...) b ...))))
|
||||
((_ (a ... . b) self (supers ...) c ...)
|
||||
(begin
|
||||
(define (a ... . b)
|
||||
(roos-body self (supers ...) c ...))))
|
||||
(roos-body (@roos-class a ... . b) (@roos-classname a ... . b) self (supers ...) c ...))))
|
||||
))
|
||||
|
||||
|
||||
(define-syntax @roos-caller
|
||||
(syntax-rules ()
|
||||
((_ a . b)
|
||||
a)))
|
||||
|
||||
(define-syntax @roos-top
|
||||
(syntax-rules ()
|
||||
((_ (a . bb) (at ...) self (supers ...) b ...)
|
||||
(define (a . arg)
|
||||
(roos1 (at ...) self (supers ...) b ...)
|
||||
(if (null? arg)
|
||||
(a)
|
||||
(if (eq? (car arg) '@roos-class?)
|
||||
'@is-a-roos-class
|
||||
(if (eq? (car arg) '@roos-classname@)
|
||||
(@roos-classname at ...)
|
||||
(apply (@roos-caller at ...) arg))))))))
|
||||
|
||||
|
||||
(define-syntax roos
|
||||
(syntax-rules ()
|
||||
((_ (a ...) self (supers ...) b ...)
|
||||
(@roos-top (a ...) (a ...) self (supers ...) b ...))))
|
||||
|
||||
|
||||
(define (roos-class? cl)
|
||||
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(eq? (cl '@roos-class?) '@is-a-roos-class)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
@@ -118,7 +175,8 @@
|
||||
(let ((obj (t1)))
|
||||
(check-true (= (-> obj a) 10))
|
||||
(-> obj a! 12)
|
||||
(check-true (= (-> obj a) 12))))
|
||||
(check-true (= (-> obj a) 12)))
|
||||
)
|
||||
|
||||
(test-case
|
||||
"ROOS declaration with supers"
|
||||
@@ -140,7 +198,8 @@
|
||||
(check-true (= (-> bb v 10) 10))
|
||||
(check-true (= (-> bb g 3) 165))
|
||||
(-> bb y! 10)
|
||||
(check-true (= (-> bb g 2) 20))))
|
||||
(check-true (= (-> bb g 2) 20)))
|
||||
)
|
||||
|
||||
)
|
||||
|
||||
|
||||
100
roos.rkt
100
roos.rkt
@@ -1,100 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/syntax)
|
||||
(provide roos ->)
|
||||
|
||||
(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 ())
|
||||
(hash-set! self 'super (list)))
|
||||
((_ self (a))
|
||||
(hash-set! self 'super (list (a))))
|
||||
((_ self (a b ...))
|
||||
(hash-set! self 'super (list (a b ...))))
|
||||
((_ ((x) (y) ...))
|
||||
(hash-set! self 'super (list (roos-supers x) (roos-supers y) ...)))
|
||||
))
|
||||
|
||||
(define-syntax roos
|
||||
(syntax-rules ()
|
||||
((_ (a ...) self supers b ...)
|
||||
(begin
|
||||
(define (a ...)
|
||||
(begin
|
||||
(define self (make-hash))
|
||||
(roos-supers self supers)
|
||||
(roos-def self b)
|
||||
...
|
||||
self))))
|
||||
((_ (a ... . b) self supers c ...)
|
||||
(begin
|
||||
(define (a ... . b)
|
||||
(begin
|
||||
(define self (make-hash))
|
||||
(roos-supers self supers)
|
||||
(roos-def self c)
|
||||
...
|
||||
self))))
|
||||
))
|
||||
|
||||
(define (find-super obj method)
|
||||
(let ((supers (hash-ref obj 'super '())))
|
||||
(letrec ((f (lambda (supers)
|
||||
(if (null? supers)
|
||||
(error (format "Method ~a not found" method))
|
||||
(let ((s (car supers)))
|
||||
(let ((m (hash-ref s method '%roos-nil%)))
|
||||
(if (eq? m '%roos-nil%)
|
||||
(f (cdr supers))
|
||||
m)))))))
|
||||
(f supers))))
|
||||
|
||||
(define-syntax ->
|
||||
(syntax-rules ()
|
||||
((_ obj method)
|
||||
(let ((f (hash-ref obj 'method '%roos-nil%)))
|
||||
(if (eq? f '%roos-nil%)
|
||||
(let ((f* (find-super obj 'method)))
|
||||
(f*))
|
||||
(f))))
|
||||
((_ obj method arg ...)
|
||||
(let ((f (hash-ref obj 'method '%roos-nil%)))
|
||||
(if (eq? f '%roos-nil%)
|
||||
(let ((f* (find-super obj 'method)))
|
||||
(f* arg ...))
|
||||
(f arg ...))))))
|
||||
|
||||
)
|
||||
@@ -2,7 +2,7 @@
|
||||
|
||||
@(require
|
||||
scribble/example
|
||||
@(for-label racket roos))
|
||||
@(for-label roos))
|
||||
|
||||
@(define myeval
|
||||
(make-base-eval '(require roos)))
|
||||
@@ -23,22 +23,69 @@ method will be used.
|
||||
...
|
||||
((method-j ...) expr ...)
|
||||
)]
|
||||
Defines a class with name @code{class-name}. @code{this} refers to the instantiated object of class @{class-name}, @code{supers} refers to the possible instantiated super classes of @code{class-name}. @code{attribute-i} defines an attribute. It will create a getter, named @code{attribute-i}, and a setter, named @code{attribute-i!}. @code{method-j} defines a method.
|
||||
Defines a class with name @code{class-name}. @code{this} refers to the instantiated object of class @code{class-name}, @code{supers} refers to the possible instantiated super classes of @code{class-name}. @code{attribute-i} defines an attribute. It will create a getter, named @code{attribute-i}, and a setter, named @code{attribute-i!}. @code{method-j} defines a method.
|
||||
|
||||
@defform[(-> obj name ...)]
|
||||
Calls a method or getter/setter of obj.
|
||||
|
||||
@examples[#:eval eval
|
||||
@defform[(roos-class? var)]
|
||||
Returns @code{#t}, if var is a defined roos class; @code{#f}, otherwise.
|
||||
|
||||
@defform[(roos-object? var)]
|
||||
Returns @code{#t}, if var is a variable instantiated by a roos class; @code{#f}, otherwise.
|
||||
|
||||
@defform[(roos-classname var)]
|
||||
Returns the name (as symbol) of the defined roos class, or of the class of a roos object, if var is an instantiated class; @code{#f}, otherwise.
|
||||
|
||||
@defform[(roos-class var)]
|
||||
Returns the defined roos class of an instantiated roos class if @code{roos-object?} returns @code{#t}; @code{#f}, otherwise
|
||||
|
||||
|
||||
@examples[(require roos)
|
||||
(roos (a x) this (supers)
|
||||
(y ( + x 4))
|
||||
((g a) (* a (-> this y))))
|
||||
(roos (b) this (supers (a))
|
||||
|
||||
(roos (b1) this (supers (a 6))
|
||||
((v . a) (if (null? a)
|
||||
(-> supers y)
|
||||
(begin
|
||||
(-> supers y! (car a))
|
||||
(-> supers y))))
|
||||
(y 55))
|
||||
(define bb (b))
|
||||
(-> bb g 2)]
|
||||
|
||||
(roos (b2) this (supers (a 5))
|
||||
((v2) (-> supers y))
|
||||
((v2*) (-> this y)))
|
||||
|
||||
(roos (c) this (supers (b1) (b2))
|
||||
((zy) (-> supers y))
|
||||
((z1) (-> supers v))
|
||||
((z2) (-> supers v2))
|
||||
(y -1))
|
||||
|
||||
(define-syntax :
|
||||
(syntax-rules ()
|
||||
((_ c d ...)
|
||||
c)))
|
||||
|
||||
(define bb (b1))
|
||||
|
||||
(: (-> bb g 2) "(-> bb g 2) Will return the value of (* 2 y of class b1)")
|
||||
(: (-> bb y! 7) "(-> bb y! 7) Will set y in class b1 to 7")
|
||||
(: (-> bb g 6) "(-> bb g 6) Will return 42")
|
||||
(: (-> bb v) "(-> bb v) Will return the value of y in class a")
|
||||
(: (-> bb v 42) "(-> bb v 42) Will set the value of y in class a to 42")
|
||||
(: (-> bb y) "(-> bb y) Will return the value of y in class b1, i.e. 7")
|
||||
(: (-> bb v) "(-> bb v) Will return the value of y in class a, i.e. 42")
|
||||
|
||||
(define cc (c))
|
||||
(: (-> cc zy) "(-> cc zy) Will return the value of y in super class b1")
|
||||
(: (-> cc y! 88) "(-> cc y! 88) Will set the value of y in class c")
|
||||
(: (-> cc zy) "(-> cc zy) Will return the value of y in super class b1")
|
||||
(: (-> cc z1) "(-> cc z1) Will return the value of y in the super class of b1, which will be (+ 4 6) = 10")
|
||||
(: (-> cc z2) "(-> cc z2) Will return this value of y in the super class of b2, which will be (+ 4 5) = 9")
|
||||
(: (-> cc v2*) "(-> cc v2*) Will return the value of y in class c")
|
||||
|
||||
]
|
||||
|
||||
|
||||
Reference in New Issue
Block a user