functions are typechecking!!
This commit is contained in:
parent
1b8d487e25
commit
e768d36318
|
@ -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))
|
||||||
|
|
||||||
|
; 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]
|
(binding [*print-meta* true]
|
||||||
(pr (typecheck-expr `(if 3 3 true) nil)))
|
(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:
|
||||||
|
|
Loading…
Reference in a new issue