1. Moritz Heidkamp
  2. chicken- clojure

Commits

Moritz Heidkamp  committed e86555d

implement extend-type as a primitive macro

  • Participants
  • Parent commits 3d7ffcd
  • Branches master

Comments (0)

Files changed (2)

File clojure.scm

View file
  • Ignore whitespace
                   var))
           (else val))))
 
+(define (clojure-var-deref* var-name)
+  (clojure-var-deref (clojure-var-ref var-name)))
+
 (define (clojure-nil? x)
   (eq? 'nil x))
 
   '(def fn* let* loop* recur do quote in-ns ns var scheme*
         ;; the following primitives should be implemented in Clojure
         ;; itself later on
-        use defprotocol binding))
+        use defprotocol extend-type binding))
 
 (define clojure-reserved-symbols
   '(nil true false))
      (for-each
       (match-lambda
        ((method . impl)
-        (let* ((name     (clojure-keyword-name method))
-               (var-name (clojure-keyword->clojure-symbol method))
-               (proc     (clojure-var-deref (clojure-var-ref var-name))))
+        (let* ((name     (if (clojure-symbol? method)
+                             (clojure-symbol-name method)
+                             (clojure-keyword-name method)))
+               (var-name (if (clojure-symbol? method)
+                             method
+                             (clojure-keyword->clojure-symbol method)))
+               (proc     (clojure-var-deref* var-name)))
           (unless (protocol-has-method? protocol name)
             (error 'clojure-extend
                    "protocol doesn't have a method of that name"
                      (split-at pms 2)
                    (cons pm (loop more-pms))))))))
 
+(define +fn-sym+
+  (make-clojure-symbol 'clojure.core 'fn))
+
+(define compile-extend-type
+  (match-lambda
+   ((type protocols+methods ...) (=> fail)
+    (clojure-compile
+     (cons*
+      '~clojure-extend
+      type
+      (let loop ((pms protocols+methods))
+        (cond
+         ((null? pms) '())
+         ((clojure-symbol? (car pms))
+          (receive (methods rest) (span list? (cdr pms))
+            (cons*
+             (car pms)
+             (make-clojure-map
+              (map
+               (match-lambda
+                ((method body ...)
+                 (cons (list 'quote method)
+                       (cons +fn-sym+ body))))
+               methods))
+             (loop rest))))
+         (else (fail)))))))
+   (else (error 'clojure-extend-type
+                "invalid extend-type syntax"
+                else))))
+
 (define (compile-dispatch form)
   (match (clojure-dispatch-value form)
     (('quote sym)
                 (('binding rest ...)
                  (compile-binding rest))
                 (('scheme* forms ...)
-                 (compile-scheme* forms))))
+                 (compile-scheme* forms))
+                (('extend-type forms ...)
+                 (compile-extend-type forms))))
              (else
               (compile-fn-application sym rest)))))
     ((? pair?)

File tests/run.scm

View file
  • Ignore whitespace
   (test* #t "(and)")
   (test* 'nil "(if false 1)"))
 
-(test-group "defprotocol, extend"
+(test-group "defprotocol, extend, extend-type"
   (test* "bar, bar"
          "(defprotocol Foo"
          "  (foo [x y]))"
          "(extend String"
          "  Foo"
          "  {:foo (fn* [x y] (str x y x))})"
-         "(foo \"bar\" \", \")"))
+         "(foo \"bar\" \", \")")
+  (test* '(1 2)
+         "(defprotocol Bar"
+         "  (bar [x] [x y]))"
+         "(extend-type Symbol"
+         "  Bar"
+         "  (bar ([x] 1) ([x y] 2)))"
+         "(list (bar 'hey) (bar 'ho 'ho))"))
 
 (test-group "vars"
   (test-error* "#'asdlkajsldf"))