Roos package

roos.rkt

@@ -0,0 +1,100 @@
+#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 ...))))))
+
+  )