eros.scm

(define-library (eros)
  (import (scheme base)
          (scheme write)
          (srfi 1)
          (srfi 8)
          (picrin macro)
          (picrin attribute)
          (picrin dictionary))

  (define-record-type class
    (make-class membership)
    class?
    (membership class-membership))

  (define-syntax define-class
    (syntax-rules ()
      ((_ class-name membership)
       (define class-name
         (make-class membership)))))

  (define-class <value> (lambda (obj) #t))
  (define-class <class> class?)
  (define-class <number> number?)
  (define-class <string> string?)
  (define-class <procedure> procedure?)
  (define-class <boolean> boolean?)

  (define (instance-of? obj class)
    ((class-membership class) obj))

  (define method-sym 'methods)

  (define-syntax define-generic
    (ir-macro-transformer
     (lambda (form inject compare)
       (let ((generic-name (cadr form)))
         `(define (,generic-name . args)
            (let ((method-alst
                   (dictionary-ref (attribute ,generic-name) method-sym)))
              (if method-alst
                  (apply (find-method args method-alst) args)
                  (error "No methods found"))))))))
  
  (define (add-method generic-fn arg-type-list closure)
    (dictionary-set!
     (attribute generic-fn) 'methods
     `((,arg-type-list . ,closure) .
       ,(let ((x (dictionary-ref (attribute generic-fn)
                                 'methods)))
          (if x x '())))))

  (define (method-args-types lst)
    (map
     (lambda (x)
       (if (pair? x) (cadr x) <value>))
     lst))

  (define (method-args-params lst)
    (map
     (lambda (x)
       (if (pair? x) (car x) x))
     lst))

  (define-syntax define-method
    (ir-macro-transformer
     (lambda (form rename compare)
       (let ((method-name (caadr form))
             (args (cdadr form))
             (body (cddr form)))
         `(add-method ,method-name
                      (list ,@(method-args-types args))
                      (lambda ,(method-args-params args)
                        ,@body))))))
  
  (define (find-method args method-lst)
    (let ((method
           (member
            args method-lst
            (lambda (x y)
              (every values
                     (map instance-of? x (car y)))))))
      (if method
          (cdar method)
          (error "No methods found"))))

  (define-generic class-of)
  (define-method (class-of obj)
    <value>)
  (define-method (class-of (num <number>))
    <number>)
  (define-method (class-of (str <string>))
    <string>)
  (define-method (class-of (proc <procedure>))
    <procedure>)
  (define-method (class-of (bool <boolean>))
    <boolean>)

  (export class?
          define-class
          <class>
          <value>
          <number>
          <string>
          <procedure>
          <boolean>
          instance-of?
          define-generic
          define-method
          class-of))

(import (eros))

(define (print obj)
  (display obj)
  (newline))

(define-generic foo)
(define-method (foo (n <number>))
  (+ 1 n))
(define-method (foo (str <string>))
  (apply string-append (list "Hi, " str "!")))

(print "; ------------------")
(print "; foo method calling")
(print "")
(print "; (foo 10)")
(print (foo 10))
(print "")
(print "; (foo \"lisper\")")
(print (foo "lisper"))
(print "")

(print "; class-of")
(print "")
(print "; (eq? (class-of 10) <number>)")
(print (eq? (class-of 10) <number>))
(print "")
(print "; (eq? (class-of \"hello\") <string>)")
(print (eq? (class-of "hello") <string>))
(print "")
(print "; (eq? (class-of #f) <boolean>)")
(print (eq? (class-of #f) <boolean>))
(print "")
(print "; (eq? (class-of 'hoge) <value>)")
(print (eq? (class-of 'hoge) <value>))
(print "")
(print "; done")
(print "; ------------------")