From e768d36318613afdc1deaf20ad6407f06eb5077f Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Mon, 17 Jun 2024 17:21:53 -0400 Subject: [PATCH] functions are typechecking!! --- src/main/tock/experiment.cljs | 119 ++++++++++++++++++++++++++++------ 1 file changed, 98 insertions(+), 21 deletions(-) diff --git a/src/main/tock/experiment.cljs b/src/main/tock/experiment.cljs index 742d38c..c50359f 100644 --- a/src/main/tock/experiment.cljs +++ b/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] - [malli.util] - [meander.epsilon :as m] - [clojure.pprint :as pp])) + [meander.epsilon :as m])) (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))) -(defmethod decorate-type `if [form ctx] +; ctx is a vector of atoms of maps +(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) - (let [[left-expr right-expr] (unify ?left ?right (compile-error ?left "Cannot compare incompatible types"))] - (bool `(= ~left-expr ~right-expr))))) + (?comparitor ?left ?right) + (let [[left-expr right-expr] (unify ?left ?right (compile-error ?right "Cannot compare incompatible types"))] + (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] - (cond (integer? form) (i64 `(lit ~form)) - (boolean? form) (bool `(lit ~form)) - :else (throw (compile-error form "Not a valid literal")))) +(defmethod decorate-type '= [form ctx] (decorate-comparison form ctx equatable-type?)) +(defmethod decorate-type 'not= [form ctx] (decorate-comparison form ctx equatable-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 '> [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] - (pr (typecheck-expr `(if 3 3 true) nil))) +; todo: actually validate types +(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: