Documentation and meta functions

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")

main.rkt

@@ -1,16 +1,32 @@
 #lang racket/base
 
-(require racket/syntax)
+  (require racket/syntax)
-(provide roos ->)
+  (provide roos -> roos-object? roos-class roos-class?)
 
-(define-syntax ->
+  (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 ...))))
 
-(define-syntax roos-def
+  (define-syntax roos-def
     (syntax-rules ()
       ((_ h ((a) expr ...))
        (begin
@@ -43,7 +59,7 @@
          (hash-set! h (string->symbol (format "~a!" 'a)) (lambda (v) (set! a v)))))
       ))
 
-(define-syntax roos-supers
+  (define-syntax roos-supers
     (syntax-rules ()
       ((_ self supers ())
        (hash-set! self '@supers@ (list)))
@@ -55,12 +71,12 @@
        (hash-set! self '@supers@ (list x y ...)))
       ))
 
-(define-syntax roos-err
+  (define-syntax roos-err
     (syntax-rules ()
       ((_ name msg)
        (error (format "~a: ~a" name msg)))))
 
-(define (roos-call hash supers f-name 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)
@@ -68,15 +84,15 @@
               (roos-call ((car supers) '@roos@) (cdr supers) f-name args))
           (apply f args))))
 
-(define-syntax roos-supers-def
+  (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
+  (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)))
+   )
   
   )
 

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 ...))))))
-
-  )

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")
+          
+          ]