functions are typechecking!!

src/main/tock/experiment.cljs

@@ -4,10 +4,7 @@
             [helins.wasm.bin :as op]
             [helins.binf :as binf]
             [helins.binf.string :as binf.string]
-            ;; [malli.core :as malli]
+            [meander.epsilon :as m]))
-            [malli.util]
-            [meander.epsilon :as m]
-            [clojure.pprint :as pp]))
 
 (defn compile-error [term message]
   ; todo: extract location of error term
@@ -42,39 +39,119 @@
           :else (throw error))))
 
 (defn form-dispatch [form]
-  (if (list? form) (first form) `lit))
+  (if (list? form) (first form) `atom))
 
-(defmulti map-subexpressions (fn [form f] (form-dispatch form)))
+; not sure about this... in non-special-form cases, all first values are subexpressions
+; as well, it's simply not needed for decorate-type, as in order to typecheck any special
+; form, you need to explicitly recurse anyway
+(defmulti map-subexpressions (fn [form _f] (form-dispatch form)))
 (defmethod map-subexpressions :default [form f]
   (apply list (first form) (map f (rest form))))
-(defmethod map-subexpressions `lit [form f] form)
+(defmethod map-subexpressions `atom [form _f] form)
 
-(defmulti decorate-type (fn [form ctx] (form-dispatch form)))
+; ctx is a vector of atoms of maps
-(defmethod decorate-type `if [form ctx]
+(defn new-scope 
+  ([ctx base] (conj ctx (atom base)))
+  ([ctx] (new-scope ctx {})))
+
+(defn lookup [ctx key]
+  (loop [scopes (reverse ctx)]
+    (when (seq scopes)
+      (let [scope (deref (first scopes))
+            value (get scope key)]
+        (if (nil? value) (recur (rest scopes)) value)))))
+(defn bind! [ctx key data]
+  (swap! (last ctx) assoc key data))
+
+(defmulti decorate-type (fn [form _ctx] (form-dispatch form)))
+(defmethod decorate-type 'if [form _ctx]
   (m/match form
     (_ ?test ?when-true ?when-false)
     (let [test-expr (coerce ?test 'bool (compile-error ?test "Condition must be a boolean expression"))
           [true-expr false-expr] (unify ?when-true ?when-false nil)
           type (expr-type true-expr)]
-      (assoc-type `(if ~test-expr ~true-expr ~false-expr) type))))
+      (assoc-type (list 'if test-expr true-expr false-expr) type))))
 
-(defmethod decorate-type `= [form ctx]
+(defn equatable-type? [typesym] (contains? #{'i64 'bool} typesym))
+(defn ordered-type? [typesym] (= typesym 'i64))
+(defn logical-type? [typesym] (= typesym 'bool))
+
+(defn decorate-comparison [form _ctx typecheck]
   (m/match form
-    (_ ?left ?right)
+    (?comparitor ?left ?right)
-    (let [[left-expr right-expr] (unify ?left ?right (compile-error ?left "Cannot compare incompatible types"))]
+    (let [[left-expr right-expr] (unify ?left ?right (compile-error ?right "Cannot compare incompatible types"))]
-      (bool `(= ~left-expr ~right-expr)))))
+      (if (typecheck (expr-type left-expr))
+        (bool (list '= left-expr right-expr))
+        (throw (compile-error left-expr ["is not comparable using " ?comparitor]))))))
 
-(defmethod decorate-type `lit [form ctx]
+(defmethod decorate-type '= [form ctx] (decorate-comparison form ctx equatable-type?))
-  (cond (integer? form) (i64 `(lit ~form))
+(defmethod decorate-type 'not= [form ctx] (decorate-comparison form ctx equatable-type?))
-        (boolean? form) (bool `(lit ~form))
+(defmethod decorate-type '< [form ctx] (decorate-comparison form ctx ordered-type?))
-        :else           (throw (compile-error form "Not a valid literal"))))
+(defmethod decorate-type '<= [form ctx] (decorate-comparison form ctx ordered-type?))
+(defmethod decorate-type '> [form ctx] (decorate-comparison form ctx ordered-type?))
+(defmethod decorate-type '>= [form ctx] (decorate-comparison form ctx ordered-type?))
+(defmethod decorate-type 'and [form ctx] (decorate-comparison form ctx logical-type?))
+(defmethod decorate-type 'or [form ctx] (decorate-comparison form ctx logical-type?))
 
-(defmulti typecheck-expr (fn [form ctx] (form-dispatch form)))
+(defmethod decorate-type `atom [form ctx]
+  (cond (integer? form)       (i64 `(lit ~form))
+        (boolean? form)       (bool `(lit ~form))
+        (simple-symbol? form) (m/match (lookup ctx form)
+                                {:local ?local-id :type ?type} (assoc-type `(local ~?local-id) ?type)
+                                _ (throw (compile-error form "Undefined symbol")))
+        :else                 (throw (compile-error form "Not a valid literal"))))
+
+(defmulti typecheck-expr (fn [form _ctx] (form-dispatch form)))
 (defmethod typecheck-expr :default [form ctx]
   (decorate-type (map-subexpressions form #(typecheck-expr % ctx)) ctx))
 
-(binding [*print-meta* true] 
+; todo: actually validate types
-  (pr (typecheck-expr `(if 3 3 true) nil)))
+(defn validate-type [type] type)
+
+; (fn [name type name type return-type] body)
+(defn alloc-local [ctx]
+  (swap! (lookup ctx ::lastlocal) inc))
+; todo: must store function metadata globally
+(defn alloc-func [ctx func-type func-body]
+  (let [funcs (swap! (lookup ctx ::module-funcs)
+                     (fn [funcs]
+                       (conj funcs {:type func-type :body func-body})))]
+    (- (count funcs) 1)))
+
+(defn bind-params! [params ctx]
+  (let [bind-param! (fn [name type]
+                      (bind! ctx name {:local (alloc-local ctx)
+                                       :type (validate-type type)}))
+        bind-all!   (fn [names types return-type]
+                      (doseq [[name type] (map vector names types)] (bind-param! name type))
+                      (apply vector (concat ['fn] types [return-type])))]
+    (m/match params
+      [!name !type ... ?return-type] (bind-all! !name !type ?return-type)
+      [!name !type ...] (bind-all! !name !type 'void))))
+
+(defmethod typecheck-expr 'fn [form ctx]
+  (let [fn-ctx (new-scope ctx {::lastlocal (atom -1)})]
+    (m/match form
+      (_ ?params . !body ..1)
+      (let [fn-type (bind-params! ?params fn-ctx)
+            return-type (last fn-type)
+            body-expr (coerce (typecheck-expr (apply list 'do !body) fn-ctx) return-type
+                              (compile-error form ["Expected return type" return-type]))]
+        (assoc-type (list 'funcref (alloc-func ctx fn-type body-expr)) fn-type)))))
+
+(defmethod typecheck-expr 'do [form ctx]
+  (m/match form
+    (_ . !statement ... ?return-expr)
+    (let [statements (apply list (map (fn [expr] (coerce (typecheck-expr expr ctx) 'void nil)) !statement))
+          return-expr (typecheck-expr ?return-expr ctx)
+          return-type (expr-type return-expr)]
+      (assoc-type (apply list (concat ['do] statements [return-expr])) return-type))))
+
+(binding [*print-meta* true]
+  (let [ctx [(atom {::module-funcs (atom [])})]
+        form '(fn [x i64 y i64 bool] (< x y))]
+    (pr (typecheck-expr form ctx))
+    (pr (deref (first ctx)))))
 
 ; first task: compile (+ 1 2)
 ; expected output: