diff --git a/info.rkt b/info.rkt index 164e8d5..628fe4f 100644 --- a/info.rkt +++ b/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") diff --git a/main.rkt b/main.rkt index a139b78..8586756 100644 --- a/main.rkt +++ b/main.rkt @@ -1,113 +1,170 @@ #lang racket/base -(require racket/syntax) -(provide roos ->) + (require racket/syntax) + (provide roos -> roos-object? roos-class roos-class?) -(define-syntax -> - (syntax-rules () - ((_ obj method) + (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 () + ((_ obj method) (obj 'method)) - ((_ obj method arg ...) - (obj 'method arg ...)))) + ((_ 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-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-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) + (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 (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-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-body + (syntax-rules () + ((_ class classname 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@)))) + (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 - (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 ...)))) - )) + (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 (@roos-class a ...) (@roos-classname a ...) self (supers ...) b ...)))) + ((_ (a ... . b) self (supers ...) c ...) + (begin + (define (a ... . b) + (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))) + ) ) diff --git a/roos.rkt b/roos.rkt deleted file mode 100644 index 241ab23..0000000 --- a/roos.rkt +++ /dev/null @@ -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 ...)))))) - - ) diff --git a/scribblings/roos.scrbl b/scribblings/roos.scrbl index 86ce615..bcbbb8c 100644 --- a/scribblings/roos.scrbl +++ b/scribblings/roos.scrbl @@ -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") + + ]