functions are typechecking!!

This commit is contained in:
Jeremy Penner 2024-06-17 17:21:53 -04:00
parent 1b8d487e25
commit e768d36318

View file

@ -4,10 +4,7 @@
[helins.wasm.bin :as op] [helins.wasm.bin :as op]
[helins.binf :as binf] [helins.binf :as binf]
[helins.binf.string :as binf.string] [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] (defn compile-error [term message]
; todo: extract location of error term ; todo: extract location of error term
@ -42,39 +39,119 @@
:else (throw error)))) :else (throw error))))
(defn form-dispatch [form] (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] (defmethod map-subexpressions :default [form f]
(apply list (first form) (map f (rest form)))) (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 (m/match form
(_ ?test ?when-true ?when-false) (_ ?test ?when-true ?when-false)
(let [test-expr (coerce ?test 'bool (compile-error ?test "Condition must be a boolean expression")) (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) [true-expr false-expr] (unify ?when-true ?when-false nil)
type (expr-type true-expr)] 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 (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] (defmethod typecheck-expr :default [form ctx]
(decorate-type (map-subexpressions form #(typecheck-expr % ctx)) 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) ; first task: compile (+ 1 2)
; expected output: ; expected output: