From ab2f2790de210f9f09b9831355a76f0ba53bbb39 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 12 Jan 2015 15:39:25 +0900
Subject: [PATCH] add (picrin class) and (picrin protocol)

---
 contrib/40.class/CMakeLists.txt               |  2 +
 contrib/40.class/piclib/picrin/class.scm      | 35 +++++++++
 contrib/50.protocol/CMakeLists.txt            |  2 +
 .../50.protocol/piclib/picrin/protocol.scm    | 72 +++++++++++++++++++
 4 files changed, 111 insertions(+)
 create mode 100644 contrib/40.class/CMakeLists.txt
 create mode 100644 contrib/40.class/piclib/picrin/class.scm
 create mode 100644 contrib/50.protocol/CMakeLists.txt
 create mode 100644 contrib/50.protocol/piclib/picrin/protocol.scm

diff --git a/contrib/40.class/CMakeLists.txt b/contrib/40.class/CMakeLists.txt
new file mode 100644
index 00000000..5281edcd
--- /dev/null
+++ b/contrib/40.class/CMakeLists.txt
@@ -0,0 +1,2 @@
+file(GLOB CLASS_FILES ${PROJECT_SOURCE_DIR}/contrib/40.class/piclib/picrin/*.scm)
+list(APPEND PICLIB_CONTRIB_LIBS ${CLASS_FILES})
diff --git a/contrib/40.class/piclib/picrin/class.scm b/contrib/40.class/piclib/picrin/class.scm
new file mode 100644
index 00000000..f4407adf
--- /dev/null
+++ b/contrib/40.class/piclib/picrin/class.scm
@@ -0,0 +1,35 @@
+(define-library (picrin class)
+  (import (scheme base))
+
+  (define-record-type class-type
+      (make-class membership)
+      class?
+    (membership class-membership))
+
+  (define-syntax define-class
+    (syntax-rules ()
+      ((define-class name membership)
+       (define name (make-class membership)))))
+
+  (define (instance? obj class)
+    ((class-membership class) obj))
+
+  (define-class <class> class?)
+
+  (define-class <any> (lambda (x) #t))
+  (define-class <list> list?)
+  (define-class <procedure> procedure?)
+  (define-class <number> number?)
+  (define-class <boolean> boolean?)
+  (define-class <string> string?)
+
+  (export make-class
+          instance?
+          define-class
+          <class>
+          <any>
+          <list>
+          <procedure>
+          <number>
+          <boolean>
+          <string>))
diff --git a/contrib/50.protocol/CMakeLists.txt b/contrib/50.protocol/CMakeLists.txt
new file mode 100644
index 00000000..41b4df2f
--- /dev/null
+++ b/contrib/50.protocol/CMakeLists.txt
@@ -0,0 +1,2 @@
+file(GLOB PROTOCOL_FILES ${PROJECT_SOURCE_DIR}/contrib/50.protocol/piclib/picrin/*.scm)
+list(APPEND PICLIB_CONTRIB_LIBS ${PROTOCOL_FILES})
diff --git a/contrib/50.protocol/piclib/picrin/protocol.scm b/contrib/50.protocol/piclib/picrin/protocol.scm
new file mode 100644
index 00000000..3a0175ab
--- /dev/null
+++ b/contrib/50.protocol/piclib/picrin/protocol.scm
@@ -0,0 +1,72 @@
+(define-library (picrin protocol)
+  (import (scheme base)
+          (srfi 1))
+
+  (import (picrin class))
+
+  (define method-table
+    '())
+
+  (define (applicative? args types)
+    (cond
+     ((and (null? args) (null? types))
+      #true)
+     ((and (pair? args) (pair? types))
+      (and (instance? (car args) (car types)) (applicative? (cdr args) (cdr types))))
+     (else
+      #false)))
+
+  (define (find-generic generic)
+    (or (assq generic method-table)
+        (error "no method alist found")))
+
+  (define (find-method generic args)
+    (let ((methods (cdr (find-generic generic))))
+      (let ((m (filter (lambda (x) (applicative? args (cdr x))) methods)))
+        (if (null? m)
+            #f
+            (car (car m))))))
+
+  (define (add-generic generic)
+    (set! method-table (cons (cons generic '()) method-table)))
+
+  (define (add-method generic method types)
+    (let ((r (find-generic generic)))
+      (set-cdr! r (cons (cons method types) (cdr r)))))
+
+  (define (add-methods methods prototypes)
+    (for-each
+     (lambda (method prototype)
+       (add-method (car prototype) method (cdr prototype)))
+     methods
+     prototypes))
+
+  (define make-generic
+    (lambda ()
+      (letrec ((self (lambda args
+                       (let ((m (find-method self args)))
+                         (if m
+                             (apply m args)
+                             (error "method not found"))))))
+        (add-generic self)
+        self)))
+
+  (define-syntax define-protocol
+    (syntax-rules ()
+      ((define-protocol (name type ...) (method arg ...) ...)
+       (begin
+         (define method
+           (make-generic))
+         ...
+         (define name
+           (lambda (type ...)
+             (lambda methods
+               (add-methods methods (list (list method arg ...) ...)))))))))
+
+  (define-syntax define-instance
+    (syntax-rules ()
+      ((define-instance (name arg ...) method ...)
+       ((name arg ...) method ...))))
+
+  (export define-protocol
+          define-instance))