From 36ba345de7e20ad1a51f5ab05ce10931dba04771 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 8 Apr 2015 20:27:38 -0400 Subject: - Renamed exec to |do. - :let within |do now uses |let instead of let. - The analyser now does totality analysis and structures the pattern matching, with the compiler only compiling the generated structures. - Local bindings with case' can now be prefixed arbitrarily. (Note: must do the same with functions). --- src/lux/analyser.clj | 8 +- src/lux/analyser/base.clj | 10 +- src/lux/analyser/case.clj | 237 +++++++++++++++++++++++++++++---- src/lux/analyser/def.clj | 2 +- src/lux/analyser/env.clj | 3 +- src/lux/analyser/host.clj | 52 ++++---- src/lux/analyser/lambda.clj | 6 +- src/lux/analyser/lux.clj | 309 ++++++++++++++++++++------------------------ src/lux/base.clj | 43 ++++-- src/lux/compiler.clj | 16 +-- src/lux/compiler/base.clj | 6 +- src/lux/compiler/case.clj | 129 ++++++------------ src/lux/compiler/host.clj | 68 +++++----- src/lux/compiler/lambda.clj | 8 +- src/lux/compiler/lux.clj | 30 ++--- src/lux/host.clj | 10 +- src/lux/lexer.clj | 42 +++--- src/lux/optimizer.clj | 2 + src/lux/parser.clj | 14 +- src/lux/reader.clj | 2 +- src/lux/type.clj | 172 +++++++++++++----------- 21 files changed, 665 insertions(+), 504 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 80f2cd252..c56f3c053 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -2,7 +2,7 @@ (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return fail |list]] + (lux [base :as & :refer [|do return fail |list]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -68,8 +68,8 @@ (&&lux/analyse-symbol analyse exo-type ?ident) [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "case'"]]]] - ["lux;Cons" [?variant ?branches]]]]]]]] - (&&lux/analyse-case analyse ?variant ?branches) + ["lux;Cons" [?value ?branches]]]]]]]] + (&&lux/analyse-case analyse exo-type ?value ?branches) [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "lambda'"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?self]]]] @@ -444,5 +444,5 @@ ;; [Resources] (defn analyse [eval!] - (exec [asts &parser/parse] + (|do [asts &parser/parse] (&/flat-map% (partial analyse-ast eval! &type/Nothing) asts))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 62ccedb51..b287b545f 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -1,7 +1,7 @@ (ns lux.analyser.base (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return fail]] + (lux [base :as & :refer [|do return fail]] [type :as &type]))) ;; [Resources] @@ -17,7 +17,7 @@ (fail (str "[Analyser Error] Can't retrieve the type of a statement: " (pr-str syntax+))))) (defn analyse-1 [analyse exo-type elem] - (exec [output (analyse exo-type elem)] + (|do [output (analyse exo-type elem)] (do ;; (prn 'analyse-1 (aget output 0)) (matchv ::M/objects [output] [["lux;Cons" [x ["lux;Nil" _]]]] @@ -27,7 +27,7 @@ (fail "[Analyser Error] Can't expand to other than 1 element."))))) (defn analyse-2 [analyse el1 el2] - (exec [output (&/flat-map% analyse (&/|list el1 el2))] + (|do [output (&/flat-map% analyse (&/|list el1 el2))] (do ;; (prn 'analyse-2 (aget output 0)) (matchv ::M/objects [output] [["lux;Cons" [x ["lux;Cons" [y ["lux;Nil" _]]]]]] @@ -37,9 +37,9 @@ (fail "[Analyser Error] Can't expand to other than 2 elements."))))) (defn with-var [k] - (exec [=var &type/fresh-var + (|do [=var &type/fresh-var =ret (k =var)] (matchv ::M/objects [=ret] [["Expression" [?expr ?type]]] - (exec [=type (&type/clean =var ?type)] + (|do [=type (&type/clean =var ?type)] (return (&/V "Expression" (&/T ?expr =type))))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f6a0b2cc8..0c9c55cf8 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -1,36 +1,225 @@ (ns lux.analyser.case (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return fail |let]] + (lux [base :as & :refer [|do return fail |let]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] [env :as &env]))) -;; [Resources] -(defn locals [member] - (matchv ::M/objects [member] - [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]]] - (&/|list ?name) +;; [Utils] +(defn ^:private analyse-variant [analyse-pattern idx value-type tag value] + (|do [=var &type/fresh-var + _ (&type/check value-type (&/V "lux;VariantT" (&/|list (&/T tag =var)))) + [idx* test] (analyse-pattern idx =var value)] + (return (&/T idx* (&/V "VariantTestAC" (&/T tag test)))))) - [["lux;Meta" [_ ["lux;Tuple" ?submembers]]]] - (&/flat-map locals ?submembers) +(defn ^:private analyse-pattern [idx value-type pattern] + (prn 'analyse-pattern/pattern (aget pattern 0) (aget pattern 1) (alength (aget pattern 1))) + (matchv ::M/objects [pattern] + [["lux;Meta" [_ pattern*]]] + ;; (assert false) + (do (prn 'analyse-pattern/pattern* (aget pattern* 0)) + (matchv ::M/objects [pattern*] + [["lux;Symbol" [?module ?name]]] + (return (&/T (inc idx) (&/V "StoreTestAC" (&/T idx (str ?module ";" ?name) value-type)))) - [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" _]]] ?submembers]]]]]] - (&/flat-map locals ?submembers) + [["lux;Bool" ?value]] + (|do [_ (&type/check value-type &type/Bool)] + (return (&/T idx (&/V "BoolTestAC" ?value)))) + [["lux;Int" ?value]] + (|do [_ (&type/check value-type &type/Int)] + (return (&/T idx (&/V "IntTestAC" ?value)))) + + [["lux;Real" ?value]] + (|do [_ (&type/check value-type &type/Real)] + (return (&/T idx (&/V "RealTestAC" ?value)))) + + [["lux;Char" ?value]] + (|do [_ (&type/check value-type &type/Char)] + (return (&/T idx (&/V "CharTestAC" ?value)))) + + [["lux;Text" ?value]] + (|do [_ (&type/check value-type &type/Text)] + (return (&/T idx (&/V "TextTestAC" ?value)))) + + [["lux;Tuple" ?members]] + (|do [=vars (&/map% (fn [_] &type/fresh-var) + (&/|range (&/|length ?members))) + _ (&type/check value-type (&/V "lux;TupleT" =vars)) + [idx* tests] (&/fold% (fn [idx+subs mv] + (|let [[idx subs] idx+subs + [?member ?var] mv] + (|do [[idx* test] (analyse-pattern idx ?var ?member)] + (return (&/T idx* (&/|cons test subs)))))) + (&/T idx (&/|list)) + (&/zip2 ?members =vars))] + (return (&/T idx* (&/V "TupleTestAC" (&/|reverse tests))))) + + [["lux;Record" ?fields]] + (|do [=vars (&/map% (fn [_] &type/fresh-var) + (&/|range (&/|length ?fields))) + _ (&type/check value-type (&/V "lux;RecordT" (&/zip2 (&/|keys ?fields) =vars))) + tests (&/fold% (fn [idx+subs mv] + (|let [[idx subs] idx+subs + [[slot value] ?var] mv] + (|do [[idx* test] (analyse-pattern idx ?var value)] + (return (&/T idx* (&/|cons (&/T slot test) subs)))))) + (&/T idx (&/|list)) (&/zip2 ?fields =vars))] + (return (&/V "RecordTestAC" tests))) + + [["lux;Tag" ?tag]] + (analyse-variant analyse-pattern idx value-type ?tag (&/V "lus;Meta" (&/T (&/T "" -1 -1) + (&/V "lux;Tuple" (&/|list))))) + + [["lux;Form" ["lux;Cons" [["lus;Meta" [_ ["lux;Tag" ?tag]]] + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]] + (analyse-variant analyse-pattern idx value-type ?tag ?value) + )) + )) + +(defn ^:private with-test [test body] + (matchv ::M/objects [test] + [["StoreTestAC" [?idx ?name ?type]]] + (&env/with-local ?name ?type + body) + + [["TupleTestAC" ?tests]] + (&/fold #(with-test %2 %1) body (&/|reverse ?tests)) + + [["RecordTestAC" ?tests]] + (&/fold #(with-test %2 %1) body (&/|reverse (&/|vals ?tests))) + + [["VariantTestAC" [?tag ?value]]] + (with-test ?value body) + [_] - (&/|list))) - -(defn analyse-branch [analyse max-registers bindings+body] - (|let [[bindings body] bindings+body] - (do ;; (prn 'analyse-branch max-registers (&/->seq bindings) body) - (&/fold (fn [body* name] - (&&/with-var - (fn [=var] - (&env/with-local name =var body*)))) - (&/fold (fn [body* _] - (&env/with-local "" &type/+dont-care+ body*)) - (&&/analyse-1 analyse body) - (&/|range (- max-registers (&/|length bindings)))) - (&/|reverse bindings))))) + body + )) + +(defn ^:private analyse-branch [analyse exo-type value-type pattern body match] + (|do [idx &env/next-local-idx + [idx* =test] (analyse-pattern idx value-type pattern) + =body (with-test =test + (&&/analyse-1 analyse exo-type body))] + (matchv ::M/objects [match] + [["MatchAC" ?patterns]] + (return (&/V "MatchAC" (&/|cons (&/T =test =body) ?patterns)))))) + +(let [compare-kv #(compare (aget %1 0) (aget %2 0))] + (defn ^:private merge-total [struct test+body] + (prn 'merge-total (aget struct 0) (aget test+body 0 0)) + (matchv ::M/objects [test+body] + [[test _]] + (matchv ::M/objects [struct test] + [["DefaultTotal" total?] ["StoreTestAC" [?idx ?name type]]] + (return (&/V "DefaultTotal" true)) + + [[?tag [total? ?values]] ["StoreTestAC" [?idx ?name type]]] + (return (&/V ?tag (&/T true ?values))) + + [["DefaultTotal" total?] ["BoolTestAC" ?value]] + (return (&/V "BoolTotal" (&/T total? (&/|list ?value)))) + + [["BoolTotal" [total? ?values]] ["BoolTestAC" ?value]] + (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values)))) + + [["DefaultTotal" total?] ["IntTestAC" ?value]] + (return (&/V "IntTotal" (&/T total? (&/|list ?value)))) + + [["IntTotal" [total? ?values]] ["IntTestAC" ?value]] + (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values)))) + + [["DefaultTotal" total?] ["RealTestAC" ?value]] + (return (&/V "RealTotal" (&/T total? (&/|list ?value)))) + + [["RealTotal" [total? ?values]] ["RealTestAC" ?value]] + (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values)))) + + [["DefaultTotal" total?] ["CharTestAC" ?value]] + (return (&/V "CharTotal" (&/T total? (&/|list ?value)))) + + [["CharTotal" [total? ?values]] ["CharTestAC" ?value]] + (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values)))) + + [["DefaultTotal" total?] ["TextTestAC" ?value]] + (return (&/V "TextTotal" (&/T total? (&/|list ?value)))) + + [["TextTotal" [total? ?values]] ["TextTestAC" ?value]] + (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values)))) + + [["DefaultTotal" total?] ["TupleTestAC" ?tests]] + (|do [structs (&/map% (fn [t] + (merge-total (&/V "DefaultTotal" total?) t)) + ?tests)] + (return (&/V "TupleTotal" (&/T total? structs)))) + + [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] + (if (= (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map% (fn [vt] + (|let [[v t] vt] + (merge-total v t))) + (&/zip2 ?values ?tests))] + (return (&/V "TupleTotal" (&/T total? structs)))) + (fail "[Pattern-matching error] Inconsistent tuple-size.")) + + [["DefaultTotal" total?] ["RecordTestAC" ?tests]] + (|do [structs (&/map% (fn [t] + (|let [[slot value] t] + (|do [struct (merge-total (&/V "DefaultTotal" total?) value)] + (return (&/T slot struct))))) + (sort compare-kv ?tests))] + (return (&/V "RecordTotal" (&/T total? structs)))) + + [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] + (if (= (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map% (fn [lr] + (|let [[[lslot struct] [rslot value]] lr] + (if (= lslot rslot) + (|do [struct (merge-total (&/V "DefaultTotal" total?) value)] + (return (&/T lslot struct))) + (fail "[Pattern-matching error] Record slots mismatch.")))) + (&/zip2 ?values + (sort compare-kv ?tests)))] + (return (&/V "RecordTotal" (&/T total? structs)))) + (fail "[Pattern-matching error] Inconsistent record-size.")) + + [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] + (|do [struct (merge-total (&/V "DefaultTotal" total?) ?test)] + (return (&/V "VariantTotal" (&/T total? (&/|list (&/T ?tag struct)))))) + + [["VariantTotal" [total? ?branches]] ["VariantTestAC" [?tag ?test]]] + (|do [struct (merge-total (or (&/|get ?tag ?branches) + (&/V "DefaultTotal" total?)) + ?test)] + (return (&/V "VariantTotal" (&/T total? (&/|put ?tag struct ?branches))))) + )))) + +(defn ^:private totality-struct [owner-total? match] + (let [msg "Pattern matching is non-total"] + (matchv ::M/objects [match] + [["MatchAC" ?tests]] + (&/fold% merge-total (&/V "DefaultTotal" false) ?tests)))) + +(defn ^:private check-totality [value-type struct] + (prn 'check-totality (aget value-type 0) (aget struct 0) (&type/show-type value-type)) + (matchv ::M/objects [value-type struct] + [_ ["DefaultTotal" true]] + true + )) + +;; [Exports] +(defn analyse-branches [analyse exo-type value-type branches] + (|do [=match (&/fold% (fn [match branch] + (|let [[pattern body] branch] + (analyse-branch analyse exo-type value-type pattern body match))) + (&/V "MatchAC" (&/|list)) + branches) + struct (totality-struct false =match)] + (matchv ::M/objects [=match] + [["MatchAC" ?tests]] + (if (check-totality value-type struct) + (return (&/V "MatchAC" (&/|reverse ?tests))) + (fail "[Pattern-maching error] Pattern-matching is non-total."))))) diff --git a/src/lux/analyser/def.clj b/src/lux/analyser/def.clj index 2a9b181e2..eb637f66b 100644 --- a/src/lux/analyser/def.clj +++ b/src/lux/analyser/def.clj @@ -2,7 +2,7 @@ (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return return* fail]]) + (lux [base :as & :refer [|do return return* fail]]) [lux.analyser.base :as &&])) ;; [Exports] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 4f772e126..454d8ad6c 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -1,7 +1,7 @@ (ns lux.analyser.env (:require [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return return* fail]]) + (lux [base :as & :refer [|do return return* fail]]) [lux.analyser.base :as &&])) ;; [Exports] @@ -10,6 +10,7 @@ (return* state (->> state (&/get$ "lux;local-envs") &/|head (&/get$ "lux;locals") (&/get$ "lux;counter"))))) (defn with-local [name type body] + (prn 'with-local name) (fn [state] (let [old-mappings (->> state (&/get$ "lux;local-envs") &/|head (&/get$ "lux;locals") (&/get$ "lux;mappings")) =return (body (&/update$ "lux;local-envs" diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index cfc79c0b3..6fce672de 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -2,7 +2,7 @@ (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return fail]] + (lux [base :as & :refer [|do return fail]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -23,11 +23,11 @@ (let [input-type (&/V "lux;DataT" (to-array [ (&/V "lux;Nil" nil)])) output-type (&/V "lux;DataT" (to-array [ (&/V "lux;Nil" nil)]))] (defn [analyse ?x ?y] - (exec [[=x =y] (&&/analyse-2 analyse ?x ?y) + (|do [[=x =y] (&&/analyse-2 analyse ?x ?y) =x-type (&&/expr-type =x) =y-type (&&/expr-type =y) - _ (&type/solve input-type =x-type) - _ (&type/solve input-type =y-type)] + _ (&type/check input-type =x-type) + _ (&type/check input-type =y-type)] (return (&/|list (&/V "Expression" (&/T (&/V (&/T =x =y)) output-type))))))) analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer" @@ -68,7 +68,7 @@ ) (defn analyse-jvm-getstatic [analyse ?class ?field] - (exec [=class (&host/full-class-name ?class) + (|do [=class (&host/full-class-name ?class) ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)] =type (&host/lookup-static-field =class ?field) ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)] @@ -76,13 +76,13 @@ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-getstatic" (&/T =class ?field)) =type)))))) (defn analyse-jvm-getfield [analyse ?class ?field ?object] - (exec [=class (&host/full-class-name ?class) + (|do [=class (&host/full-class-name ?class) =type (&host/lookup-static-field =class ?field) =object (&&/analyse-1 analyse ?object)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-getfield" (&/T =class ?field =object)) =type)))))) (defn analyse-jvm-putstatic [analyse ?class ?field ?value] - (exec [=class (&host/full-class-name ?class) + (|do [=class (&host/full-class-name ?class) ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)] =type (&host/lookup-static-field =class ?field) ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)] @@ -90,14 +90,14 @@ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-putstatic" (&/T =class ?field =value)) =type)))))) (defn analyse-jvm-putfield [analyse ?class ?field ?object ?value] - (exec [=class (&host/full-class-name ?class) + (|do [=class (&host/full-class-name ?class) =type (&host/lookup-static-field =class ?field) =object (&&/analyse-1 analyse ?object) =value (&&/analyse-1 analyse ?value)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-putfield" (&/T =class ?field =object =value)) =type)))))) (defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] - (exec [=class (&host/full-class-name ?class) + (|do [=class (&host/full-class-name ?class) =classes (&/map% &host/extract-jvm-param ?classes) =return (&host/lookup-static-method =class ?method =classes) =args (&/flat-map% analyse ?args)] @@ -106,7 +106,7 @@ (do-template [ ] (defn [analyse ?class ?method ?classes ?object ?args] ;; (prn ' ?class ?method) - (exec [=class (&host/full-class-name ?class) + (|do [=class (&host/full-class-name ?class) ;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)] =classes (&/map% &host/extract-jvm-param ?classes) ;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)] @@ -125,22 +125,22 @@ ) (defn analyse-jvm-null? [analyse ?object] - (exec [=object (&&/analyse-1 analyse ?object)] + (|do [=object (&&/analyse-1 analyse ?object)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" (&/T "java.lang.Boolean" (&/V "lux;Nil" nil))))))))) (defn analyse-jvm-new [analyse ?class ?classes ?args] - (exec [=class (&host/full-class-name ?class) + (|do [=class (&host/full-class-name ?class) =classes (&/map% &host/extract-jvm-param ?classes) =args (&/flat-map% analyse ?args)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-new" (&/T =class =classes =args)) (&/V "lux;DataT" (&/T =class (&/V "lux;Nil" nil))))))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (exec [=class (&host/full-class-name ?class)] + (|do [=class (&host/full-class-name ?class)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-new-array" (&/T =class ?length)) (&/V "array" (&/T (&/V "lux;DataT" (to-array [=class (&/V "lux;Nil" nil)])) (&/V "lux;Nil" nil))))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] - (exec [=array+=elem (&&/analyse-2 analyse ?array ?elem) + (|do [=array+=elem (&&/analyse-2 analyse ?array ?elem) :let [[=array =elem] (matchv ::M/objects [=array+=elem] [[=array =elem]] [=array =elem])] @@ -148,12 +148,12 @@ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-aastore" (&/T =array ?idx =elem)) =array-type)))))) (defn analyse-jvm-aaload [analyse ?array ?idx] - (exec [=array (&&/analyse-1 analyse ?array) + (|do [=array (&&/analyse-1 analyse ?array) =array-type (&&/expr-type =array)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type)))))) (defn analyse-jvm-class [analyse ?name ?super-class ?fields] - (exec [?fields (&/map% (fn [?field] + (|do [?fields (&/map% (fn [?field] (matchv ::M/objects [?field] [["lux;Meta" [_ ["lux;Tuple" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?field-name]]] @@ -171,7 +171,7 @@ (defn analyse-jvm-interface [analyse ?name ?members] ;; (prn 'analyse-jvm-interface ?name ?members) - (exec [=members (&/map% (fn [member] + (|do [=members (&/map% (fn [member] ;; (prn 'analyse-jvm-interface (&/show-ast member)) (matchv ::M/objects [member] [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":"]]]] @@ -182,7 +182,7 @@ ["lux;Nil" _]]]]]]]]]] ["lux;Nil" _]]]]]]]]]]] (do ;; (prn 'analyse-jvm-interface ?member-name ?inputs ?output) - (exec [?inputs (&/map% extract-ident ?inputs)] + (|do [?inputs (&/map% extract-ident ?inputs)] (return [?member-name [?inputs ?output]]))) [_] @@ -196,10 +196,10 @@ (return (&/|list (&/V "Statement" (&/V "jvm-interface" (&/T $module ?name =methods))))))) (defn analyse-jvm-try [analyse ?body [?catches ?finally]] - (exec [=body (&&/analyse-1 analyse ?body) + (|do [=body (&&/analyse-1 analyse ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] (&&env/with-local ?ex-arg (&/V "lux;DataT" (&/T ?ex-class (&/V "lux;Nil" nil))) - (exec [=catch-body (&&/analyse-1 analyse ?catch-body)] + (|do [=catch-body (&&/analyse-1 analyse ?catch-body)] (return [?ex-class ?ex-arg =catch-body])))) ?catches) =finally (&&/analyse-1 analyse ?finally) @@ -207,20 +207,20 @@ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-try" (&/T =body =catches =finally)) =body-type)))))) (defn analyse-jvm-throw [analyse ?ex] - (exec [=ex (&&/analyse-1 analyse ?ex)] + (|do [=ex (&&/analyse-1 analyse ?ex)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-throw" =ex) (&/V "lux;NothingT" nil))))))) (defn analyse-jvm-monitorenter [analyse ?monitor] - (exec [=monitor (&&/analyse-1 analyse ?monitor)] + (|do [=monitor (&&/analyse-1 analyse ?monitor)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-monitorenter" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil)))))))) (defn analyse-jvm-monitorexit [analyse ?monitor] - (exec [=monitor (&&/analyse-1 analyse ?monitor)] + (|do [=monitor (&&/analyse-1 analyse ?monitor)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-monitorexit" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil)))))))) (do-template [ ] (defn [analyse ?value] - (exec [=value (&&/analyse-1 analyse ?value)] + (|do [=value (&&/analyse-1 analyse ?value)] (return (&/|list (&/V "Expression" (&/T (&/V =value) (&/V "lux;DataT" (&/T (&/V "lux;Nil" nil))))))))) analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float" @@ -245,7 +245,7 @@ (do-template [ ] (defn [analyse ?value] - (exec [=value (&&/analyse-1 analyse ?value)] + (|do [=value (&&/analyse-1 analyse ?value)] (return (&/|list (&/V "Expression" (&/T (&/V =value) (&/V "lux;DataT" (&/T (&/V "lux;Nil" nil))))))))) analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" @@ -261,6 +261,6 @@ ) (defn analyse-jvm-program [analyse ?args ?body] - (exec [=body (&&env/with-local ?args (&/V "lux;AnyT" nil) + (|do [=body (&&env/with-local ?args (&/V "lux;AnyT" nil) (&&/analyse-1 analyse ?body))] (return (&/|list (&/V "Statement" (&/V "jvm-program" =body)))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index c4d218c18..e12b22005 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -1,17 +1,17 @@ (ns lux.analyser.lambda (:require [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return fail]]) + (lux [base :as & :refer [|do return fail]]) (lux.analyser [base :as &&] [env :as &env]))) ;; [Resource] (defn with-lambda [self self-type arg arg-type body] (&/with-closure - (exec [scope-name &/get-scope-name] + (|do [scope-name &/get-scope-name] (&env/with-local self self-type (&env/with-local arg arg-type - (exec [=return body + (|do [=return body =captured &env/captured-vars] (return (&/T scope-name =captured =return)))))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index e38d10117..119e77826 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -2,7 +2,7 @@ (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return return* fail fail* |let |list]] + (lux [base :as & :refer [|do return return* fail fail* |let |list]] [parser :as &parser] [type :as &type] [macro :as ¯o] @@ -19,206 +19,183 @@ ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - (exec [=elems (&/map% (analyse-1+ analyse) ?elems) - =elems-types (&/map% &&/expr-type =elems) - ;; :let [_ (prn 'analyse-tuple =elems)] - :let [endo-type (&/V "lux;TupleT" =elems-types)] - _ (&type/solve exo-type endo-type) - ;; :let [_ (prn 'analyse-tuple 'DONE)] - ] + (|do [=elems (&/map% (analyse-1+ analyse) ?elems) + =elems-types (&/map% &&/expr-type =elems) + ;; :let [_ (prn 'analyse-tuple =elems)] + :let [endo-type (&/V "lux;TupleT" =elems-types)] + _ (&type/check exo-type endo-type) + ;; :let [_ (prn 'analyse-tuple 'DONE)] + ] (return (&/|list (&/V "Expression" (&/T (&/V "tuple" =elems) exo-type)))))) (defn analyse-variant [analyse exo-type ident ?value] - (|let [[?module ?name] ident - ?tag (str ?module ";" ?name)] - (exec [=value ((analyse-1+ analyse) ?value) - =value-type (&&/expr-type =value) - :let [endo-type (&/V "lux;VariantT" (|list (&/T ?tag =value-type)))] - _ (&type/solve exo-type endo-type) - ;; :let [_ (prn 'analyse-variant 'DONE)] - ] + (|let [[?module ?name] ident] + (|do [module (if (= "" ?module) + &/get-module-name + (return ?module)) + :let [?tag (str module ";" ?name)] + =value ((analyse-1+ analyse) ?value) + =value-type (&&/expr-type =value) + :let [endo-type (&/V "lux;VariantT" (|list (&/T ?tag =value-type)))] + _ (&type/check exo-type endo-type) + ;; :let [_ (prn 'analyse-variant 'DONE)] + ] (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag =value)) exo-type))))))) (defn analyse-record [analyse exo-type ?elems] - (exec [=elems (&/map% (fn [kv] - (matchv ::M/objects [kv] - [[k v]] - (exec [=v (&&/analyse-1 analyse v)] - (return (to-array [k =v]))))) - ?elems) - =elems-types (&/map% (fn [kv] - (matchv ::M/objects [kv] - [[k v]] - (exec [=v (&&/expr-type v)] - (return (to-array [k =v]))))) - =elems) - ;; :let [_ (prn 'analyse-tuple =elems)] - ] + (|do [=elems (&/map% (fn [kv] + (matchv ::M/objects [kv] + [[k v]] + (|do [=v (&&/analyse-1 analyse v)] + (return (to-array [k =v]))))) + ?elems) + =elems-types (&/map% (fn [kv] + (matchv ::M/objects [kv] + [[k v]] + (|do [module (if (= "" k) + &/get-module-name + (return k)) + =v (&&/expr-type v)] + (return (to-array [module =v]))))) + =elems) + ;; :let [_ (prn 'analyse-tuple =elems)] + ] (return (&/|list (&/V "Expression" (&/T (&/V "lux;record" =elems) (&/V "lux;RecordT" =elems-types))))))) (defn analyse-symbol [analyse exo-type ident] - (|let [[?module ?name] ident] - (do ;; (prn 'analyse-ident ?module ?name) - (exec [module-name &/get-module-name] - (fn [state] - ;; (when (and (= "lux" ?module) - ;; (= "output" ?name)) - ;; (prn (&/show-state state))) - ;; (prn 'module-name module-name) - ;; (prn '(&/get$ "local-envs" state) (&/get$ "local-envs" state)) - ;; (prn '(&/->seq (&/get$ "local-envs" state)) (&/->seq (&/get$ "local-envs" state))) - ;; (println (&/show-state state)) - (|let [stack (&/get$ "lux;local-envs" state) - no-binding? #(and (->> % (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|contains? ?name) not) - (->> % (&/get$ "lux;closure") (&/get$ "lux;mappings") (&/|contains? ?name) not)) - [inner outer] (&/|split-with no-binding? stack)] - (matchv ::M/objects [outer] - [["lux;Nil" _]] - (|let [[?module ?name] ident - ident* (str ?module ";" ?name)] - (if-let [global (->> state (&/get$ "lux;global-env") &/from-some (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|get ident*))] - (&/run-state (exec [=global-type (&&/expr-type global) - _ (&type/solve exo-type =global-type)] - (return (&/|list global))) - state) - (fail* (str "[Analyser Error] Unresolved identifier: " ident*)))) - - [["lux;Cons" [top-outer _]]] - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ "lux;name" %2) %1) - (&/|map #(&/get$ "lux;name" %) outer) - (&/|reverse inner))) - ;; _ (prn 'inner module-name ident (&/->seq (&/|map #(&/get$ "name" %) inner)) scopes) - [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] - (|let [[register new-inner] register+new-inner - [frame in-scope] frame+in-scope - [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ?name register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|get ?name)) - (->> top-outer (&/get$ "lux;closure") (&/get$ "lux;mappings") (&/|get ?name))) - (&/|list)) - (&/zip2 (&/|reverse inner) scopes))] - (return* (&/set$ "lux;local-envs" (&/|++ inner* outer) state) (&/|list =local))) - ))) - )))) + (|do [module-name &/get-module-name] + (fn [state] + (|let [[?module ?name] ident + local-ident (str ?module ";" ?name) + global-ident (str (if (= "" ?module) module-name ?module) ";" ?name) + stack (&/get$ "lux;local-envs" state) + no-binding? #(and (->> % (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|contains? local-ident) not) + (->> % (&/get$ "lux;closure") (&/get$ "lux;mappings") (&/|contains? local-ident) not)) + [inner outer] (&/|split-with no-binding? stack)] + (matchv ::M/objects [outer] + [["lux;Nil" _]] + (if-let [global (->> state (&/get$ "lux;global-env") &/from-some (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|get global-ident))] + (&/run-state (|do [=global-type (&&/expr-type global) + _ (&type/check exo-type =global-type)] + (return (&/|list global))) + state) + (fail* (str "[Analyser Error] Unrecognized identifier: " local-ident))) + + [["lux;Cons" [top-outer _]]] + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ "lux;name" %2) %1) + (&/|map #(&/get$ "lux;name" %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] + (|let [[register new-inner] register+new-inner + [frame in-scope] frame+in-scope + [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ?name register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|get local-ident)) + (->> top-outer (&/get$ "lux;closure") (&/get$ "lux;mappings") (&/|get local-ident))) + (&/|list)) + (&/zip2 (&/|reverse inner) scopes))] + (return* (&/set$ "lux;local-envs" (&/|++ inner* outer) state) (&/|list =local))) + ))) + )) (defn ^:private analyse-apply* [analyse exo-type =fn ?args] - (exec [=args (&/flat-map% analyse ?args) - =fn-type (&&/expr-type =fn) - [=apply _] (&/fold% (fn [[=fn =fn-type] =input] - (exec [;; :let [_ (prn "#2")] - =input-type (&&/expr-type =input) - ;; :let [_ (prn "#3")] - =output-type (&type/apply-lambda =fn-type =input-type) - ;; :let [_ (prn "#4")] - ] - (return [(&/V "Expression" (&/T (&/V "apply" (&/T =fn =input)) - =output-type)) - =output-type]))) - [=fn =fn-type] - =args)] + (|do [=args (&/flat-map% analyse ?args) + =fn-type (&&/expr-type =fn) + [=apply _] (&/fold% (fn [[=fn =fn-type] =input] + (|do [;; :let [_ (prn "#2")] + =input-type (&&/expr-type =input) + ;; :let [_ (prn "#3")] + =output-type (&type/apply-lambda =fn-type =input-type) + ;; :let [_ (prn "#4")] + ] + (return [(&/V "Expression" (&/T (&/V "apply" (&/T =fn =input)) + =output-type)) + =output-type]))) + [=fn =fn-type] + =args)] (return (&/|list =apply)))) (defn analyse-apply [analyse exo-type =fn ?args] ;; (prn 'analyse-apply1 (aget =fn 0)) - (exec [loader &/loader] + (|do [loader &/loader] (matchv ::M/objects [=fn] [["Expression" [=fn-form =fn-type]]] (do ;; (prn 'analyse-apply2 (aget =fn-form 0)) - (matchv ::M/objects [=fn-form] - [["global" [?module ?name]]] - (exec [macro? (&&def/macro? ?module ?name)] - (if macro? - (let [macro-class (&host/location (&/|list ?module ?name))] - (exec [macro-expansion (¯o/expand loader macro-class ?args) - output (&/flat-map% analyse macro-expansion)] - (return output))) - (analyse-apply* analyse =fn ?args))) - - [_] - (analyse-apply* analyse =fn ?args))) + (matchv ::M/objects [=fn-form] + [["global" [?module ?name]]] + (|do [macro? (&&def/macro? ?module ?name)] + (if macro? + (let [macro-class (&host/location (&/|list ?module ?name))] + (|do [macro-expansion (¯o/expand loader macro-class ?args) + output (&/flat-map% analyse macro-expansion)] + (return output))) + (analyse-apply* analyse =fn ?args))) + + [_] + (analyse-apply* analyse =fn ?args))) [_] (fail "[Analyser Error] Can't call a statement!")) )) (defn analyse-case [analyse exo-type ?value ?branches] - ;; (prn 'analyse-case (aget ?branches 0) (aget ?branches 1 1 0) - ;; (&/->seq ?branches)) - ;; (prn 'analyse-case (&/show-ast ?value)) - (exec [:let [num-branches (&/|length ?branches) - ;; _ (prn 'analyse-case ?value (&/|length ?branches) - ;; (and (> num-branches 0) (even? num-branches))) - ] - _ (&/assert! (and (> num-branches 0) (even? num-branches)) - "[Analyser Error] Unbalanced branches in \"case'\" expression.") - :let [branches (&/|as-pairs ?branches) - ;; _ (prn '(&/|length branches) (&/|length branches)) - locals-per-branch (&/|map (comp &&case/locals &/|first) branches) - max-locals (&/fold max 0 (&/|map &/|length locals-per-branch))] - ;; :let [_ (prn '[branches locals-per-branch max-locals] [branches locals-per-branch max-locals])] - base-register &&env/next-local-idx - ;; :let [_ (prn 'base-register base-register)] - =value (&&/analyse-1 analyse ?value) - ;; :let [_ (prn '=value =value)] - =bodies (&/map% (partial &&case/analyse-branch analyse max-locals) - (&/zip2 locals-per-branch (&/|map &/|second branches))) - ;; :let [_ (prn '=bodies =bodies)] - ;; :let [_ (prn 'analyse-case/=bodies =bodies)] - =body-types (&/map% &&/expr-type =bodies) - :let [_ (prn 'analyse-case (->> =body-types (&/|map &type/show-type) (&/|interpose " ") (&/fold str "")))] - =case-type (&/fold% &type/merge (&/V "lux;NothingT" nil) =body-types) - :let [=branches (&/zip2 (&/|map &/|first branches) =bodies)]] - (return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value base-register max-locals =branches)) - =case-type)))))) + (|do [:let [num-branches (&/|length ?branches)] + _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") + _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") + =value ((analyse-1+ analyse) ?value) + =value-type (&&/expr-type =value) + =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] + (return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value =match)) + exo-type)))))) (defn analyse-lambda [analyse exo-type ?self ?arg ?body] ;; (prn 'analyse-lambda ?self ?arg ?body) - (exec [=lambda-type* &type/fresh-lambda] + (|do [=lambda-type* &type/fresh-lambda] (matchv ::M/objects [=lambda-type*] [["lux;LambdaT" [=arg =return]]] - (exec [[=scope =captured =body] (&&lambda/with-lambda ?self =lambda-type* - ?arg =arg - (&&/analyse-1 analyse ?body)) - =body-type (&&/expr-type =body) - ;; _ =body-type - =lambda-type (exec [_ (&type/solve &type/init-fixpoints =return =body-type)] - (&type/clean =return =lambda-type*)) - =bound-arg (&type/lookup =arg) - =lambda-type (matchv ::M/objects [=arg =bound-arg] - [["lux;VarT" id] ["lux;Some" bound]] - (&type/clean =arg =lambda-type) - - [["lux;VarT" id] ["lux;None" _]] - (let [var-name (str (gensym "")) - bound (&/V "lux;BoundT" var-name)] - (exec [_ (&type/reset id bound) - lambda-type (&type/clean =arg =lambda-type)] - (return (&/V "lux;AllT" (&/T (&/|list) "" var-name lambda-type)))))) - ;; :let [_ (prn '=lambda-type =lambda-type)] - ] + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self =lambda-type* + ?arg =arg + (&&/analyse-1 analyse ?body)) + =body-type (&&/expr-type =body) + ;; _ =body-type + =lambda-type (|do [_ (&type/check &type/init-fixpoints =return =body-type)] + (&type/clean =return =lambda-type*)) + =bound-arg (&type/lookup =arg) + =lambda-type (matchv ::M/objects [=arg =bound-arg] + [["lux;VarT" id] ["lux;Some" bound]] + (&type/clean =arg =lambda-type) + + [["lux;VarT" id] ["lux;None" _]] + (let [var-name (str (gensym "")) + bound (&/V "lux;BoundT" var-name)] + (|do [_ (&type/reset id bound) + lambda-type (&type/clean =arg =lambda-type)] + (return (&/V "lux;AllT" (&/T (&/|list) "" var-name lambda-type)))))) + ;; :let [_ (prn '=lambda-type =lambda-type)] + ] (return (&/|list (&/V "Expression" (&/T (&/V "lambda" (&/T =scope =captured ?arg =body)) =lambda-type)))))))) (defn analyse-def [analyse exo-type ?name ?value] ;; (prn 'analyse-def ?name ?value) - (exec [_ (&type/solve &type/Nothing exo-type) - module-name &/get-module-name] + (|do [_ (&type/check &type/Nothing exo-type) + module-name &/get-module-name] (&/if% (&&def/defined? module-name ?name) (fail (str "[Analyser Error] Can't redefine " ?name)) - (exec [=value (&/with-scope ?name - (&&/with-var - #(&&/analyse-1 analyse % ?value))) - =value-type (&&/expr-type =value) - :let [_ (prn 'analyse-def ?name (&type/show-type =value-type))] - _ (&&def/define module-name ?name =value-type)] + (|do [=value (&/with-scope ?name + (&&/with-var + #(&&/analyse-1 analyse % ?value))) + =value-type (&&/expr-type =value) + :let [_ (prn 'analyse-def ?name (&type/show-type =value-type))] + _ (&&def/define module-name ?name =value-type)] (return (&/|list (&/V "Statement" (&/V "def" (&/T ?name =value))))))))) (defn analyse-declare-macro [exo-type ident] (|let [[?module ?name] ident] - (exec [module-name &/get-module-name] + (|do [module-name &/get-module-name] (if (= ?module module-name) - (exec [_ (&&def/declare-macro ?module ?name)] + (|do [_ (&&def/declare-macro ?module ?name)] (return (&/|list))) (fail "Can't declare macros from foreign modules."))))) @@ -228,26 +205,24 @@ (defn analyse-check [analyse eval! exo-type ?type ?value] (println "analyse-check#0") - (exec [=type (&&/analyse-1 analyse &type/Type ?type) + (|do [=type (&&/analyse-1 analyse &type/Type ?type) :let [_ (println "analyse-check#1")] ==type (eval! =type) - _ (&type/solve &type/init-fixpoints exo-type ==type) + _ (&type/check &type/init-fixpoints exo-type ==type) :let [_ (println "analyse-check#4" (&type/show-type ==type))] =value (&&/analyse-1 analyse ==type ?value) :let [_ (println "analyse-check#5")]] (matchv ::M/objects [=value] [["Expression" [?expr ?expr-type]]] - (exec [:let [_ (println "analyse-check#6" (&type/show-type ?expr-type))] - _ (&type/solve &type/init-fixpoints ==type ?expr-type) + (|do [:let [_ (println "analyse-check#6" (&type/show-type ?expr-type))] + _ (&type/check ==type ?expr-type) :let [_ (println "analyse-check#7")]] (return (&/|list (&/V "Expression" (&/T ?expr ==type)))))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] - (exec [=type (&&/analyse-1 analyse ?type) - =type-type (&&/expr-type =type) - _ (&type/solve &type/init-fixpoints &type/Type =type-type) + (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) - =value (&&/analyse-1 analyse ?value)] + =value (&&/analyse-1 analyse ==type ?value)] (matchv ::M/objects [=value] [["Expression" [?expr ?expr-type]]] (return (&/|list (&/V "Expression" (&/T ?expr ==type))))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index cd5801660..a8649816a 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -151,14 +151,21 @@ [["lux;Left" _]] inputs)))) -(defmacro exec [steps return] +(defmacro |do [steps return] (assert (not= 0 (count steps)) "The steps can't be empty!") (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") (reduce (fn [inner [label computation]] (case label - :let `(let ~computation ~inner) + :let `(|let ~computation ~inner) ;; else - `(bind ~computation (fn [~label] ~inner)))) + ;; `(bind ~computation + ;; (fn [val#] + ;; (matchv ::M/objects [val#] + ;; [~label] + ;; ~inner))) + `(bind ~computation + (fn [~label] ~inner)) + )) return (reverse (partition 2 steps)))) @@ -253,7 +260,7 @@ (return init) [["lux;Cons" [x xs*]]] - (exec [init* (f init x)] + (|do [init* (f init x)] (fold% f init* xs*)))) (defn folds [f init xs] @@ -299,6 +306,14 @@ [["lux;Cons" [[k v] plist*]]] (|cons k (|keys plist*)))) +(defn |vals [plist] + (matchv ::M/objects [plist] + [["lux;Nil" _]] + (|list) + + [["lux;Cons" [[k v] plist*]]] + (|cons v (|vals plist*)))) + (defn |interpose [sep xs] (matchv ::M/objects [xs] [["lux;Nil" _]] @@ -318,7 +333,7 @@ (return xs) [["lux;Cons" [x xs*]]] - (exec [y (f x) + (|do [y (f x) ;; :let [_ (prn ' 1 (class y)) ;; _ (prn ' 2 (aget y 0))] ys ( f xs*)] @@ -351,7 +366,7 @@ "}}")) (defn if% [text-m then-m else-m] - (exec [? text-m] + (|do [? text-m] (if ? then-m else-m))) @@ -374,7 +389,7 @@ (fail message))) (defn comp% [f-m g-m] - (exec [temp g-m] + (|do [temp g-m] (f-m temp))) (defn pass [m-value] @@ -388,7 +403,7 @@ (defn sequence% [m-values] (matchv ::M/objects [m-values] [["lux;Cons" [head tail]]] - (exec [_ head] + (|do [_ head] (sequence% tail)) [_] @@ -447,13 +462,13 @@ ((exhaust% step) state*) [["lux;Left" msg]] - ((exec [? source-consumed?] + ((|do [? source-consumed?] (if ? (return nil) (fail* msg))) state) ;; (if (= "[Reader Error] EOF" msg) - ;; ((exec [? source-consumed? + ;; ((|do [? source-consumed? ;; :let [_ (prn '? ?)]] ;; (return nil)) ;; state) @@ -606,7 +621,7 @@ (|list))) (def get-module-name - (exec [module get-current-module-env] + (|do [module get-current-module-env] (return (get$ "lux;name" module)))) (defn with-scope [name body] @@ -620,9 +635,9 @@ output)))) (defn with-closure [body] - (exec [closure-info (try-all% (|list (exec [top get-top-local-env] + (|do [closure-info (try-all% (|list (|do [top get-top-local-env] (return (T true (->> top (get$ "lux;inner-closures") str)))) - (exec [global get-current-module-env] + (|do [global get-current-module-env] (return (T false (->> global (get$ "lux;inner-closures") str))))))] (matchv ::M/objects [closure-info] [[local? closure-name]] @@ -643,7 +658,7 @@ ))) (def get-scope-name - (exec [module-name get-module-name] + (|do [module-name get-module-name] (fn [state] (return* state (->> state (get$ "lux;local-envs") (|map #(get$ "lux;name" %)) |reverse (|cons module-name)))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index bf724c768..280f27e63 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -5,7 +5,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail*]] [type :as &type] [reader :as &reader] [lexer :as &lexer] @@ -70,8 +70,8 @@ [["variant" [?tag ?members]]] (&&lux/compile-variant compile-expression ?type ?tag ?members) - [["case" [?variant ?base-register ?num-registers ?branches]]] - (&&case/compile-case compile-expression ?type ?variant ?base-register ?num-registers ?branches) + [["case" [?value ?match]]] + (&&case/compile-case compile-expression ?type ?value ?match) [["lambda" [?scope ?env ?args ?body]]] (&&lambda/compile-lambda compile-expression ?scope ?env ?args ?body) @@ -176,8 +176,8 @@ [["jvm-dgt" [?x ?y]]] (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - [["exec" ?exprs]] - (&&host/compile-exec compile-expression ?type ?exprs) + [["|do" ?exprs]] + (&&host/compile-|do compile-expression ?type ?exprs) [["jvm-null" _]] (&&host/compile-jvm-null compile-expression ?type) @@ -330,7 +330,7 @@ (defn ^:private eval! [expr] (prn 'eval! (aget expr 0)) ;; (assert false) - (exec [eval-ctor &/get-eval-ctor + (|do [eval-ctor &/get-eval-ctor :let [class-name (str eval-ctor) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) @@ -338,7 +338,7 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) (doto (.visitEnd))))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (.visitCode *writer*)] _ (compile-expression expr) :let [_ (doto *writer* @@ -356,7 +356,7 @@ (.get nil) return))) -(let [compiler-step (exec [analysis+ (&optimizer/optimize eval!) +(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!) ;; :let [_ (prn 'analysis+ analysis+)] ] (&/map% compile-statement analysis+) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index eeac182e0..7a75917d0 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -2,7 +2,7 @@ (:require [clojure.string :as string] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail*]]) + (lux [base :as & :refer [|do return* return fail fail*]]) [lux.analyser.base :as &a]) (:import (org.objectweb.asm Opcodes Label @@ -26,7 +26,7 @@ (.loadClass loader name)) (defn save-class! [name bytecode] - (exec [loader &/loader + (|do [loader &/loader :let [_ (write-class name bytecode) _ (load-class! loader (string/replace name #"/" "."))]] (return nil))) @@ -109,7 +109,7 @@ [["jvm-drem" [?x ?y]]] (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - [["exec" ?exprs]] + [["|do" ?exprs]] (&/fold max 0 (&/|map total-locals ?exprs)) [["jvm-new" [?class ?classes ?args]]] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index afa446df0..7fd22dc59 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -3,7 +3,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -16,75 +16,18 @@ MethodVisitor))) ;; [Utils] -(defn ^:private ->match [$body register token] - ;; (prn '->match token) - ;; (prn '->match (aget token 0)) - (matchv ::M/objects [token] - [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]]] - (&/T (inc register) (&/V "Pattern" (&/T $body (&/V "StoreMatch" register)))) - - [["lux;Meta" [_ ["lux;Bool" ?value]]]] - (&/T register (&/V "Pattern" (&/T $body (&/V "BoolMatch" ?value)))) - - [["lux;Meta" [_ ["lux;Int" ?value]]]] - (&/T register (&/V "Pattern" (&/T $body (&/V "IntMatch" ?value)))) - - [["lux;Meta" [_ ["lux;Real" ?value]]]] - (&/T register (&/V "Pattern" (&/T $body (&/V "RealMatch" ?value)))) - - [["lux;Meta" [_ ["lux;Char" ?value]]]] - (&/T register (&/V "Pattern" (&/T $body (&/V "CharMatch" ?value)))) - - [["lux;Meta" [_ ["lux;Text" ?value]]]] - (&/T register (&/V "Pattern" (&/T $body (&/V "TextMatch" ?value)))) - - [["lux;Meta" [_ ["lux;Tuple" ?members]]]] - (|let [[register* =members] (&/fold (fn [register+=members member] - ;; (prn 'register+=members (alength register+=members)) - (|let [[_register =members] register+=members - [__register =member] (let [matched (->match $body _register member)] - ;; (prn 'matched (alength matched)) - matched)] - (&/T __register (&/|cons =member =members)))) - (&/T register (&/|list)) - ?members)] - (&/T register* (&/V "Pattern" (&/T $body (&/V "TupleMatch" (&/|reverse =members)))))) - - [["lux;Meta" [_ ["lux;Tag" [?module ?name]]]]] - (|let [?tag (str ?module ";" ?name)] - (&/T register (&/V "Pattern" (&/T $body (&/V "VariantMatch" (&/T ?tag (&/V "Pattern" (&/T $body (&/V "TupleMatch" (&/|list)))))))))) - - [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" [?module ?name]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] - (|let [?tag (str ?module ";" ?name) - [register* =value] (->match $body register ?value)] - (&/T register* (&/V "Pattern" (&/T $body (&/V "VariantMatch" (&/T ?tag =value)))))) - )) - -(defn ^:private process-branches [base-register branches] - ;; (prn 'process-branches base-register (&/|length branches)) - (|let [[_ mappings pms] (&/fold (fn [$id+mappings+=matches pattern+body] - (|let [[$id mappings =matches] $id+mappings+=matches - [pattern body] pattern+body - [_ =match] (->match $id base-register pattern)] - (&/T (inc $id) (&/|put $id body mappings) (&/|cons =match =matches)))) - (&/T 0 (&/|table) (&/|list)) - branches)] - (&/T mappings (&/|reverse pms)))) - (let [+tag-sig+ (&host/->type-signature "java.lang.String") +oclass+ (&host/->class "java.lang.Object") +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")] (defn ^:private compile-match [writer ?match $target $else] - ;; (prn 'compile-match (aget ?match 0) $target $else) + (prn 'compile-match (aget ?match 0) $target $else) (matchv ::M/objects [?match] - [["StoreMatch" ?register]] + [["StoreTestAC" [?idx ?name ?value]]] (doto writer - (.visitVarInsn Opcodes/ASTORE ?register) + (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO $target)) - [["BoolMatch" ?value]] + [["BoolTestAC" ?value]] (doto writer (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Boolean") "booleanValue" "()Z") @@ -93,7 +36,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["IntMatch" ?value]] + [["IntTestAC" ?value]] (doto writer (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Long") "longValue" "()J") @@ -103,7 +46,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RealMatch" ?value]] + [["RealTestAC" ?value]] (doto writer (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Double") "doubleValue" "()D") @@ -113,7 +56,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["CharMatch" ?value]] + [["CharTestAC" ?value]] (doto writer (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Character") "charValue" "()C") @@ -122,7 +65,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TextMatch" ?value]] + [["TextTestAC" ?value]] (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) @@ -131,25 +74,25 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TupleMatch" ?members]] + [["TupleTestAC" ?members]] (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) (.visitLdcInsn (int idx)) (.visitInsn Opcodes/AALOAD) - (compile-match member $next $sub-else) + (compile-match test $next $sub-else) (.visitLabel $sub-else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $else) (.visitLabel $next)) - (->> (|let [[idx ["Pattern" [_ member]]] idx+member + (->> (|let [[idx test] idx+member $next (new Label) $sub-else (new Label)]) (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["VariantMatch" [?tag ["Pattern" [_ ?value]]]]] + [["VariantTestAC" [?tag ?test]]] (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) @@ -161,7 +104,7 @@ (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)) (.visitInsn Opcodes/AALOAD) - (-> (doto (compile-match ?value $value-then $value-else) + (-> (doto (compile-match ?test $value-then $value-else) (.visitLabel $value-then) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target) @@ -172,9 +115,21 @@ $value-else (new Label)])))) ))) +(defn ^:private separate-bodies [matches] + (prn 'separate-bodies (aget matches 0)) + (matchv ::M/objects [matches] + [["MatchAC" ?tests]] + (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] + (|let [[$id mappings =matches] $id+mappings+=matches + [pattern body] pattern+body] + (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) + (&/T 0 (&/|table) (&/|table)) + ?tests)] + (&/T mappings (&/|reverse patterns*))))) + (let [ex-class (&host/->class "java.lang.IllegalStateException")] (defn ^:private compile-pattern-matching [writer compile mappings patterns $end] - ;; (prn 'compile-pattern-matching mappings (&/|length patterns) $end) + ;; (prn 'compile-pattern-matching ?matches $end) (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] @@ -185,10 +140,11 @@ (doto writer (-> (doto (compile-match ?match (&/|get ?body mappings*) $else) (.visitLabel $else)) - (->> (|let [["Pattern" [?body ?match]] ?body+?match]) + (->> (|let [[?body ?match] ?body+?match]) (doseq [?body+?match (&/->seq patterns) :let [;; _ (prn 'compile-pattern-matching/pattern pattern) ;; _ (prn '?body+?match (alength ?body+?match) (aget ?body+?match 0)) + _ (prn '?body+?match (aget ?body+?match 0)) $else (new Label)]]))) (.visitInsn Opcodes/POP) (.visitTypeInsn Opcodes/NEW ex-class) @@ -197,23 +153,20 @@ (.visitInsn Opcodes/ATHROW)) (&/map% (fn [?label+?body] (|let [[?label ?body] ?label+?body] - (exec [:let [_ (.visitLabel writer ?label)] - ret (compile ?body) - :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] + (|do [:let [_ (.visitLabel writer ?label)] + ret (compile ?body) + :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] (return ret)))) (&/|map &/|second entries)) ))) ;; [Resources] -(defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches] - ;; (prn 'compile-case ?variant ?base-register ?num-registers (&/|length ?branches)) - (exec [*writer* &/get-writer - :let [$end (new Label)] - _ (compile ?variant)] - (|let [[mappings patterns] (process-branches ?base-register ?branches) - ;; _ (prn '[(&/|length mappings) (&/|length patterns)] [(&/|length mappings) (&/|length patterns)]) - ] - (exec [_ (compile-pattern-matching *writer* compile mappings patterns $end) - :let [_ (.visitLabel *writer* $end)]] - (return nil))) - )) +(defn compile-case [compile *type* ?value ?matches] + ;; (prn 'compile-case ?value ?matches) + (|do [*writer* &/get-writer + :let [$end (new Label)] + _ (compile ?value) + _ (|let [[mappings patterns] (separate-bodies ?matches)] + (compile-pattern-matching *writer* compile mappings patterns $end)) + :let [_ (.visitLabel *writer* $end)]] + (return nil))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 40ad7bb6d..f289ed6ba 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -4,7 +4,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -62,7 +62,7 @@ ;; [Resources] (do-template [ ] (defn [compile *type* ?x ?y] - (exec [:let [+wrapper-class+ (&host/->class )] + (|do [:let [+wrapper-class+ (&host/->class )] *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* @@ -104,7 +104,7 @@ (do-template [ ] (defn [compile *type* ?x ?y] - (exec [:let [+wrapper-class+ (&host/->class )] + (|do [:let [+wrapper-class+ (&host/->class )] *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* @@ -132,7 +132,7 @@ (do-template [ ] (defn [compile *type* ?x ?y] - (exec [:let [+wrapper-class+ (&host/->class )] + (|do [:let [+wrapper-class+ (&host/->class )] *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* @@ -168,10 +168,10 @@ ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (&/map% (fn [[class-name arg]] - (exec [ret (compile arg) + (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) (map vector ?classes ?args)) @@ -183,13 +183,13 @@ (do-template [ ] (defn [compile *type* ?class ?method ?classes ?object ?args] ;; (prn 'compile-jvm-invokevirtual ?classes *type*) - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] _ (&/map% (fn [class-name+arg] (|let [[class-name arg] class-name+arg] - (exec [ret (compile arg) + (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret)))) (&/zip2 ?classes ?args)) @@ -204,12 +204,12 @@ ) (defn compile-jvm-null [compile *type*] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) (defn compile-jvm-null? [compile *type* ?object] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?object) :let [$then (new Label) $end (new Label) @@ -223,14 +223,14 @@ (return nil))) (defn compile-jvm-new [compile *type* ?class ?classes ?args] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [init-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")V") class* (&host/->class ?class) _ (doto *writer* (.visitTypeInsn Opcodes/NEW class*) (.visitInsn Opcodes/DUP))] _ (&/map% (fn [[class-name arg]] - (exec [ret (compile arg) + (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) (map vector ?classes ?args)) @@ -239,14 +239,14 @@ (return nil))) (defn compile-jvm-new-array [compile *type* ?class ?length] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int ?length)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] (return nil))) (defn compile-jvm-aastore [compile *type* ?array ?idx ?elem] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?array) :let [_ (doto *writer* (.visitInsn Opcodes/DUP) @@ -256,7 +256,7 @@ (return nil))) (defn compile-jvm-aaload [compile *type* ?array ?idx] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?array) :let [_ (doto *writer* (.visitLdcInsn (int ?idx)) @@ -264,25 +264,25 @@ (return nil))) (defn compile-jvm-getstatic [compile *type* ?class ?field] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] (return nil))) (defn compile-jvm-getfield [compile *type* ?class ?field ?object] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] (return nil))) (defn compile-jvm-putstatic [compile *type* ?class ?field ?value] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?value) :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] (return nil))) (defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?object) _ (compile ?value) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] @@ -328,10 +328,10 @@ ;; (prn 'SAVED_CLASS full-name) (&&/save-class! full-name (.toByteArray =interface)))) -(defn compile-exec [compile *type* ?exprs] - (exec [*writer* &/get-writer +(defn compile-|do [compile *type* ?exprs] + (|do [*writer* &/get-writer _ (&/map% (fn [expr] - (exec [ret (compile expr) + (|do [ret (compile expr) :let [_ (.visitInsn *writer* Opcodes/POP)]] (return ret))) (butlast ?exprs)) @@ -339,19 +339,19 @@ (return nil))) (defn compile-jvm-try [compile *type* ?body ?catches ?finally] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [$from (new Label) $to (new Label) $end (new Label) $catch-finally (new Label) compile-finally (if ?finally - (exec [_ (return nil) + (|do [_ (return nil) _ (compile ?finally) :let [_ (doto *writer* (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $end))]] (return nil)) - (exec [_ (return nil) + (|do [_ (return nil) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] (return nil))) _ (.visitLabel *writer* $from)] @@ -359,7 +359,7 @@ :let [_ (.visitLabel *writer* $to)] _ compile-finally handlers (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (exec [:let [$handler-start (new Label) + (|do [:let [$handler-start (new Label) $handler-end (new Label)] _ (compile ?catch-body) :let [_ (.visitLabel *writer* $handler-end)] @@ -368,12 +368,12 @@ ?catches) :let [_ (.visitLabel *writer* $catch-finally)] _ (if ?finally - (exec [_ (compile ?finally) + (|do [_ (compile ?finally) :let [_ (doto *writer* (.visitInsn Opcodes/POP) (.visitInsn Opcodes/ATHROW))]] (return nil)) - (exec [_ (return nil) + (|do [_ (return nil) :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] @@ -387,14 +387,14 @@ (return nil))) (defn compile-jvm-throw [compile *type* ?ex] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?ex) :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil))) (do-template [ ] (defn [compile *type* ?monitor] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?monitor) :let [_ (doto *writer* (.visitInsn ) @@ -407,7 +407,7 @@ (do-template [ ] (defn [compile *type* ?value] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW (&host/->class )) (.visitInsn Opcodes/DUP))] @@ -440,7 +440,7 @@ (do-template [ ] (defn [compile *type* ?x ?y] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW (&host/->class )) (.visitInsn Opcodes/DUP))] @@ -466,10 +466,10 @@ ) (defn compile-jvm-program [compile *type* ?body] - (exec [*writer* &/get-writer] + (|do [*writer* &/get-writer] (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) (.visitCode)) - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?body) :let [_ (doto *writer* (.visitInsn Opcodes/POP) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index cce87e978..b914eb87b 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -4,7 +4,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail*]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -60,7 +60,7 @@ (defn ^:private add-lambda-impl [class compile impl-signature impl-body] (&/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) (.visitCode)) - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [num-locals (&&/total-locals impl-body) $start (new Label) $end (new Label) @@ -78,7 +78,7 @@ (defn ^:private instance-closure [compile lambda-class closed-over init-signature] ;; (prn 'instance-closure lambda-class closed-over init-signature) - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] @@ -99,7 +99,7 @@ ;; [Exports] (defn compile-lambda [compile ?scope ?env ?arg ?body] ;; (prn 'compile-lambda ?scope (&host/location ?scope) ?arg ?env) - (exec [:let [lambda-class (&host/location ?scope) + (|do [:let [lambda-class (&host/location ?scope) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index a761f431a..a12c30531 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -4,7 +4,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -24,14 +24,14 @@ (let [+class+ (&host/->class "java.lang.Boolean") +sig+ (&host/->type-signature "java.lang.Boolean")] (defn compile-bool [compile *type* ?value] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (&host/->type-signature "java.lang.Boolean"))]] (return nil)))) (do-template [ ] (let [+class+ (&host/->class )] (defn [compile *type* value] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW +class+) (.visitInsn Opcodes/DUP) @@ -45,19 +45,19 @@ ) (defn compile-text [compile *type* ?value] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) (defn compile-tuple [compile *type* ?elems] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [num-elems (&/|length ?elems) _ (doto *writer* (.visitLdcInsn (int num-elems)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] _ (&/map% (fn [idx+elem] (|let [[idx elem] idx+elem] - (exec [:let [_ (doto *writer* + (|do [:let [_ (doto *writer* (.visitInsn Opcodes/DUP) (.visitLdcInsn (int idx)))] ret (compile elem) @@ -67,14 +67,14 @@ (return nil))) (defn compile-record [compile *type* ?elems] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [num-elems (&/|length ?elems) _ (doto *writer* (.visitLdcInsn (int (* 2 num-elems))) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] _ (&/map% (fn [idx+kv] (|let [[idx [k v]] idx+kv] - (exec [:let [idx* (* 2 idx) + (|do [:let [idx* (* 2 idx) _ (doto *writer* (.visitInsn Opcodes/DUP) (.visitLdcInsn (int idx*)) @@ -90,7 +90,7 @@ (return nil))) (defn compile-variant [compile *type* ?tag ?value] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")) @@ -105,13 +105,13 @@ (return nil))) (defn compile-local [compile *type* ?idx] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] (return nil))) (defn compile-captured [compile *type* ?scope ?captured-id ?source] ;; (prn 'compile-captured ?scope ?captured-id) - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD @@ -121,19 +121,19 @@ (return nil))) (defn compile-global [compile *type* ?owner-class ?name] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] (return nil))) (defn compile-apply [compile *type* ?fn ?arg] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer _ (compile ?fn) _ (compile ?arg) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]] (return nil))) (defn compile-def [compile ?name ?body] - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer module-name &/get-module-name :let [outer-class (&host/->class module-name) datum-sig (&host/->type-signature "java.lang.Object") @@ -146,7 +146,7 @@ (doto (.visitEnd))))] ;; :let [_ (prn 'compile-def/pre-body)] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (exec [*writer* &/get-writer + (|do [*writer* &/get-writer :let [_ (.visitCode *writer*)] ;; :let [_ (prn 'compile-def/pre-body2)] _ (compile ?body) diff --git a/src/lux/host.clj b/src/lux/host.clj index 1dda5de5d..b10b23995 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -3,7 +3,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let]] [parser :as &parser] [type :as &type]))) @@ -30,7 +30,7 @@ ))) (defn ^:private method->type [method] - (exec [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method)))) + (|do [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method)))) =return (class->type (.getReturnType method))] (return =return))) @@ -52,7 +52,7 @@ (defn full-class-name [class-name] ;; (prn 'full-class-name class-name) - (exec [=class (full-class class-name)] + (|do [=class (full-class class-name)] (return (.getName =class)))) (defn ->class [class] @@ -104,7 +104,7 @@ [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "Array"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?inner]]]] ["lux;Nil" _]]]]]]]]] - (exec [=inner (full-class-name ?inner)] + (|do [=inner (full-class-name ?inner)] (return (str "[L" (->class =inner) ";"))) [_] @@ -118,7 +118,7 @@ (= field (.getName =field)) (= (java.lang.reflect.Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] - (exec [=type (class->type type*)] + (|do [=type (class->type type*)] (return =type)) (fail (str "[Analyser Error] Field does not exist: " target field))))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 4dc46f41c..cae2fdcaf 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -1,6 +1,6 @@ (ns lux.lexer (:require [clojure.template :refer [do-template]] - (lux [base :as & :refer [exec return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail*]] [reader :as &reader]) [lux.analyser.def :as &def])) @@ -18,30 +18,30 @@ (fail (str "[Lexer Error] Unknown escape character: " escaped)))) (defn ^:private lex-text-body [_____] - (&/try-all% (&/|list (exec [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") + (&/try-all% (&/|list (|do [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") unescaped (escape-char escaped) [_ [_ postfix]] (lex-text-body nil)] (return (str prefix unescaped postfix))) - (exec [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")] + (|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")] (return body))))) (def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)") ;; [Lexers] (def ^:private lex-white-space - (exec [[_ [meta white-space]] (&reader/read-regex #"^(\s+)")] + (|do [[_ [meta white-space]] (&reader/read-regex #"^(\s+)")] (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space)))))) (def ^:private lex-single-line-comment - (exec [[_ [meta _]] (&reader/read-text "##") + (|do [[_ [meta _]] (&reader/read-text "##") [_ [_ comment]] (&reader/read-regex #"^(.*)$")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (defn ^:private lex-multi-line-comment [___] - (exec [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (exec [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")] + (|do [_ (&reader/read-text "#(") + [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")] (return comment)) - (exec [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())") + (|do [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())") [_ inner] (lex-multi-line-comment nil) [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))")] (return (str pre "#(" inner ")#" post))))) @@ -55,7 +55,7 @@ (do-template [ ] (def - (exec [[_ [meta token]] (&reader/read-regex )] + (|do [[_ [meta token]] (&reader/read-regex )] (return (&/V "lux;Meta" (&/T meta (&/V token)))))) ^:private lex-bool "Bool" #"^(true|false)" @@ -64,30 +64,30 @@ ) (def ^:private lex-char - (exec [[_ [meta _]] (&reader/read-text "#\"") - token (&/try-all% (&/|list (exec [escaped (&reader/read-regex #"^(\\.)")] + (|do [[_ [meta _]] (&reader/read-text "#\"") + token (&/try-all% (&/|list (|do [escaped (&reader/read-regex #"^(\\.)")] (escape-char escaped)) - (exec [[_ [_ char]] (&reader/read-regex #"^(.)")] + (|do [[_ [_ char]] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Char" token)))))) (def ^:private lex-text - (exec [[_ [meta _]] (&reader/read-text "\"") + (|do [[_ [meta _]] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Text" token)))))) (def ^:private lex-ident - (&/try-all% (&/|list (exec [[_ [meta _]] (&reader/read-text ";") + (&/try-all% (&/|list (|do [[_ [meta _]] (&reader/read-text ";") [_ [_ token]] (&reader/read-regex +ident-re+)] (return (&/V "lux;Meta" (&/T meta (&/T "lux" token))))) - (exec [[_ [meta token]] (&reader/read-regex +ident-re+)] - (&/try-all% (&/|list (exec [_ (&reader/read-text ";") + (|do [[_ [meta token]] (&reader/read-regex +ident-re+)] + (&/try-all% (&/|list (|do [_ (&reader/read-text ";") [_ [_ local-token]] (&reader/read-regex +ident-re+)] - (&/try-all% (&/|list (exec [unaliased (&def/unalias-module token)] + (&/try-all% (&/|list (|do [unaliased (&def/unalias-module token)] (return (&/V "lux;Meta" (&/T meta (&/T unaliased local-token))))) - (exec [? (&def/module-exists? token)] + (|do [? (&def/module-exists? token)] (if ? (return (&/V "lux;Meta" (&/T meta (&/T token local-token)))) (fail (str "[Lexer Error] Unknown module: " token)))) @@ -97,17 +97,17 @@ ))) (def ^:private lex-symbol - (exec [[_ [meta ident]] lex-ident] + (|do [[_ [meta ident]] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident)))))) (def ^:private lex-tag - (exec [[_ [meta _]] (&reader/read-text "#") + (|do [[_ [meta _]] (&reader/read-text "#") [_ [_ ident]] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident)))))) (do-template [ ] (def - (exec [[_ [meta _]] (&reader/read-text )] + (|do [[_ [meta _]] (&reader/read-text )] (return (&/V "lux;Meta" (&/T meta (&/V nil)))))) ^:private lex-open-paren "(" "Open_Paren" diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 5c93bfbfb..e50d2aae9 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -11,6 +11,8 @@ ;; Avoid (un)boxing: Analyser movement of primitive values to/from functions to known when (un)boxing can be avoided. ;; Pre-compute constant expressions: Find function calls for which all arguments are known at compile-time and pre-calculate everything prior to compilation. ;; Convert pattern-matching on booleans into regular if-then-else structures +;; Local var aliasing. +;; Global var aliasing. ;; [Exports] (defn optimize [eval!] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 71fca764a..a21dd5ba6 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -2,13 +2,13 @@ (:require [clojure.template :refer [do-template]] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return fail]] + (lux [base :as & :refer [|do return fail]] [lexer :as &lexer]))) ;; [Utils] (do-template [ ] (defn [parse] - (exec [elems (&/repeat% parse) + (|do [elems (&/repeat% parse) token &lexer/lex] (matchv ::M/objects [token] [["lux;Meta" [meta [ _]]]] @@ -22,7 +22,7 @@ ) (defn ^:private parse-record [parse] - (exec [elems* (&/repeat% parse) + (|do [elems* (&/repeat% parse) token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (matchv ::M/objects [token] @@ -36,7 +36,7 @@ ;; [Interface] (def parse - (exec [token &lexer/lex + (|do [token &lexer/lex ;; :let [_ (prn 'parse/token token)] ;; :let [_ (prn 'parse (aget token 0))] ] @@ -69,15 +69,15 @@ (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Tag" ?ident))))) [["lux;Meta" [meta ["Open_Paren" _]]]] - (exec [syntax (parse-form parse)] + (|do [syntax (parse-form parse)] (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) [["lux;Meta" [meta ["Open_Bracket" _]]]] - (exec [syntax (parse-tuple parse)] + (|do [syntax (parse-tuple parse)] (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) [["lux;Meta" [meta ["Open_Brace" _]]]] - (exec [syntax (parse-record parse)] + (|do [syntax (parse-record parse)] (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) [_] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index a1e447669..d5d7b453c 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -2,7 +2,7 @@ (:require [clojure.string :as string] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - [lux.base :as & :refer [exec return* return fail fail* |let]])) + [lux.base :as & :refer [|do return* return fail fail* |let]])) ;; [Utils] (defn ^:private with-line [body] diff --git a/src/lux/type.clj b/src/lux/type.clj index 77025b62e..e136e8b5c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -2,7 +2,7 @@ (:refer-clojure :exclude [deref apply merge]) (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - [lux.base :as & :refer [exec return* return fail fail* assert! |let]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let]])) ;; [Util] (def ^:private success (return nil)) @@ -49,7 +49,7 @@ (&/V "lux;VarT" id))))) (def fresh-lambda - (exec [=arg fresh-var + (|do [=arg fresh-var =return fresh-var] (return (&/V "lux;LambdaT" (&/T =arg =return))))) @@ -59,42 +59,42 @@ (matchv ::M/objects [type] [["lux;VarT" ?id]] (if (= ?tid ?id) - (&/try-all% (&/|list (exec [=type (deref ?id)] + (&/try-all% (&/|list (|do [=type (deref ?id)] (clean tvar =type)) (return type))) (return type)) [["lux;LambdaT" [?arg ?return]]] - (exec [=arg (clean tvar ?arg) + (|do [=arg (clean tvar ?arg) =return (clean tvar ?return)] (return (&/V "lux;LambdaT" (&/T =arg =return)))) [["lux;AppT" [?lambda ?param]]] - (exec [=lambda (clean tvar ?lambda) + (|do [=lambda (clean tvar ?lambda) =param (clean tvar ?param)] (return (&/V "lux;AppT" (&/T =lambda =param)))) [["lux;TupleT" ?members]] - (exec [=members (&/map% (partial clean tvar) ?members)] + (|do [=members (&/map% (partial clean tvar) ?members)] (return (&/V "lux;TupleT" =members))) [["lux;VariantT" ?members]] - (exec [=members (&/map% (fn [[k v]] - (exec [=v (clean tvar v)] + (|do [=members (&/map% (fn [[k v]] + (|do [=v (clean tvar v)] (return (&/T k =v)))) ?members)] (return (&/V "lux;VariantT" =members))) [["lux;RecordT" ?members]] - (exec [=members (&/map% (fn [[k v]] - (exec [=v (clean tvar v)] + (|do [=members (&/map% (fn [[k v]] + (|do [=v (clean tvar v)] (return (&/T k =v)))) ?members)] (return (&/V "lux;RecordT" =members))) [["lux;AllT" [?env ?name ?arg ?body]]] - (exec [=env (&/map% (fn [[k v]] - (exec [=v (clean tvar v)] + (|do [=env (&/map% (fn [[k v]] + (|do [=v (clean tvar v)] (return (&/T k =v)))) ?env)] (return (&/V "lux;AllT" (&/T =env ?name ?arg ?body)))) @@ -113,12 +113,12 @@ "Nothing" [["lux;DataT" [name params]]] - (if (&/|empty? params) - "(,)" - (str "(^ " name " [" (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) "])")) - + (str "(^ " name " [" (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) "])") + [["lux;TupleT" elems]] - (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + (if (&/|empty? elems) + "(,)" + (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) [["lux;VariantT" cases]] (str "(| " (->> cases @@ -240,7 +240,7 @@ (defn ^:private fp-put [k v fixpoints] (&/|cons (&/T k v) fixpoints)) -(defn ^:private solve-error [expected actual] +(defn ^:private check-error [expected actual] (str "Type " (show-type expected) " does not subsume type " (show-type actual))) (defn beta-reduce [env type] @@ -286,15 +286,13 @@ (defn slot-type [record slot] (fn [state] - (matchv ::M/objects [(&/|get record slot)] + (matchv ::M/objects [(&/|get slot record)] [["lux;Left" msg]] (fail* msg) [["lux;Right" type]] (return* state type)))) -(def +dont-care+ (&/V "lux;AnyT" nil)) - (defn apply-type [type-fn param] ;; (prn 'apply-type (aget type-fn 0) (aget param 0)) (matchv ::M/objects [type-fn] @@ -305,7 +303,7 @@ local-def)) [["lux;AppT" [F A]]] - (exec [type-fn* (apply-type F A)] + (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) [_] @@ -313,9 +311,9 @@ (def init-fixpoints (&/|list)) -(defn ^:private solve* [fixpoints expected actual] - (prn 'solve* (aget expected 0) (aget actual 0)) - ;; (prn 'solve* (show-type expected) (show-type actual)) +(defn ^:private check* [fixpoints expected actual] + (prn 'check* (aget expected 0) (aget actual 0)) + ;; (prn 'check* (show-type expected) (show-type actual)) (matchv ::M/objects [expected actual] [["lux;AnyT" _] _] success @@ -324,40 +322,40 @@ success [["lux;VarT" ?id] _] - (&/try-all% (&/|list (exec [bound (deref ?id)] - (solve* fixpoints bound actual)) + (&/try-all% (&/|list (|do [bound (deref ?id)] + (check* fixpoints bound actual)) (reset ?id actual))) [_ ["lux;VarT" ?id]] - (&/try-all% (&/|list (exec [bound (deref ?id)] - (solve* fixpoints expected bound)) + (&/try-all% (&/|list (|do [bound (deref ?id)] + (check* fixpoints expected bound)) (reset ?id expected))) [["lux;AppT" [F A]] _] - (exec [expected* (apply-type F A) + (|do [expected* (apply-type F A) :let [fp-pair (&/T expected actual)]] (matchv ::M/objects [(fp-get fp-pair fixpoints)] [["lux;Some" ?]] (if ? success - (fail (solve-error expected actual))) + (fail (check-error expected actual))) [["lux;None" _]] - (solve* (fp-put fp-pair true fixpoints) expected* actual))) + (check* (fp-put fp-pair true fixpoints) expected* actual))) [_ ["lux;AppT" [F A]]] - (exec [actual* (apply-type F A)] - (solve* fixpoints expected actual*)) + (|do [actual* (apply-type F A)] + (check* fixpoints expected actual*)) [["lux;AllT" _] _] - (exec [$var fresh-var + (|do [$var fresh-var expected* (apply-type expected $var)] - (solve* fixpoints expected* actual)) + (check* fixpoints expected* actual)) [_ ["lux;AllT" _]] - (exec [$var fresh-var + (|do [$var fresh-var actual* (apply-type actual $var)] - (solve* fixpoints expected actual*)) + (check* fixpoints expected actual*)) [["lux;DataT" [e!name e!params]] ["lux;DataT" [a!name a!params]]] (cond (not= e!name a!name) @@ -367,22 +365,22 @@ (fail "[Type Error] Params don't match in size.") :else - (exec [_ (&/map% (fn [ea] + (|do [_ (&/map% (fn [ea] (|let [[e a] ea] - (solve* fixpoints e a))) + (check* fixpoints e a))) (&/zip2 e!params a!params))] success)) [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] - (exec [_ (solve* fixpoints aI eI)] - (solve* fixpoints eO aO)) + (|do [_ (check* fixpoints aI eI)] + (check* fixpoints eO aO)) [["lux;TupleT" e!members] ["lux;TupleT" a!members]] (if (= (&/|length e!members) (&/|length a!members)) - (exec [_ (&/map% (fn [ea] + (|do [_ (&/map% (fn [ea] (|let [[e a] ea] (do ;; (prn "lux;TupleT" 'ITER (show-type e) (show-type a)) - (solve* fixpoints e a)))) + (check* fixpoints e a)))) (&/zip2 e!members a!members)) ;; :let [_ (prn "lux;TupleT" 'DONE)] ] @@ -395,22 +393,22 @@ (fail "[Type Error] Tuples don't match in size."))) [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] - (exec [_ (&/map% (fn [kv] + (|do [_ (&/map% (fn [kv] (|let [[k av] kv] (if-let [ev (&/|get k e!cases)] - (solve* fixpoints ev av) + (check* fixpoints ev av) (fail (str "[Type Error] The expected variant cannot handle case: #" k))))) a!cases)] success) [["lux;RecordT" e!fields] ["lux;RecordT" a!fields]] (if (= (&/|length e!fields) (&/|length a!fields)) - (exec [_ (&/map% (fn [slot] + (|do [_ (&/map% (fn [slot] (if-let [e!type (&/|get e!fields slot)] (if-let [a!type (&/|get a!fields slot)] - (solve* fixpoints e!type a!type) - (fail (solve-error expected actual))) - (fail (solve-error expected actual)))) + (check* fixpoints e!type a!type) + (fail (check-error expected actual))) + (fail (check-error expected actual)))) (&/|keys e!fields))] success) (fail "[Type Error] Records don't match in size.")) @@ -424,16 +422,16 @@ ;; ... )) -(def solve (partial solve* init-fixpoints)) +(def check (partial check* init-fixpoints)) (defn apply-lambda [func param] (matchv ::M/objects [func] [["lux;LambdaT" [input output]]] - (exec [_ (solve* init-fixpoints input param)] + (|do [_ (check* init-fixpoints input param)] (return output)) [["lux;AllT" [local-env local-name local-arg local-def]]] - (exec [$var fresh-var + (|do [$var fresh-var func* (apply-type func $var)] (apply-lambda func* param)) @@ -443,8 +441,12 @@ (def Any (&/V "lux;AnyT" nil)) (def Nothing (&/V "lux;NothingT" nil)) +(def Bool (&/V "lux;DataT" (&/T "java.lang.Boolean" (&/|list)))) (def Int (&/V "lux;DataT" (&/T "java.lang.Long" (&/|list)))) +(def Real (&/V "lux;DataT" (&/T "java.lang.Double" (&/|list)))) +(def Char (&/V "lux;DataT" (&/T "java.lang.Character" (&/|list)))) (def Text (&/V "lux;DataT" (&/T "java.lang.String" (&/|list)))) +(def Unit (&/V "lux;TupleT" (&/|list))) (def List (&/V "lux;AllT" (&/T (&/|table) "List" "a" @@ -489,31 +491,55 @@ [["lux;NothingT" _] _] (return y) + [["lux;DataT" [xname xparams]] ["lux;DataT" [yname yparams]]] + (if (and (= xname yname) + (= (&/|length xparams) (&/|length yparams))) + (fail (str "[Type System Error] Can't merge types: " (show-type x) " and " (show-type y))) + (|do [xyparams (&/map% (fn [xy] + (|let [[xp yp] xy] + (merge xp yp))) + (&/zip2 xparams yparams))] + (return (&/V "lux;DataT" (&/T xname xyparams))))) + + [["lux;TupleT" xmembers] ["lux;TupleT" ymembers]] + (if (= (&/|length xmembers) (&/|length ymembers)) + (fail (str "[Type System Error] Can't merge types: " (show-type x) " and " (show-type y))) + (|do [xymembers (&/map% (fn [xy] + (|let [[xp yp] xy] + (merge xp yp))) + (&/zip2 xmembers ymembers))] + (return (&/V "lux;TupleT" xymembers)))) + [["lux;VariantT" x!cases] ["lux;VariantT" y!cases]] - (exec [cases (&/fold% (fn [cases kv] - (matchv ::M/objects [kv] - [[k v]] - (if-let [cv (&/|get k cases)] - (exec [_ (solve* init-fixpoints cv v)] - (return cases)) - (return (&/|put k v cases))))) - x!cases - y!cases)] + (|do [cases (&/fold% (fn [cases kv] + (matchv ::M/objects [kv] + [[k v]] + (if-let [cv (&/|get k cases)] + (|do [v* (merge cv v)] + (return (&/|put k v* cases))) + (return (&/|put k v cases))))) + x!cases + y!cases)] (return (&/V "lux;VariantT" cases))) [["lux;RecordT" x!fields] ["lux;RecordT" y!fields]] (if (= (&/|length x!fields) (&/|length y!fields)) - (exec [fields (&/fold% (fn [fields kv] - (matchv ::M/objects [kv] - [[k v]] - (if-let [cv (&/|get k fields)] - (exec [_ (solve* init-fixpoints cv v)] - (return fields)) - (fail (str "[Type System Error] Incompatible records: " (show-type x) " and " (show-type y)))))) - x!fields - y!fields)] + (|do [fields (&/fold% (fn [fields kv] + (matchv ::M/objects [kv] + [[k v]] + (if-let [cv (&/|get k fields)] + (|do [v* (merge cv v)] + (return (&/|put k v* fields))) + (fail (str "[Type System Error] Incompatible records: " (show-type x) " and " (show-type y)))))) + x!fields + y!fields)] (return (&/V "lux;RecordT" fields))) (fail (str "[Type System Error] Incompatible records: " (show-type x) " and " (show-type y)))) + + [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + (|do [xyinput (check xinput yinput) + xyoutput (check xoutput youtput)] + (return (&/V "lux;LambdaT" (&/T xyinput xyoutput)))) [_ _] (fail (str "[Type System Error] Can't merge types: " (show-type x) " and " (show-type y)))))) @@ -524,7 +550,7 @@ (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" (&/V "lux;TupleT" (&/|list))))))))))) ) - (matchv ::M/objects [((solve Type RealT) + (matchv ::M/objects [((check Type RealT) (&/init-state nil))] [["lux;Left" ?msg]] (assert false ?msg) @@ -532,7 +558,7 @@ [_] (println "YEAH!")) - (matchv ::M/objects [((solve List (&/V "lux;AppT" (&/T List Real))) + (matchv ::M/objects [((check List (&/V "lux;AppT" (&/T List Real))) (&/init-state nil))] [["lux;Left" ?msg]] (assert false ?msg) -- cgit v1.2.3