diff --git a/src/main/tock/compiler.cljc b/src/main/tock/compiler.cljc index 66beeda..fd44814 100644 --- a/src/main/tock/compiler.cljc +++ b/src/main/tock/compiler.cljc @@ -2,7 +2,7 @@ (:require [tock.compiler.desugar :refer [desugar]] [tock.compiler.bind :refer [bind]] [tock.compiler.specials :refer [specials]] - ;; [tock.compiler.type :refer [typecheck-expr]] + [tock.compiler.type :refer [typecheck]] ;; [tock.compiler.wasm :refer [ctx-to-wasm]] [meander.epsilon :as m])) @@ -57,4 +57,5 @@ (let [ctx (new-ctx)] (-> form (desugar specials) - (bind specials ctx)))) + (bind specials ctx) + (typecheck specials)))) diff --git a/src/main/tock/compiler/bind.cljc b/src/main/tock/compiler/bind.cljc index 26b22cc..d661b0e 100644 --- a/src/main/tock/compiler/bind.cljc +++ b/src/main/tock/compiler/bind.cljc @@ -1,7 +1,7 @@ (ns tock.compiler.bind (:require [meander.epsilon :as m] [tock.compiler.util :refer [get-special new-scope bind! lookup]] - [tock.compiler.meander :refer [bottom-up all-subexpressions m+ merge-metafield]])) + [tock.compiler.meander :refer [bottom-up all-subexpressions m+ merge-metafield] :include-macros true])) (defn decorate-ctx [specials ctx form] (let [special (get-special specials form) diff --git a/src/main/tock/compiler/meander.cljc b/src/main/tock/compiler/meander.cljc index 51095d5..b43b3ed 100644 --- a/src/main/tock/compiler/meander.cljc +++ b/src/main/tock/compiler/meander.cljc @@ -9,7 +9,8 @@ (list? form) (apply list (first form) (merge (second form) m) (rest (rest form))) :else (do (print "m+ " form meta "\n") form))) -(m/defsyntax m+ [meta-pattern pattern] +(m/defsyntax m+ + [meta-pattern pattern] (case (::r.syntax/phase &env) :meander/substitute `(m/app merge-metafield ~pattern ~meta-pattern) :meander/match `(m/and (_ ~meta-pattern . _ ...) ~pattern) @@ -48,4 +49,4 @@ (defn bottom-up [s] (fn rec [t] - ((r/pipe s (all-subexpressions rec)) t))) + ((r/pipe (all-subexpressions rec) s) t))) diff --git a/src/main/tock/compiler/specials.cljc b/src/main/tock/compiler/specials.cljc index 4622c53..584214e 100644 --- a/src/main/tock/compiler/specials.cljc +++ b/src/main/tock/compiler/specials.cljc @@ -57,7 +57,7 @@ ('l/fn (m/app merge ?m {:type ['fn . !types ... 'void] :params [!names ...]}) ('do {} & ?body))) - :typecheck (r/rewrite ({:type ['fn . _ ... ?return-type]} _) [[?return-type ?return-type]]) + :typecheck (r/rewrite ({:type (m/and ?fn-type ['fn . _ ... ?return-type])} _) [[?fn-type ?return-type]]) :scope {:local-counter 0 :valid-binding-forms #{'l/local 'l/param}} :new-bindings (fn [form _ctx] (into {} (map-indexed (fn [index [name type]] [name (list 'l/param {:type type :name name :index index})]) @@ -89,10 +89,10 @@ 'do {:typecheck (r/rewrite (_) [['void]] (_ . !stmt ... ?last) [[?last . (m/app (constantly 'void) !stmt) ... ?last]]) :scope {}} - 'l/lookup {:typecheck (r/rewrite ({:type ?type}) [[?type]])} - 'l/local {:typecheck (r/rewrite ({:type ?type}) [[?type]])} - 'l/param {:typecheck (r/rewrite ({:type ?type}) [[?type]])} - 'l/lit {:typecheck (r/rewrite ({:type ?type}) [[?type]])} + 'l/lookup {} + 'l/local {} + 'l/param {} + 'l/lit {} 'l/call {:typecheck (r/rewrite (_ (m/and ['fn . !param-types ... ?return-type] ?fn-type) . _ ...) [[?return-type ?fn-type . !param-types ...]])} diff --git a/src/main/tock/compiler/type.cljc b/src/main/tock/compiler/type.cljc index 10221bd..904fe9e 100644 --- a/src/main/tock/compiler/type.cljc +++ b/src/main/tock/compiler/type.cljc @@ -1,39 +1,59 @@ (ns tock.compiler.type (:require [meander.epsilon :as m] - [tock.compiler.util :refer [bind! compile-error lookup new-scope] :as u])) - -; once we've hit the typechecking stage, nodes in our expression tree are maps, where each node has at least :special -; and :args keys. :special is a symbol corresponding to a record in the `specials` map; :args is an ordered list of -; subexpressions. a node may optionally contain a :type field as well. + [meander.strategy.epsilon :as r] + [tock.compiler.meander :refer [bottom-up m+] :include-macros true] + [tock.compiler.util :refer [lookup get-meta get-special lookup update-binding!]])) ; typechecking happens bottom-up. by the time a node is called to be typechecked, the system has verified that all of the children ; under :args will have a :type field. -; there are two type syntaxes: +; desugared type syntax is either a bare symbol (ie. 'void, 'i64), or for parameterized types, a dynamic variant stored as a vector +; (ie ['fn arg-type arg-type return-type]). -; 1. internal syntax - always stored in a form's metadata under the :type key. fetched with `expr-type`, added by -; `decorate-type`. generally is either a bare symbol, or for parameterized types, a dynamic -; variant stored as a vector, like ['fn type type type]. +; each special has an associated typechecking function, under the :typecheck key. This function is passed a list, where the first +; element is the metadata map for the special, and the following elements are the types of the subexpression. It must return a +; vector of possible valid typings for the expression. A typing is a vector where the first element is the type of the parent +; expression, and each subsequent element corresponds to a type that the corresponding subexpression should be coerced to. -; 2. input syntax - stored in metadata with ^{} prefix syntax. converted to tock's internal syntax with `syntax-type`. -; generally, type names are stored as {:tag 'name}, and parameterized types like ['enum ...] are -; written in the input as ^{enum [...]}. (if there is only one parameter, the vector is skipped). -; The desugaring process handles this conversion. +; if no :typecheck key is specified, it is assumed that there are no subexpressions and the type should already be present in +; the metadata, or that the form is a binding lookup and the type can be read from context +(def default-typechecker + (r/rewrite + ({:ctx ?ctx :name ?name}) [[(m/app #(get-meta (lookup %1 %2) :type) ?ctx ?name)]] + ({:type ?type}) [[?type]])) -;; built-in types +(defn coerce [expr to-type] + (m/rewrite [(get-meta expr :type) to-type] + [?t ?t] ~expr + [_ 'void] ('l/cast {:type 'void} ~expr) + _ (m+ {:type-mismatch ~to-type} ~expr))) -;; (defn make-type [symbol] (fn [expr] (assoc-type expr symbol))) -;; (def void (make-type 'void)) -;; (def f64 (make-type 'f64)) -;; (def bool (make-type 'bool)) +(defn coerce-form [form typing] + (m/rewrite [form typing] + [(?special ?m . !subexprs ...) [?result-type . !types ...]] + (?special {:type ?result-type & ?m} . (m/app coerce !subexprs !types) ...))) -;; typechecking helpers -(defn coerce [expr typesym error] - (let [ltype (expr-type expr)] - (cond (= ltype typesym) expr - (= typesym 'void) (void `(u/cast-void ~expr)) - :else (throw error)))) +(defn typecheck-expr [form specials] + (let [special (get-special specials form) + typechecker (or (:typecheck special) default-typechecker) + input (m/rewrite form (_ ?m . (m/and (_ {:type !subtype} . _ ...) _) ...) (?m . !subtype ...)) + _ (print (first form) input) + typings (typechecker input) + rewrites (map #(coerce-form form %) typings) + valid-rewrites (filter #(nil? (get-meta % :type-mismatch)) rewrites) + rewrite (or (first valid-rewrites) (first rewrites))] + + ; propogate type back to binding + (m/match rewrite + (m+ {:ctx ?ctx :name ?name :type ?type} _) + (update-binding! ?ctx ?name assoc :type ?type) + _ nil) + + rewrite)) + +(defn typecheck [form specials] + ((bottom-up #(typecheck-expr % specials)) form)) ;; The typechecker itself! ;; This is currently doing several jobs at once: @@ -52,28 +72,28 @@ ;; External syntax uses simple namespaceless 'symbols, internal syntax uses `u/symbols ; todo: actually validate types -(defn validate-type [type] type) +;; (defn validate-type [type] type) -; (fn [^type name ^type name -> return-type] body) -(defn alloc-local [ctx] - (swap! (lookup ctx ::u/lastlocal) inc)) +;; ; (fn [^type name ^type name -> return-type] body) +;; (defn alloc-local [ctx] +;; (swap! (lookup ctx ::u/lastlocal) inc)) -; todo: must store function metadata globally -(defn alloc-func [ctx func-type func-body] - (let [funcs (swap! (lookup ctx ::u/module-funcs) - (fn [funcs] - (conj funcs {:type func-type :body func-body})))] - (- (count funcs) 1))) +;; ; todo: must store function metadata globally +;; (defn alloc-func [ctx func-type func-body] +;; (let [funcs (swap! (lookup ctx ::u/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 return-type] - (doseq [name names] (bind-param! name (syntax-type (meta name) ctx (compile-error name "Expected explicit type")))) - (apply vector (concat ['fn] - (map #(syntax-type (meta %) ctx nil) names) - [(syntax-type return-type ctx (compile-error return-type "Invalid return type"))])))] - (m/match params - [!name ... '-> ?return-type] (bind-all! !name ?return-type) - [!name ...] (bind-all! !name 'void)))) +;; (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 return-type] +;; (doseq [name names] (bind-param! name (syntax-type (meta name) ctx (compile-error name "Expected explicit type")))) +;; (apply vector (concat ['fn] +;; (map #(syntax-type (meta %) ctx nil) names) +;; [(syntax-type return-type ctx (compile-error return-type "Invalid return type"))])))] +;; (m/match params +;; [!name ... '-> ?return-type] (bind-all! !name ?return-type) +;; [!name ...] (bind-all! !name 'void))))