1. Moritz Heidkamp
  2. coops-encore

Commits

Moritz Heidkamp  committed 5c82ea1

Initial commit

  • Participants
  • Branches master

Comments (0)

Files changed (5)

File .gitignore

View file
+*.c
+*.o
+*.so
+*.import.*

File coops-encore.meta

View file
+((synopsis "Extensions for the coops OOP system")
+ (author "Moritz Heidkamp")
+ (category oop)
+ (license "BSD")
+ (depends coops matchable)
+ (test-depends test))

File coops-encore.scm

View file
+(module coops-encore
+
+(define-class* define-record-class)
+
+(import chicken scheme)
+
+(use coops)
+
+(require-library matchable)
+
+(import-for-syntax matchable)
+
+(define-syntax define-class*
+  (ir-macro-transformer
+   (lambda (x i c)
+     (match x
+       ((_ (self <class>) (parents ...) (slots ...) methods ...)
+        (let* ((slot-names (map (lambda (s)
+                                  (if (pair? s)
+                                      (car s) s))
+                                slots))
+               (slot-names* (map gensym (map strip-syntax slot-names))))
+          `(begin
+             (define-class ,<class> ,parents ,slots)
+
+             ,@(map (lambda (slot-name slot-name*)
+                      (let ((slot-value `(slot-value x ',slot-name)))
+                        `(define ,slot-name*
+                           (getter-with-setter
+                            (lambda (x)
+                              ,slot-value)
+                            (lambda (x y)
+                              (set! ,slot-value y))))))
+                    slot-names slot-names*)
+
+             . ,(map (match-lambda
+                      (((name args ...) body ...)
+                       `(define-method (,name (,self ,<class>) . ,args)
+                          (let ,(map list slot-names slot-names*)
+                            . ,body))))
+                     methods))))))))
+
+(define-syntax define-record-class
+  (ir-macro-transformer
+   (lambda (x i c)
+     (match x
+       ((_ (name <class>) rest ...)
+        `(define-record-class (,name ,name ,<class>) . ,rest))
+       ((_ (self name <class>) (parents ...) (slots ...) methods ...)
+        (let* ((name* (symbol->string (strip-syntax name)))
+               (slot-names  (map (lambda (s)
+                                   (if (pair? s) (car s) s))
+                                 slots))
+               (getters     (map (lambda (slot-name)
+                                   (string-append
+                                    name* "-" (symbol->string (strip-syntax slot-name))))
+                                 slot-names))
+               (setters     (map (lambda (g)
+                                   (string->symbol (string-append g "-set!")))
+                                 getters))
+               (getters     (map string->symbol getters))
+               (predicate   (string->symbol (string-append name* "?")))
+               (constructor (string->symbol (string-append "make-" name*))))
+          `(begin
+             (define-class* (,self ,<class>)
+               ,parents ,slots . ,methods)
+             (define (,(i predicate) x)
+               (subclass? (class-of x) ,<class>))
+             (define (,(i constructor) . args)
+               (apply make ,<class>
+                      (append-map (lambda (s a)
+                                    (list s a))
+                                  ',slot-names
+                                  args)))
+             ,@(map (lambda (name slot)
+                      `(define (,(i name) x)
+                         (slot-value x ',slot)))
+                    getters slot-names)
+             ,@(map (lambda (name slot)
+                      `(define (,(i name) x y)
+                         (set! (slot-value x ',slot) y)))
+                    setters slot-names))))))))
+
+
+)

File coops-encore.setup

View file
+(compile -d0 -O2 -J -s coops-encore.scm)
+(compile -d0 -O2 -s coops-encore.import.scm)
+
+(install-extension
+ 'coops-encore
+ '("coops-encore.so" "coops-encore.import.so")
+ '((version "0.0.1")))

File tests/run.scm

View file
+(use coops coops-encore test)
+
+(define-class* (self <point>) ()
+  ((x 0) (y 0))
+  ((add (p <point>))
+   (make <point>
+     'x (+ (x self) (x p))
+     'y (+ (y self) (y p)))))
+
+
+(define point (make <point> 'x 10 'y 20))
+
+(test (make <point> 'x 20 'y 30)
+      (add point (make <point> 'x 10 'y 10)))
+
+(define-record-class (3d-point <3d-point>) (<point>)
+  ((x 0) (y 0) (z 0))
+  ((add (p <3d-point>))
+   (make-3d-point (+ (x 3d-point) (x p))
+                  (+ (y 3d-point) (y p))
+                  (+ (z 3d-point) (z p)))))
+
+(define 3d (make-3d-point))
+
+(test-assert (3d-point? 3d))
+(test 0 (slot-value 3d 'x))
+(3d-point-x-set! 3d 2)
+(test 2 (slot-value 3d 'x))
+
+(test (make-3d-point 5 7 9)
+      (add (make-3d-point 1 2 3)
+           (make-3d-point 4 5 6)))
+
+(test 10 (3d-point-x (make-3d-point 10 20 30)))
+(test (make <point> 'x 2 'y 2)
+      (add (make <3d-point> 'x 1 'y 1)
+           (make <point>    'x 1 'y 1)))