From 97d1a9d0c5b469c3de4e9ee8af33e5a9d3144cb6 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Jan 2017 17:35:20 -0400 Subject: - More refactorings. - Changed the place where module-compilation-state was being stored. - No longer keeping the compiler's name as part of the compiler's state. --- stdlib/source/lux.lux | 63 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 41 insertions(+), 22 deletions(-) (limited to 'stdlib/source') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 520e55434..19a7b4716 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -485,6 +485,26 @@ Text])])) default-def-meta-exported) +## (type: Module-State +## #Active +## #Compiled +## #Cached) +(_lux_def Module-State + (#NamedT ["lux" "Module-State"] + (#SumT + ## #Active + Unit + (#SumT + ## #Compiled + Unit + ## #Cached + Unit))) + (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "Active") + (#Cons (#TextA "Compiled") + (#Cons (#TextA "Cached") + #Nil))))] + default-def-meta-exported)) + ## (type: Module ## {#module-hash Int ## #module-aliases (List [Text Text]) @@ -493,6 +513,7 @@ ## #tags (List [Text [Nat (List Ident) Bool Type]]) ## #types (List [Text [(List Ident) Bool Type]])} ## #module-anns Anns +## #module-state Module-State ## ) (_lux_def Module (#NamedT ["lux" "Module"] @@ -518,8 +539,9 @@ (#ProdT (#AppT List Ident) (#ProdT Bool Type)))) - ## "lux;module-anns" - Anns) + (#ProdT ## "lux;module-anns" + Anns + Module-State)) )))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module-hash") (#Cons (#TextA "module-aliases") @@ -528,7 +550,8 @@ (#Cons (#TextA "tags") (#Cons (#TextA "types") (#Cons (#TextA "module-anns") - #Nil))))))))] + (#Cons (#TextA "module-state") + #Nil)))))))))] (#Cons [["lux" "doc"] (#TextA "All the information contained within a Lux module.")] default-def-meta-exported))) @@ -556,21 +579,17 @@ default-def-meta-exported))) ## (type: Compiler-Info -## {#compiler-name Text -## #compiler-version Text +## {#compiler-version Text ## #compiler-mode Compiler-Mode}) (_lux_def Compiler-Info (#NamedT ["lux" "Compiler-Info"] - (#ProdT ## "lux;compiler-name" + (#ProdT ## "lux;compiler-version" Text - (#ProdT ## "lux;compiler-version" - Text - ## "lux;compiler-mode" - Compiler-Mode))) - (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "compiler-name") - (#Cons (#TextA "compiler-version") - (#Cons (#TextA "compiler-mode") - #Nil))))] + ## "lux;compiler-mode" + Compiler-Mode)) + (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "compiler-version") + (#Cons (#TextA "compiler-mode") + #Nil)))] (#Cons [["lux" "doc"] (#TextA "Information about the current version and type of compiler that is running.")] default-def-meta-exported))) @@ -1697,7 +1716,7 @@ #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} state] (_lux_case (get module modules) - (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _}) + (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _}) (_lux_case (get name defs) (#Some [def-type def-meta def-value]) (_lux_case (get-meta ["lux" "alias"] def-meta) @@ -2206,7 +2225,7 @@ ($' Maybe Macro)) (do Monad [$module (get module modules) - gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} (_lux_: Module $module)] + gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _ #module-state _} (_lux_: Module $module)] (get name bindings))] (let' [[def-type def-meta def-value] (_lux_: Def gdef)] (_lux_case (get-meta ["lux" "macro?"] def-meta) @@ -3374,7 +3393,7 @@ (-> Ident (Lux [Nat (List Ident) Bool Type])) (do Monad [=module (find-module module) - #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _} =module]] + #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _ #module-state _} =module]] (case (get name tags-table) (#Some output) (return output) @@ -3397,7 +3416,7 @@ (#NamedT [module name] _) (do Monad [=module (find-module module) - #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} =module]] + #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _ #module-state _} =module]] (case (get name types) (#Some [tags exported? (#NamedT _ _type)]) (case (resolve-struct-type _type) @@ -3956,7 +3975,7 @@ _ (list)))) - (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _} =module] + (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _} =module] defs))] (#Right state (List/join to-alias))) @@ -4022,7 +4041,7 @@ #None #None - (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _}) + (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _ #module-state _}) (case (get v-name defs) #None #None @@ -4041,7 +4060,7 @@ #None (#Left (Text/append "Unknown definition: " (Ident/encode name))) - (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _}) + (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _ #module-state _}) (case (get v-name defs) #None (#Left (Text/append "Unknown definition: " (Ident/encode name))) @@ -4344,7 +4363,7 @@ (-> Text Text (Lux Bool)) (do Monad [module (find-module module-name) - #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _} module]] + #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _ #module-state _} module]] (wrap (is-member? imports import-name)))) (macro: #export (default tokens state) -- cgit v1.3.1 From 3fa825d4ef98f2bdd9a31202bf04b06b9a1d9daa Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Jan 2017 19:50:38 -0400 Subject: - The data for checking which exceptions are being catched has been moved from the host state to the normal compiler state. --- luxc/src/lux/analyser/jvm.clj | 7 +++---- luxc/src/lux/base.clj | 10 ++++++---- luxc/src/lux/compiler/jvm.clj | 2 -- stdlib/source/lux.lux | 39 ++++++++++++++++++++++----------------- 4 files changed, 31 insertions(+), 27 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj index 24d2b2017..5ea64d41a 100644 --- a/luxc/src/lux/analyser/jvm.clj +++ b/luxc/src/lux/analyser/jvm.clj @@ -25,7 +25,6 @@ (fn [state] (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) catching (->> state - (&/get$ &/$host) (&/get$ &/$catching) (&/|map #(Class/forName % true class-loader)))] (if-let [missing-ex (&/fold (fn [prev ^Class now] @@ -53,14 +52,14 @@ (defn ^:private with-catches [catches body] "(All [a] (-> (List Text) (Lux a) (Lux a)))" (fn [state] - (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) - state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] + (let [old-catches (&/get$ &/$catching state) + state* (&/update$ &/$catching (partial &/|++ catches) state)] (|case (&/run-state body state*) (&/$Left msg) (&/$Left msg) (&/$Right state** output) - (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + (&/$Right (&/T [(&/set$ &/$catching old-catches state**) output])))) )) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 5e8c8c0d0..6ab09166e 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -117,7 +117,6 @@ ["writer" "loader" "classes" - "catching" "type-env" "dummy-mappings" ]) @@ -143,6 +142,7 @@ "expected" "seed" "scope-type-vars" + "catching" "host"]) ;; Compiler @@ -716,10 +716,10 @@ (defn with-no-catches [body] "(All [a] (-> (Lux a) (Lux a)))" (fn [state] - (let [old-catching (->> state (get$ $host) (get$ $catching))] - (|case (body (update$ $host #(set$ $catching $Nil %) state)) + (let [old-catching (->> state (get$ $catching))] + (|case (body (set$ $catching $Nil state)) ($Right state* output) - (return* (update$ $host #(set$ $catching old-catching %) state*) output) + (return* (set$ $catching old-catching state*) output) ($Left msg) (fail* msg))))) @@ -750,6 +750,8 @@ 0 ;; scope-type-vars $Nil + ;; catching + $Nil ;; "lux;host" host-data] )) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index bb333df57..809c03022 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -232,8 +232,6 @@ (memory-class-loader store) ;; "lux;classes" store - ;; "lux;catching" - &/$Nil ;; "lux;module-states" (&/|table) ;; lux;type-env diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 19a7b4716..cd16ce35f 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -603,6 +603,7 @@ ## #expected (Maybe Type) ## #seed Nat ## #scope-type-vars (List Nat) +## #catching (List Text) ## #host Void}) (_lux_def Compiler (#NamedT ["lux" "Compiler"] @@ -623,10 +624,13 @@ (#AppT Maybe Type) (#ProdT ## "lux;seed" Nat - (#ProdT ## "lux;scope-type-vars" + (#ProdT ## scope-type-vars (#AppT List Nat) ## "lux;host" - Void)))))))))) + (#ProdT ## catching + (#AppT List Text) + ## "lux;host" + Void))))))))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "info") (#Cons (#TextA "source") (#Cons (#TextA "cursor") @@ -636,8 +640,9 @@ (#Cons (#TextA "expected") (#Cons (#TextA "seed") (#Cons (#TextA "scope-type-vars") - (#Cons (#TextA "host") - #Nil)))))))))))] + (#Cons (#TextA "catching") + (#Cons (#TextA "host") + #Nil))))))))))))] (#Cons [["lux" "doc"] (#TextA "Represents the state of the Lux compiler during a run. It is provided to macros during their invocation, so they can access compiler data. @@ -1714,7 +1719,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (_lux_case (get module modules) (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _}) (_lux_case (get name defs) @@ -1873,7 +1878,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} (_lux_case (reverse scopes) (#Cons {#name (#;Cons module-name #Nil) #inner-closures _ #locals _ #closure _} _) (#Right [state module-name]) @@ -2273,7 +2278,7 @@ #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} (#Right state (find-macro' modules current-module module name))))))) (def:''' (macro? ident) @@ -2528,12 +2533,12 @@ #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching catching} (#Right {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed (n.+ +1 seed) #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching catching} (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))])))) (macro:' #export (Rec tokens) @@ -3375,7 +3380,7 @@ (let [{#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (case (get name modules) (#Some module) (#Right state module) @@ -3438,7 +3443,7 @@ (let [{#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (case expected (#Some type) (#Right state type) @@ -3961,7 +3966,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} modules)] (case (get module modules) (#Some =module) @@ -4016,7 +4021,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} (find (: (-> Scope (Maybe Type)) (lambda [env] (case env @@ -4036,7 +4041,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (case (get v-prefix modules) #None #None @@ -4055,7 +4060,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (case (get v-prefix modules) #None (#Left (Text/append "Unknown definition: " (Ident/encode name))) @@ -5409,7 +5414,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} (#Right state scope-type-vars) )) @@ -5518,7 +5523,7 @@ (let [{#;info info #;source source #;modules modules #;scopes scopes #;type-vars types #;host host #;seed seed #;expected expected #;cursor cursor - #;scope-type-vars scope-type-vars} state] + #;scope-type-vars scope-type-vars #catching _} state] (#;Right [state cursor])))) (macro: #export (with-cursor tokens) -- cgit v1.3.1 From 8003120870b877264afcfc5bc785453ae55e2a7b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 5 Feb 2017 23:12:18 -0400 Subject: - Added support for compiling _lux_proc (some procedures). - Added support for compiling (some) procedures, captured-variables, iteration, if-expressions and get-expressions. - Fixed some bugs. --- luxc/src/lux/analyser.clj | 5 +- luxc/src/lux/analyser/jvm.clj | 73 +++++++ luxc/src/lux/analyser/proc.clj | 285 ++++++++++++++++++++++++++ luxc/src/lux/base.clj | 113 ++++++----- luxc/src/lux/compiler/js.clj | 22 +- luxc/src/lux/compiler/js/base.clj | 3 + luxc/src/lux/compiler/js/lux.clj | 169 +++++++--------- luxc/src/lux/compiler/js/proc.clj | 364 ++++++++++++++++++++++++++++++++++ luxc/src/lux/compiler/jvm/host.clj | 104 ++++++++-- stdlib/source/lux.lux | 298 ++++++++++++++-------------- stdlib/source/lux/control/comonad.lux | 11 +- stdlib/source/lux/control/monad.lux | 13 +- stdlib/source/lux/data/coll/list.lux | 2 +- stdlib/source/lux/io.lux | 2 +- stdlib/source/lux/macro/ast.lux | 2 +- 15 files changed, 1131 insertions(+), 335 deletions(-) create mode 100644 luxc/src/lux/analyser/proc.clj create mode 100644 luxc/src/lux/compiler/js/proc.clj (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index b611c1f80..977911c28 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -10,6 +10,7 @@ (lux.analyser [base :as &&] [lux :as &&lux] [jvm :as &&jvm] + [proc :as &&proc] [module :as &&module] [parser :as &&a-parser]))) @@ -132,7 +133,9 @@ (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type - (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args))) + (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) + ;; (&&proc/analyse-proc analyse exo-type ?category ?proc ?args) + )) "_lux_:" (|let [(&/$Cons ?type diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj index b82c634d6..6146551ef 100644 --- a/luxc/src/lux/analyser/jvm.clj +++ b/luxc/src/lux/analyser/jvm.clj @@ -1068,6 +1068,15 @@ ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-int-add ["int" "+"] &type/Int &type/Int + ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int + ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int + ^:private analyse-int-div ["int" "/"] &type/Int &type/Int + ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int + ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool + ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool + ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg @@ -1075,6 +1084,15 @@ ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool + + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-real-add ["real" "+"] &type/Real &type/Real + ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real + ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real + ^:private analyse-real-div ["real" "/"] &type/Real &type/Real + ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real + ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool + ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool ) (defn ^:private analyse-deg-scale [analyse exo-type ?values] @@ -1105,7 +1123,11 @@ (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real ) (do-template [ ] @@ -1119,8 +1141,16 @@ ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-int-min-value &type/Int ["int" "min-value"] + ^:private analyse-int-max-value &type/Int ["int" "max-value"] + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-real-min-value &type/Real ["real" "min-value"] + ^:private analyse-real-max-value &type/Real ["real" "max-value"] ) (do-template [ ] @@ -1141,6 +1171,22 @@ ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] ) +;; TODO: USE COMMON PROC ANALYSIS +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-append ["text" "append"] &type/Text &type/Text + ) +;; TODO: USE COMMON PROC ANALYSIS + (defn analyse-host [analyse exo-type compilers category proc ?values] (|let [[_ _ _ compile-class compile-interface] compilers] (case category @@ -1148,6 +1194,11 @@ (case proc "==" (analyse-lux-== analyse exo-type ?values)) + "text" + (case proc + "=" (analyse-text-eq analyse exo-type ?values) + "append" (analyse-text-append analyse exo-type ?values)) + "bit" (case proc "count" (analyse-bit-count analyse exo-type ?values) @@ -1202,11 +1253,33 @@ "int" (case proc + "+" (analyse-int-add analyse exo-type ?values) + "-" (analyse-int-sub analyse exo-type ?values) + "*" (analyse-int-mul analyse exo-type ?values) + "/" (analyse-int-div analyse exo-type ?values) + "%" (analyse-int-rem analyse exo-type ?values) + "=" (analyse-int-eq analyse exo-type ?values) + "<" (analyse-int-lt analyse exo-type ?values) + "encode" (analyse-int-encode analyse exo-type ?values) + "decode" (analyse-int-decode analyse exo-type ?values) + "min-value" (analyse-int-min-value analyse exo-type ?values) + "max-value" (analyse-int-max-value analyse exo-type ?values) "to-nat" (analyse-int-to-nat analyse exo-type ?values) ) "real" (case proc + "+" (analyse-real-add analyse exo-type ?values) + "-" (analyse-real-sub analyse exo-type ?values) + "*" (analyse-real-mul analyse exo-type ?values) + "/" (analyse-real-div analyse exo-type ?values) + "%" (analyse-real-rem analyse exo-type ?values) + "=" (analyse-real-eq analyse exo-type ?values) + "<" (analyse-real-lt analyse exo-type ?values) + "encode" (analyse-real-encode analyse exo-type ?values) + "decode" (analyse-real-decode analyse exo-type ?values) + "min-value" (analyse-real-min-value analyse exo-type ?values) + "max-value" (analyse-real-max-value analyse exo-type ?values) "to-deg" (analyse-real-to-deg analyse exo-type ?values) ) diff --git a/luxc/src/lux/analyser/proc.clj b/luxc/src/lux/analyser/proc.clj new file mode 100644 index 000000000..a71a1a9e5 --- /dev/null +++ b/luxc/src/lux/analyser/proc.clj @@ -0,0 +1,285 @@ +(ns lux.analyser.proc + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type]) + (lux.analyser [base :as &&]))) + +(defn ^:private analyse-lux-== [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] + =left (&&/analyse-1 analyse $var left) + =right (&&/analyse-1 analyse $var right) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-append ["text" "append"] &type/Text &type/Text + ) + +;; (do-template [ ] +;; (defn [analyse exo-type ?values] +;; (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] +;; =mask (&&/analyse-1 analyse &type/Nat mask) +;; =input (&&/analyse-1 analyse &type/Nat input) +;; _ (&type/check exo-type &type/Nat) +;; _cursor &/cursor] +;; (return (&/|list (&&/|meta exo-type _cursor +;; (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) + +;; ^:private analyse-bit-and "and" +;; ^:private analyse-bit-or "or" +;; ^:private analyse-bit-xor "xor" +;; ) + +;; (defn ^:private analyse-bit-count [analyse exo-type ?values] +;; (|do [:let [(&/$Cons input (&/$Nil)) ?values] +;; =input (&&/analyse-1 analyse &type/Nat input) +;; _ (&type/check exo-type &type/Nat) +;; _cursor &/cursor] +;; (return (&/|list (&&/|meta exo-type _cursor +;; (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) + +;; (do-template [ ] +;; (defn [analyse exo-type ?values] +;; (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] +;; =shift (&&/analyse-1 analyse &type/Nat shift) +;; =input (&&/analyse-1 analyse input) +;; _ (&type/check exo-type ) +;; _cursor &/cursor] +;; (return (&/|list (&&/|meta exo-type _cursor +;; (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) + +;; ^:private analyse-bit-shift-left "shift-left" &type/Nat +;; ^:private analyse-bit-shift-right "shift-right" &type/Int +;; ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat +;; ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat + ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat + ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat + ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat + ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat + ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool + ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + + ^:private analyse-int-add ["int" "+"] &type/Int &type/Int + ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int + ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int + ^:private analyse-int-div ["int" "/"] &type/Int &type/Int + ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int + ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool + ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool + + ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg + ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg + ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg + ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg + ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg + ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool + ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool + + ^:private analyse-real-add ["real" "+"] &type/Real &type/Real + ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real + ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real + ^:private analyse-real-div ["real" "/"] &type/Real &type/Real + ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real + ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool + ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool + ) + +(defn ^:private analyse-deg-scale [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse &type/Deg x) + =y (&&/analyse-1 analyse &type/Nat y) + _ (&type/check exo-type &type/Deg) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Deg _cursor + (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) + +(do-template [ ] + (do (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe )] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _cursor &/cursor] + (return (&/|list (&&/|meta decode-type _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) + + ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int + ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg + ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list) (&/|list))))))) + + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + + ^:private analyse-int-min-value &type/Int ["int" "min-value"] + ^:private analyse-int-max-value &type/Int ["int" "max-value"] + + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] + ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ) + +(defn analyse-proc [analyse exo-type category proc ?values] + (case category + ;; "lux" + ;; (case proc + ;; "==" (analyse-lux-== analyse exo-type ?values)) + + "text" + (case proc + "=" (analyse-text-eq analyse exo-type ?values) + "append" (analyse-text-append analyse exo-type ?values)) + + ;; "bit" + ;; (case proc + ;; "count" (analyse-bit-count analyse exo-type ?values) + ;; "and" (analyse-bit-and analyse exo-type ?values) + ;; "or" (analyse-bit-or analyse exo-type ?values) + ;; "xor" (analyse-bit-xor analyse exo-type ?values) + ;; "shift-left" (analyse-bit-shift-left analyse exo-type ?values) + ;; "shift-right" (analyse-bit-shift-right analyse exo-type ?values) + ;; "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) + + ;; "array" + ;; (case proc + ;; "new" (analyse-array-new analyse exo-type ?values) + ;; "get" (analyse-array-get analyse exo-type ?values) + ;; "put" (analyse-jvm-aastore analyse exo-type ?values) + ;; "remove" (analyse-array-remove analyse exo-type ?values) + ;; "size" (analyse-jvm-arraylength analyse exo-type ?values)) + + "nat" + (case proc + "+" (analyse-nat-add analyse exo-type ?values) + "-" (analyse-nat-sub analyse exo-type ?values) + "*" (analyse-nat-mul analyse exo-type ?values) + "/" (analyse-nat-div analyse exo-type ?values) + "%" (analyse-nat-rem analyse exo-type ?values) + "=" (analyse-nat-eq analyse exo-type ?values) + "<" (analyse-nat-lt analyse exo-type ?values) + "encode" (analyse-nat-encode analyse exo-type ?values) + "decode" (analyse-nat-decode analyse exo-type ?values) + "min-value" (analyse-nat-min-value analyse exo-type ?values) + "max-value" (analyse-nat-max-value analyse exo-type ?values) + "to-int" (analyse-nat-to-int analyse exo-type ?values) + "to-char" (analyse-nat-to-char analyse exo-type ?values) + ) + + "int" + (case proc + "+" (analyse-int-add analyse exo-type ?values) + "-" (analyse-int-sub analyse exo-type ?values) + "*" (analyse-int-mul analyse exo-type ?values) + "/" (analyse-int-div analyse exo-type ?values) + "%" (analyse-int-rem analyse exo-type ?values) + "=" (analyse-int-eq analyse exo-type ?values) + "<" (analyse-int-lt analyse exo-type ?values) + "encode" (analyse-int-encode analyse exo-type ?values) + "decode" (analyse-int-decode analyse exo-type ?values) + "min-value" (analyse-int-min-value analyse exo-type ?values) + "max-value" (analyse-int-max-value analyse exo-type ?values) + "to-nat" (analyse-int-to-nat analyse exo-type ?values) + ) + + "deg" + (case proc + "+" (analyse-deg-add analyse exo-type ?values) + "-" (analyse-deg-sub analyse exo-type ?values) + "*" (analyse-deg-mul analyse exo-type ?values) + "/" (analyse-deg-div analyse exo-type ?values) + "%" (analyse-deg-rem analyse exo-type ?values) + "=" (analyse-deg-eq analyse exo-type ?values) + "<" (analyse-deg-lt analyse exo-type ?values) + ;; "encode" (analyse-deg-encode analyse exo-type ?values) + ;; "decode" (analyse-deg-decode analyse exo-type ?values) + ;; "min-value" (analyse-deg-min-value analyse exo-type ?values) + ;; "max-value" (analyse-deg-max-value analyse exo-type ?values) + ;; "to-real" (analyse-deg-to-real analyse exo-type ?values) + ;; "scale" (analyse-deg-scale analyse exo-type ?values) + ) + + "real" + (case proc + "+" (analyse-real-add analyse exo-type ?values) + "-" (analyse-real-sub analyse exo-type ?values) + "*" (analyse-real-mul analyse exo-type ?values) + "/" (analyse-real-div analyse exo-type ?values) + "%" (analyse-real-rem analyse exo-type ?values) + "=" (analyse-real-eq analyse exo-type ?values) + "<" (analyse-real-lt analyse exo-type ?values) + "encode" (analyse-real-encode analyse exo-type ?values) + ;; "decode" (analyse-real-decode analyse exo-type ?values) + ;; "min-value" (analyse-real-min-value analyse exo-type ?values) + ;; "max-value" (analyse-real-max-value analyse exo-type ?values) + ;; "to-deg" (analyse-real-to-real analyse exo-type ?values) + ) + + ;; "char" + ;; (case proc + ;; "to-nat" (analyse-char-to-nat analyse exo-type ?values) + ;; ) + + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 6ab09166e..1c34926aa 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -4,6 +4,11 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) +(def !log! (atom false)) +(defn flag-prn! [& args] + (when @!log! + (apply prn args))) + ;; [Tags] (def unit-tag (.intern (str (char 0) "unit" (char 0)))) @@ -1019,13 +1024,13 @@ (let [clean-separators (fn [^String input] (.replaceAll input "_" "")) deg-text-to-digits (fn [^String input] - (loop [output (vec (repeat deg-bits 0)) - index (dec (.length input))] - (if (>= index 0) - (let [digit (Byte/parseByte (.substring input index (inc index)))] - (recur (assoc output index digit) - (dec index))) - output))) + (loop [output (vec (repeat deg-bits 0)) + index (dec (.length input))] + (if (>= index 0) + (let [digit (Byte/parseByte (.substring input index (inc index)))] + (recur (assoc output index digit) + (dec index))) + output))) times5 (fn [index digits] (loop [index index carry 0 @@ -1037,58 +1042,58 @@ (assoc digits index (rem raw 10)))) digits))) deg-digit-power (fn [level] - (loop [output (-> (vec (repeat deg-bits 0)) - (assoc level 1)) - times level] - (if (>= times 0) - (recur (times5 level output) - (dec times)) - output))) + (loop [output (-> (vec (repeat deg-bits 0)) + (assoc level 1)) + times level] + (if (>= times 0) + (recur (times5 level output) + (dec times)) + output))) deg-digits-lt (fn deg-digits-lt - ([subject param index] - (and (< index deg-bits) - (or (< (get subject index) - (get param index)) - (and (= (get subject index) - (get param index)) - (deg-digits-lt subject param (inc index)))))) - ([subject param] - (deg-digits-lt subject param 0))) + ([subject param index] + (and (< index deg-bits) + (or (< (get subject index) + (get param index)) + (and (= (get subject index) + (get param index)) + (deg-digits-lt subject param (inc index)))))) + ([subject param] + (deg-digits-lt subject param 0))) deg-digits-sub-once (fn [subject param-digit index] - (if (>= (get subject index) - param-digit) - (update-in subject [index] #(- % param-digit)) - (recur (update-in subject [index] #(- 10 (- param-digit %))) - 1 - (dec index)))) + (if (>= (get subject index) + param-digit) + (update-in subject [index] #(- % param-digit)) + (recur (update-in subject [index] #(- 10 (- param-digit %))) + 1 + (dec index)))) deg-digits-sub (fn [subject param] - (loop [target subject - index (dec deg-bits)] - (if (>= index 0) - (recur (deg-digits-sub-once target (get param index) index) - (dec index)) - target))) + (loop [target subject + index (dec deg-bits)] + (if (>= index 0) + (recur (deg-digits-sub-once target (get param index) index) + (dec index)) + target))) deg-digits-to-text (fn [digits] - (loop [output "" - index (dec deg-bits)] - (if (>= index 0) - (recur (-> (get digits index) - (Character/forDigit 10) - (str output)) - (dec index)) - output))) + (loop [output "" + index (dec deg-bits)] + (if (>= index 0) + (recur (-> (get digits index) + (Character/forDigit 10) + (str output)) + (dec index)) + output))) add-deg-digit-powers (fn [dl dr] - (loop [index (dec deg-bits) - output (vec (repeat deg-bits 0)) - carry 0] - (if (>= index 0) - (let [raw (+ carry - (get dl index) - (get dr index))] - (recur (dec index) - (assoc output index (rem raw 10)) - (int (/ raw 10)))) - output)))] + (loop [index (dec deg-bits) + output (vec (repeat deg-bits 0)) + carry 0] + (if (>= index 0) + (let [raw (+ carry + (get dl index) + (get dr index))] + (recur (dec index) + (assoc output index (rem raw 10)) + (int (/ raw 10)))) + output)))] ;; Based on the LuxRT.encode_deg method (defn encode-deg [input] (if (= 0 input) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 8901bc154..6aa5d5915 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -22,7 +22,7 @@ ;; [cache :as &&cache] [lux :as &&lux] [rt :as &&rt] - ;; [host :as &&host] + [proc :as &&proc] ) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory @@ -62,8 +62,8 @@ (&o/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?idx) - ;; (&o/$captured ?scope ?captured-id ?source) - ;; (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) + (&o/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) (&o/$var (&/$Global ?module ?name)) (&&lux/compile-global ?module ?name) @@ -74,8 +74,8 @@ ;; (&o/$loop _register-offset _inits _body) ;; (&&lux/compile-loop compile-expression _register-offset _inits _body) - ;; (&o/$iter _register-offset ?args) - ;; (&&lux/compile-iter compile-expression _register-offset ?args) + (&o/$iter _register-offset ?args) + (&&lux/compile-iter compile-expression _register-offset ?args) (&o/$variant ?tag ?tail ?members) (&&lux/compile-variant compile-expression ?tag ?tail ?members) @@ -86,11 +86,11 @@ (&o/$let _value _register _body) (&&lux/compile-let compile-expression _value _register _body) - ;; (&o/$record-get _value _path) - ;; (&&lux/compile-record-get compile-expression _value _path) + (&o/$record-get _value _path) + (&&lux/compile-record-get compile-expression _value _path) - ;; (&o/$if _test _then _else) - ;; (&&lux/compile-if compile-expression _test _then _else) + (&o/$if _test _then _else) + (&&lux/compile-if compile-expression _test _then _else) (&o/$function _register-offset ?arity ?scope ?env ?body) (&&lux/compile-function compile-expression ?arity ?scope ?env ?body) @@ -98,8 +98,8 @@ (&o/$ann ?value-ex ?type-ex) (compile-expression ?value-ex) - ;; (&o/$proc [?proc-category ?proc-name] ?args special-args) - ;; (&&host/compile-host compile-expression ?proc-category ?proc-name ?args special-args) + (&o/$proc [?proc-category ?proc-name] ?args special-args) + (&&proc/compile-proc compile-expression ?proc-category ?proc-name ?args special-args) _ (assert false (prn-str 'JS=compile-expression (&/adt->text syntax)))) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index f89bbb9a2..b88d4dc00 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -93,6 +93,9 @@ (instance? java.lang.String js-object)) js-object + (instance? java.lang.Number js-object) + (long js-object) + (instance? LuxJsObject js-object) (.-obj ^LuxJsObject js-object) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 3324a83c7..578eb74f8 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -22,6 +22,9 @@ (defn ^:private js-var-name [module name] (str (string/replace module "/" "$") "$" (&host/def-name name))) +(defn ^:private captured-name [register] + (str "$" register)) + (defn ^:private register-name [register] (str "_" register)) @@ -31,7 +34,7 @@ (do-template [] (defn [value] - (return (str value "|0"))) + (return (str "(" value "|0)"))) compile-nat compile-int @@ -70,16 +73,8 @@ (defn compile-local [compile register] (return (register-name register))) -;; (defn compile-captured [compile ?scope ?captured-id ?source] -;; (|do [:let [??scope (&/|reverse ?scope)] -;; ^MethodVisitor *writer* &/get-writer -;; :let [_ (doto *writer* -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitFieldInsn Opcodes/GETFIELD -;; (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) -;; (str &&/closure-prefix ?captured-id) -;; "Ljava/lang/Object;"))]] -;; (return nil))) +(defn compile-captured [compile ?scope ?captured-id ?source] + (return (captured-name ?captured-id))) (defn compile-global [module name] (return (js-var-name module name))) @@ -105,38 +100,31 @@ ;; (compile-expression $begin body) ;; )) -;; (defn compile-iter [compile $begin register-offset ?args] -;; (|do [^MethodVisitor *writer* &/get-writer -;; :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) -;; ?args)] -;; _ (&/map% (fn [idx+?arg] -;; (|do [:let [[idx ?arg] idx+?arg -;; idx+ (+ register-offset idx) -;; already-set? (|case ?arg -;; [_ (&o/$var (&/$Local l-idx))] -;; (= idx+ l-idx) - -;; _ -;; false)]] -;; (if already-set? -;; (return nil) -;; (compile ?arg)))) -;; idxs+args) -;; _ (&/map% (fn [idx+?arg] -;; (|do [:let [[idx ?arg] idx+?arg -;; idx+ (+ register-offset idx) -;; already-set? (|case ?arg -;; [_ (&o/$var (&/$Local l-idx))] -;; (= idx+ l-idx) - -;; _ -;; false)] -;; :let [_ (when (not already-set?) -;; (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] -;; (return nil))) -;; (&/|reverse idxs+args)) -;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] -;; (return nil))) +(defn compile-iter [compile register-offset ?args] + ;; Can only optimize if it is a simple expression. + ;; Won't work if it's inside an 'if', unlike on the JVM. + ;; (|do [[updates _] (&/fold% (fn [updates+offset ?arg] + ;; (|let [[updates offset] updates+offset + ;; already-set? (|case ?arg + ;; [_ (&o/$var (&/$Local l-idx))] + ;; (= offset l-idx) + + ;; _ + ;; false)] + ;; (if already-set? + ;; (return (&/T [updates (inc offset)])) + ;; (|do [=arg (compile ?arg)] + ;; (return (&/T [(str updates + ;; (register-name offset) " = " =arg ";") + ;; (inc offset)])))))) + ;; (&/T ["" register-offset]) + ;; ?args)] + ;; (return updates)) + (|do [=args (&/map% compile ?args)] + (return (str "_0(" + (->> =args (&/|interpose ",") (&/fold str "")) + ")"))) + ) (defn compile-let [compile _value _register _body] (|do [=value (compile _value) @@ -146,35 +134,20 @@ " return " =body ";})()")))) -;; (defn compile-record-get [compile _value _path] -;; (|do [^MethodVisitor *writer* &/get-writer -;; _ (compile _value) -;; :let [_ (&/|map (fn [step] -;; (|let [[idx tail?] step] -;; (doto *writer* -;; (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") -;; (.visitLdcInsn (int idx)) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" -;; (if tail? "product_getRight" "product_getLeft") -;; "([Ljava/lang/Object;I)Ljava/lang/Object;")))) -;; _path)]] -;; (return nil))) - -;; (defn compile-if [compile _test _then _else] -;; (|do [^MethodVisitor *writer* &/get-writer -;; _ (compile _test) -;; :let [$else (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; &&/unwrap-boolean -;; (.visitJumpInsn Opcodes/IFEQ $else))] -;; _ (compile _then) -;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] -;; :let [_ (.visitLabel *writer* $else)] -;; _ (compile _else) -;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) -;; _ (.visitLabel *writer* $end)]] -;; (return nil))) +(defn compile-record-get [compile _value _path] + (|do [=value (compile _value)] + (return (&/fold (fn [source step] + (|let [[idx tail?] step + method (if tail? "product_getRight" "product_getLeft")] + (str &&rt/LuxRT "." method "(" source "," idx ")"))) + (str "(" =value ")") + _path)))) + +(defn compile-if [compile _test _then _else] + (|do [=test (compile _test) + =then (compile _then) + =else (compile _else)] + (return (str "(" =test " ? " =then " : " =else ")")))) (def ^:private savepoint "pm_cursor_savepoint") (def ^:private cursor "pm_cursor") @@ -307,27 +280,39 @@ func-args (->> (&/|range* 0 (dec arity)) (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) (&/fold str ""))] + =env (&/map% (fn [=captured] + (|case =captured + [_ (&o/$captured ?scope ?captured-id ?source)] + (|do [=source (compile ?source)] + (return (str "var " (captured-name ?captured-id) " = " =source ";"))))) + (&/|vals ?env)) =body (compile ?body)] - (return (str "(function " function-name "() {" - "\"use strict\";" - "var num_args = arguments.length;" - "if(num_args == " arity ") {" - "var " (register-name 0) " = " function-name ";" - func-args - "return " =body ";" - "}" - "else if(num_args > " arity ") {" - "return " function-name ".apply(null, [].slice.call(arguments,0," arity "))" - ".apply(null, [].slice.call(arguments," arity "));" - "}" - ;; Less than arity - "else {" - "var curried = [].slice.call(arguments);" - "return function() { " - "return " function-name ".apply(null, curried.concat([].slice.call(arguments)));" - " };" - "}" - "})")))) + (return (str "(function() {" + (->> =env (&/fold str "")) + "return " + (str "(function " function-name "() {" + "\"use strict\";" + "var num_args = arguments.length;" + "if(num_args == " arity ") {" + "var " (register-name 0) " = " function-name ";" + func-args + (str "while(true) {" + "return " =body ";" + "}") + "}" + "else if(num_args > " arity ") {" + "return " function-name ".apply(null, [].slice.call(arguments,0," arity "))" + ".apply(null, [].slice.call(arguments," arity "));" + "}" + ;; Less than arity + "else {" + "var curried = [].slice.call(arguments);" + "return function() { " + "return " function-name ".apply(null, curried.concat([].slice.call(arguments)));" + " };" + "}" + "})") + ";})()")))) (defn compile-def [compile ?name ?body def-meta] (|do [module-name &/get-module-name diff --git a/luxc/src/lux/compiler/js/proc.clj b/luxc/src/lux/compiler/js/proc.clj new file mode 100644 index 000000000..95e6950da --- /dev/null +++ b/luxc/src/lux/compiler/js/proc.clj @@ -0,0 +1,364 @@ +(ns lux.compiler.js.proc + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [analyser :as &analyser] + [optimizer :as &o]) + [lux.analyser.base :as &a] + [lux.compiler.js.base :as &&])) + +;; [Resources] +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; _ (compile ?mask) +;; :let [_ (&&/unwrap-long *writer*)] +;; :let [_ (doto *writer* +;; (.visitInsn ) +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-bit-and Opcodes/LAND +;; ^:private compile-bit-or Opcodes/LOR +;; ^:private compile-bit-xor Opcodes/LXOR +;; ) + +;; (defn ^:private compile-bit-count [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; :let [_ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") +;; (.visitInsn Opcodes/I2L) +;; &&/wrap-long)]] +;; (return nil))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; _ (compile ?shift) +;; :let [_ (doto *writer* +;; &&/unwrap-long +;; (.visitInsn Opcodes/L2I))] +;; :let [_ (doto *writer* +;; (.visitInsn ) +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-bit-shift-left Opcodes/LSHL +;; ^:private compile-bit-shift-right Opcodes/LSHR +;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR +;; ) + +;; (defn ^:private compile-lux-== [compile ?values special-args] +;; (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?left) +;; _ (compile ?right) +;; :let [$then (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; (.visitJumpInsn Opcodes/IF_ACMPEQ $then) +;; ;; else +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") +;; (.visitJumpInsn Opcodes/GOTO $end) +;; (.visitLabel $then) +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") +;; (.visitLabel $end))]] +;; (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x " " " " =y ")")))) + + ^:private compile-nat-add "+" + ^:private compile-nat-sub "-" + ^:private compile-nat-mul "*" + ^:private compile-nat-div "/" + ^:private compile-nat-rem "%" + ^:private compile-nat-eq "===" + ^:private compile-nat-lt "<" + + ^:private compile-int-add "+" + ^:private compile-int-sub "-" + ^:private compile-int-mul "*" + ^:private compile-int-div "/" + ^:private compile-int-rem "%" + ^:private compile-int-eq "===" + ^:private compile-int-lt "<" + + ^:private compile-deg-add "+" + ^:private compile-deg-sub "-" + ^:private compile-deg-mul "*" + ^:private compile-deg-div "/" + ^:private compile-deg-rem "%" + ^:private compile-deg-eq "===" + ^:private compile-deg-lt "<" + ^:private compile-deg-scale "*" + + ^:private compile-real-add "+" + ^:private compile-real-sub "-" + ^:private compile-real-mul "*" + ^:private compile-real-div "/" + ^:private compile-real-rem "%" + ^:private compile-real-eq "===" + ^:private compile-real-lt "<" + ) + +;; (defn ^:private compile-nat-lt [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; _ (compile ?y) +;; :let [_ (doto *writer* +;; &&/unwrap-long) +;; $then (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") +;; (.visitLdcInsn (int -1)) +;; (.visitJumpInsn Opcodes/IF_ICMPEQ $then) +;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) +;; (.visitJumpInsn Opcodes/GOTO $end) +;; (.visitLabel $then) +;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) +;; (.visitLabel $end))]] +;; (return nil))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Nil) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; :let [_ (doto *writer* +;; +;; )]] +;; (return nil))) + +;; ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long +;; ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + +;; ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long +;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long +;; ) + +;; (do-template [ ] +;; (do (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] +;; (return nil))) + +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] +;; (return nil))))) + +;; ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" +;; ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" +;; ) + +(defn compile-int-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "(" =x ").toString()")))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; _ (compile ?y) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; :let [_ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-deg-mul "mul_deg" +;; ^:private compile-deg-div "div_deg" +;; ) + +;; (do-template [ ] +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) +;; )]] +;; (return nil)))) + +;; ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double +;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long +;; ) + +;; (let [widen (fn [^MethodVisitor *writer*] +;; (doto *writer* +;; (.visitInsn Opcodes/I2L))) +;; shrink (fn [^MethodVisitor *writer*] +;; (doto *writer* +;; (.visitInsn Opcodes/L2I) +;; (.visitInsn Opcodes/I2C)))] +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; +;; +;; )]] +;; (return nil))) + +;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink +;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen +;; )) + +(do-template [] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] + (compile ?x))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + +(defn compile-text-eq [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x "===" =y ")")))) + +(defn compile-text-append [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str =x ".concat(" =y ")")))) + +(defn compile-proc [compile proc-category proc-name ?values special-args] + (case proc-category + ;; "lux" + ;; (case proc-name + ;; "==" (compile-lux-== compile ?values special-args)) + + "text" + (case proc-name + "=" (compile-text-eq compile ?values special-args) + "append" (compile-text-append compile ?values special-args)) + + ;; "bit" + ;; (case proc-name + ;; "count" (compile-bit-count compile ?values special-args) + ;; "and" (compile-bit-and compile ?values special-args) + ;; "or" (compile-bit-or compile ?values special-args) + ;; "xor" (compile-bit-xor compile ?values special-args) + ;; "shift-left" (compile-bit-shift-left compile ?values special-args) + ;; "shift-right" (compile-bit-shift-right compile ?values special-args) + ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + + ;; "array" + ;; (case proc-name + ;; "get" (compile-array-get compile ?values special-args)) + + "nat" + (case proc-name + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) + ;; "encode" (compile-nat-encode compile ?values special-args) + ;; "decode" (compile-nat-decode compile ?values special-args) + ;; "max-value" (compile-nat-max-value compile ?values special-args) + ;; "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + ;; "to-char" (compile-nat-to-char compile ?values special-args) + ) + + "int" + (case proc-name + "+" (compile-int-add compile ?values special-args) + "-" (compile-int-sub compile ?values special-args) + "*" (compile-int-mul compile ?values special-args) + "/" (compile-int-div compile ?values special-args) + "%" (compile-int-rem compile ?values special-args) + "=" (compile-int-eq compile ?values special-args) + "<" (compile-int-lt compile ?values special-args) + "encode" (compile-int-encode compile ?values special-args) + ;; "decode" (compile-int-decode compile ?values special-args) + ;; "max-value" (compile-int-max-value compile ?values special-args) + ;; "min-value" (compile-int-min-value compile ?values special-args) + "to-nat" (compile-int-to-nat compile ?values special-args) + ) + + "deg" + (case proc-name + "+" (compile-deg-add compile ?values special-args) + "-" (compile-deg-sub compile ?values special-args) + "*" (compile-deg-mul compile ?values special-args) + "/" (compile-deg-div compile ?values special-args) + "%" (compile-deg-rem compile ?values special-args) + "=" (compile-deg-eq compile ?values special-args) + "<" (compile-deg-lt compile ?values special-args) + ;; "encode" (compile-deg-encode compile ?values special-args) + ;; "decode" (compile-deg-decode compile ?values special-args) + ;; "max-value" (compile-deg-max-value compile ?values special-args) + ;; "min-value" (compile-deg-min-value compile ?values special-args) + ;; "to-real" (compile-deg-to-real compile ?values special-args) + "scale" (compile-deg-scale compile ?values special-args) + ) + + "real" + (case proc-name + "+" (compile-real-add compile ?values special-args) + "-" (compile-real-sub compile ?values special-args) + "*" (compile-real-mul compile ?values special-args) + "/" (compile-real-div compile ?values special-args) + "%" (compile-real-rem compile ?values special-args) + "=" (compile-real-eq compile ?values special-args) + "<" (compile-real-lt compile ?values special-args) + ;; "encode" (compile-real-encode compile ?values special-args) + ;; "decode" (compile-real-decode compile ?values special-args) + ;; "max-value" (compile-real-max-value compile ?values special-args) + ;; "min-value" (compile-real-min-value compile ?values special-args) + ;; "to-deg" (compile-real-to-deg compile ?values special-args) + ) + + ;; "char" + ;; (case proc-name + ;; "to-nat" (compile-char-to-nat compile ?values special-args) + ;; ) + + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/jvm/host.clj b/luxc/src/lux/compiler/jvm/host.clj index 34a5a2bb7..9583c3106 100644 --- a/luxc/src/lux/compiler/jvm/host.clj +++ b/luxc/src/lux/compiler/jvm/host.clj @@ -1954,6 +1954,12 @@ (.visitLabel $end))]] (return nil))) + ^:private compile-int-eq Opcodes/LCMP 0 &&/unwrap-long + ^:private compile-int-lt Opcodes/LCMP -1 &&/unwrap-long + + ^:private compile-real-eq Opcodes/DCMPG 0 &&/unwrap-double + ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double + ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long @@ -2383,29 +2389,41 @@ (.visitLabel $end))]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* - &&/unwrap-long)] + )] _ (compile ?y) :let [_ (doto *writer* - &&/unwrap-long) + ) _ (doto *writer* (.visitInsn ) - &&/wrap-long)]] + )]] (return nil))) - ^:private compile-nat-add Opcodes/LADD - ^:private compile-nat-sub Opcodes/LSUB - ^:private compile-nat-mul Opcodes/LMUL - - ^:private compile-deg-add Opcodes/LADD - ^:private compile-deg-sub Opcodes/LSUB - ^:private compile-deg-rem Opcodes/LSUB - ^:private compile-deg-scale Opcodes/LMUL + ^:private compile-int-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-int-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-int-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long + ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long + ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long + + ^:private compile-nat-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-nat-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-nat-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long + + ^:private compile-deg-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-deg-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-deg-rem Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-deg-scale Opcodes/LMUL &&/unwrap-long &&/wrap-long + + ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double ) (do-template [ ] @@ -2518,6 +2536,24 @@ ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" ) +(defn ^:private compile-int-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;"))]] + (return nil))) + +(defn ^:private compile-real-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -2586,11 +2622,39 @@ ^:private compile-int-to-nat ) +(defn compile-text-eq [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + _ (compile ?y) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (&&/wrap-boolean))]] + (return nil))) + +(defn compile-text-append [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] + (return nil))) + (defn compile-host [compile proc-category proc-name ?values special-args] (case proc-category "lux" (case proc-name "==" (compile-lux-== compile ?values special-args)) + + "text" + (case proc-name + "=" (compile-text-eq compile ?values special-args) + "append" (compile-text-append compile ?values special-args)) "bit" (case proc-name @@ -2642,11 +2706,27 @@ "int" (case proc-name + "+" (compile-int-add compile ?values special-args) + "-" (compile-int-sub compile ?values special-args) + "*" (compile-int-mul compile ?values special-args) + "/" (compile-int-div compile ?values special-args) + "%" (compile-int-rem compile ?values special-args) + "=" (compile-int-eq compile ?values special-args) + "<" (compile-int-lt compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) + "encode" (compile-int-encode compile ?values special-args) ) "real" (case proc-name + "+" (compile-real-add compile ?values special-args) + "-" (compile-real-sub compile ?values special-args) + "*" (compile-real-mul compile ?values special-args) + "/" (compile-real-div compile ?values special-args) + "%" (compile-real-rem compile ?values special-args) + "=" (compile-real-eq compile ?values special-args) + "<" (compile-real-lt compile ?values special-args) + "encode" (compile-real-encode compile ?values special-args) "to-deg" (compile-real-to-deg compile ?values special-args) ) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index cd16ce35f..1c74cac80 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -323,11 +323,11 @@ ## (type: Cursor ## {#module Text -## #line Int -## #column Int}) +## #line Nat +## #column Nat}) (_lux_def Cursor (#NamedT ["lux" "Cursor"] - (#ProdT Text (#ProdT Int Int))) + (#ProdT Text (#ProdT Nat Nat))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module") (#Cons (#TextA "line") (#Cons (#TextA "column") @@ -673,16 +673,10 @@ default-def-meta-exported)) ## Base functions & macros -## (def: _cursor -## Cursor -## ["" -1 -1]) (_lux_def _cursor - (_lux_: Cursor ["" -1 -1]) + (_lux_: Cursor ["" +0 +0]) #Nil) -## (def: (_meta data) -## (-> (AST' (Meta Cursor)) AST) -## [["" -1 -1] data]) (_lux_def _meta (_lux_: (#LambdaT (#AppT AST' (#AppT Meta Cursor)) @@ -691,11 +685,6 @@ [_cursor data])) #Nil) -## (def: (return x) -## (All [a] -## (-> a Compiler -## (Either Text [Compiler a]))) -## ...) (_lux_def return (_lux_: (#UnivQ #Nil (#LambdaT (#BoundT +1) @@ -708,11 +697,6 @@ (#Right state val)))) #Nil) -## (def: (fail msg) -## (All [a] -## (-> Text Compiler -## (Either Text [Compiler a]))) -## ...) (_lux_def fail (_lux_: (#UnivQ #Nil (#LambdaT Text @@ -1044,7 +1028,7 @@ (def:'' (Text/= x y) #Nil (#LambdaT Text (#LambdaT Text Bool)) - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [x y])) + (_lux_proc ["text" "="] [x y])) (def:'' (get-rep key env) #Nil @@ -1157,7 +1141,7 @@ #Nil (#UnivQ #Nil (#LambdaT ($' List (#BoundT +1)) Int)) - (fold (lambda'' [_ acc] (_lux_proc ["jvm" "ladd"] [1 acc])) 0 list)) + (fold (lambda'' [_ acc] (_lux_proc ["int" "+"] [1 acc])) 0 list)) (macro:' #export (All tokens) (#Cons [["lux" "doc"] (#TextA "## Universal quantification. @@ -1469,7 +1453,7 @@ (def:''' (wrap-meta content) #Nil (-> AST AST) - (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1))) + (tuple$ (list (tuple$ (list (text$ "") (nat$ +0) (nat$ +0))) content))) (def:''' (untemplate-list tokens) @@ -1685,7 +1669,7 @@ (def:''' (Text/append x y) #Nil (-> Text Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y])) + (_lux_proc ["text" "append"] [x y])) (def:''' (Ident/encode ident) #Nil @@ -1931,12 +1915,12 @@ (macro:' #export (|> tokens) (list [["lux" "doc"] (#TextA "## Piping macro. - (|> elems (map ->Text) (interpose \" \") (fold Text/append \"\")) + (|> elems (map Int/encode) (interpose \" \") (fold Text/append \"\")) ## => (fold Text/append \"\" (interpose \" \" - (map ->Text elems)))")]) + (map Int/encode elems)))")]) (_lux_case tokens (#Cons [init apps]) (return (list (fold (_lux_: (-> AST AST AST) @@ -1958,12 +1942,12 @@ (macro:' #export (<| tokens) (list [["lux" "doc"] (#TextA "## Reverse piping macro. - (<| (fold Text/append \"\") (interpose \" \") (map ->Text) elems) + (<| (fold Text/append \"\") (interpose \" \") (map Int/encode) elems) ## => (fold Text/append \"\" (interpose \" \" - (map ->Text elems)))")]) + (map Int/encode elems)))")]) (_lux_case (reverse tokens) (#Cons [init apps]) (return (list (fold (_lux_: (-> AST AST AST) @@ -2077,12 +2061,46 @@ (def:''' (i= x y) #Nil (-> Int Int Bool) - (_lux_proc ["jvm" "leq"] [x y])) + (_lux_proc ["int" "="] [x y])) -(def:''' (->Text x) +(def:''' (Bool/encode x) #Nil - (-> (host java.lang.Object) Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) + (-> Bool Text) + (if x "true" "false")) + +(def:''' (Nat/encode x) + #Nil + (-> Nat Text) + (_lux_proc ["nat" "encode"] [x])) + +(def:''' (Int/encode x) + #Nil + (-> Int Text) + (_lux_proc ["int" "encode"] [x])) + +(def:''' (Deg/encode x) + #Nil + (-> Deg Text) + (_lux_proc ["deg" "encode"] [x])) + +(def:''' (Real/encode x) + #Nil + (-> Real Text) + (_lux_proc ["real" "encode"] [x])) + +(def:''' (Char/encode x) + #Nil + (-> Char Text) + (let' [as-text (_lux_case x + #"\t" "\\t" + #"\b" "\\b" + #"\n" "\\n" + #"\r" "\\r" + #"\f" "\\f" + #"\"" "\\\"" + #"\\" "\\\\" + _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + ($_ Text/append "#\"" as-text "\""))) (macro:' #export (do-template tokens) (list [["lux" "doc"] (#TextA "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary. @@ -2105,7 +2123,7 @@ (|> data' (join-map (. apply (make-env bindings'))) return) - (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (->Text num-bindings))))) + (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (Int/encode num-bindings))))) _ (fail "Wrong syntax for do-template")) @@ -2113,47 +2131,47 @@ _ (fail "Wrong syntax for do-template"))) -(do-template [ <=-name> <=> +(do-template [ <=-name> <<-doc> <<=-doc> <>-doc> <>=-doc>] [(def:''' #export (<=-name> test subject) (list [["lux" "doc"] (#TextA )]) (-> Bool) - (_lux_proc [ <=>] [subject test])) + (_lux_proc [ "="] [subject test])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <<-doc>)]) (-> Bool) - (_lux_proc [ ] [subject test])) + (_lux_proc [ "<"] [subject test])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <<=-doc>)]) (-> Bool) - (if (_lux_proc [ ] [subject test]) + (if (_lux_proc [ "<"] [subject test]) true - (_lux_proc [ <=>] [subject test]))) + (_lux_proc [ "="] [subject test]))) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <>-doc>)]) (-> Bool) - (_lux_proc [ ] [test subject])) + (_lux_proc [ "<"] [test subject])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <>=-doc>)]) (-> Bool) - (if (_lux_proc [ ] [test subject]) + (if (_lux_proc [ "<"] [test subject]) true - (_lux_proc [ <=>] [subject test])))] + (_lux_proc [ "="] [subject test])))] - [ Nat "nat" n.= "=" n.< n.<= "<" n.> n.>= + [ Nat "nat" n.= n.< n.<= n.> n.>= "Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."] - [ Int "jvm" i.= "leq" i.< i.<= "llt" i.> i.>= + [ Int "int" i.= i.< i.<= i.> i.>= "Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."] - [Deg "deg" d.= "=" d.< d.<= "<" d.> d.>= + [ Deg "deg" d.= d.< d.<= d.> d.>= "Degree equality." "Degree less-than." "Degree less-than-equal." "Degree greater-than." "Degree greater-than-equal."] - [Real "jvm" r.= "deq" r.< r.<= "dlt" r.> r.>= + [Real "real" r.= r.< r.<= r.> r.>= "Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."] ) @@ -2163,29 +2181,29 @@ (-> ) (_lux_proc [subject param]))] - [ Nat n.+ ["nat" "+"] "Nat(ural) addition."] - [ Nat n.- ["nat" "-"] "Nat(ural) substraction."] - [ Nat n.* ["nat" "*"] "Nat(ural) multiplication."] - [ Nat n./ ["nat" "/"] "Nat(ural) division."] - [ Nat n.% ["nat" "%"] "Nat(ural) remainder."] + [ Nat n.+ [ "nat" "+"] "Nat(ural) addition."] + [ Nat n.- [ "nat" "-"] "Nat(ural) substraction."] + [ Nat n.* [ "nat" "*"] "Nat(ural) multiplication."] + [ Nat n./ [ "nat" "/"] "Nat(ural) division."] + [ Nat n.% [ "nat" "%"] "Nat(ural) remainder."] - [ Int i.+ ["jvm" "ladd"] "Int(eger) addition."] - [ Int i.- ["jvm" "lsub"] "Int(eger) substraction."] - [ Int i.* ["jvm" "lmul"] "Int(eger) multiplication."] - [ Int i./ ["jvm" "ldiv"] "Int(eger) division."] - [ Int i.% ["jvm" "lrem"] "Int(eger) remainder."] - - [Deg d.+ ["deg" "+"] "Deg(ree) addition."] - [Deg d.- ["deg" "-"] "Deg(ree) substraction."] - [Deg d.* ["deg" "*"] "Deg(ree) multiplication."] - [Deg d./ ["deg" "/"] "Deg(ree) division."] - [Deg d.% ["deg" "%"] "Deg(ree) remainder."] + [ Int i.+ [ "int" "+"] "Int(eger) addition."] + [ Int i.- [ "int" "-"] "Int(eger) substraction."] + [ Int i.* [ "int" "*"] "Int(eger) multiplication."] + [ Int i./ [ "int" "/"] "Int(eger) division."] + [ Int i.% [ "int" "%"] "Int(eger) remainder."] + + [ Deg d.+ [ "deg" "+"] "Deg(ree) addition."] + [ Deg d.- [ "deg" "-"] "Deg(ree) substraction."] + [ Deg d.* [ "deg" "*"] "Deg(ree) multiplication."] + [ Deg d./ [ "deg" "/"] "Deg(ree) division."] + [ Deg d.% [ "deg" "%"] "Deg(ree) remainder."] - [Real r.+ ["jvm" "dadd"] "Real addition."] - [Real r.- ["jvm" "dsub"] "Real substraction."] - [Real r.* ["jvm" "dmul"] "Real multiplication."] - [Real r./ ["jvm" "ddiv"] "Real division."] - [Real r.% ["jvm" "drem"] "Real remainder."] + [Real r.+ ["real" "+"] "Real addition."] + [Real r.- ["real" "-"] "Real substraction."] + [Real r.* ["real" "*"] "Real multiplication."] + [Real r./ ["real" "/"] "Real division."] + [Real r.% ["real" "%"] "Real remainder."] ) (do-template [ ] @@ -2196,14 +2214,14 @@ left right))] - [n.min Nat n.< "Nat(ural) minimum."] - [n.max Nat n.> "Nat(ural) maximum."] + [n.min Nat n.< "Nat(ural) minimum."] + [n.max Nat n.> "Nat(ural) maximum."] - [i.min Int i.< "Int(eger) minimum."] - [i.max Int i.> "Int(eger) maximum."] + [i.min Int i.< "Int(eger) minimum."] + [i.max Int i.> "Int(eger) maximum."] - [d.min Deg d.< "Deg(ree) minimum."] - [d.max Deg d.> "Deg(ree) maximum."] + [d.min Deg d.< "Deg(ree) minimum."] + [d.max Deg d.> "Deg(ree) maximum."] [r.min Real r.< "Real minimum."] [r.max Real r.> "Real minimum."] @@ -2530,16 +2548,16 @@ (-> Text ($' Lux AST)) (_lux_case state {#info info #source source #modules modules - #scopes scopes #type-vars types #host host + #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars #catching catching} (#Right {#info info #source source #modules modules - #scopes scopes #type-vars types #host host + #scopes scopes #type-vars types #host host #seed (n.+ +1 seed) #expected expected #cursor cursor #scope-type-vars scope-type-vars #catching catching} - (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))])))) + (symbol$ ["" ($_ Text/append "__gensym__" prefix (Nat/encode seed))])))) (macro:' #export (Rec tokens) (list [["lux" "doc"] (#TextA "## Parameter-less recursive types. @@ -2622,36 +2640,26 @@ (let' [[left right] pair] (list left right))) -(def:''' (Nat->Text x) - #Nil - (-> Nat Text) - (_lux_proc ["nat" "encode"] [x])) - -(def:''' (Deg->Text x) - #Nil - (-> Deg Text) - (_lux_proc ["deg" "encode"] [x])) - (def:' (ast-to-text ast) (-> AST Text) (_lux_case ast [_ (#BoolS value)] - (->Text value) + (Bool/encode value) [_ (#NatS value)] - (Nat->Text value) + (Nat/encode value) [_ (#IntS value)] - (->Text value) + (Int/encode value) [_ (#DegS value)] - (Deg->Text value) + (Deg/encode value) [_ (#RealS value)] - (->Text value) + (Real/encode value) [_ (#CharS value)] - ($_ Text/append "#" "\"" (->Text value) "\"") + ($_ Text/append "#" "\"" (Char/encode value) "\"") [_ (#TextS value)] ($_ Text/append "\"" value "\"") @@ -4158,13 +4166,13 @@ ($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") (#BoundT id) - (Nat->Text id) + (Nat/encode id) (#VarT id) - ($_ Text/append "⌈v:" (->Text id) "⌋") + ($_ Text/append "⌈v:" (Nat/encode id) "⌋") (#ExT id) - ($_ Text/append "⟨e:" (->Text id) "⟩") + ($_ Text/append "⟨e:" (Nat/encode id) "⟩") (#UnivQ env body) ($_ Text/append "(All " (Type/show body) ")") @@ -4354,12 +4362,12 @@ (macro: #export (|>. tokens) {#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. - (|> (map ->Text) (interpose \" \") (fold Text/append \"\")) + (|> (map Int/encode) (interpose \" \") (fold Text/append \"\")) ## => (lambda [] (fold Text/append \"\" (interpose \" \" - (map ->Text ))))"} + (map Int/encode ))))"} (do Monad [g!arg (gensym "arg")] (return (list (` (lambda [(~ g!arg)] (|> (~ g!arg) (~@ tokens)))))))) @@ -4379,7 +4387,7 @@ (default 20 #;None) => 20"} (case tokens (^ (list else maybe)) - (let [g!temp (: AST [["" -1 -1] (#;SymbolS ["" ""])]) + (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])]) code (` (case (~ maybe) (#;Some (~ g!temp)) (~ g!temp) @@ -4793,7 +4801,7 @@ ) (def: (find-baseline-column ast) - (-> AST Int) + (-> AST Nat) (case ast (^template [] [[_ _ column] ( _)] @@ -4810,12 +4818,12 @@ (^template [] [[_ _ column] ( parts)] - (fold i.min column (map find-baseline-column parts))) + (fold n.min column (map find-baseline-column parts))) ([#FormS] [#TupleS]) [[_ _ column] (#RecordS pairs)] - (fold i.min column + (fold n.min column (List/append (map (. find-baseline-column first) pairs) (map (. find-baseline-column second) pairs))) )) @@ -4833,19 +4841,6 @@ _ (#Doc-Example ast))) -(def: (Char/encode x) - (-> Char Text) - (let [as-text (case x - #"\t" "\\t" - #"\b" "\\b" - #"\n" "\\n" - #"\r" "\\r" - #"\f" "\\f" - #"\"" "\\\"" - #"\\" "\\\\" - _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] - ($_ Text/append "#\"" as-text "\""))) - (def: (Text/encode original) (-> Text Text) (let [escaped (|> original @@ -4865,16 +4860,28 @@ (-> ) ( value))] - [i.inc i.+ 1 Int "Increment function."] - [i.dec i.- 1 Int "Decrement function."] - [n.inc n.+ +1 Nat "Increment function."] - [n.dec n.- +1 Nat "Decrement function."] + [i.inc i.+ 1 Int "[Int] Increment function."] + [i.dec i.- 1 Int "[Int] Decrement function."] + [n.inc n.+ +1 Nat "[Nat] Increment function."] + [n.dec n.- +1 Nat "[Nat] Decrement function."] ) -(def: tag->Text +(def: Tag/encode (-> Ident Text) (. (Text/append "#") Ident/encode)) +(do-template [ ] + [(def: #export ( input) + (-> ) + (_lux_proc [input]))] + + [int-to-nat ["int" "to-nat"] Int Nat] + [nat-to-int ["nat" "to-int"] Nat Int] + + [real-to-deg ["real" "to-deg"] Real Deg] + [deg-to-real ["deg" "to-real"] Deg Real] + ) + (def: (repeat n x) (All [a] (-> Int a (List a))) (if (i.> 0 n) @@ -4882,17 +4889,18 @@ #;Nil)) (def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column]) - (-> Int Cursor Cursor Text) - (if (i.= old-line new-line) - (Text/join (repeat (i.- old-column new-column) " ")) - (let [extra-lines (Text/join (repeat (i.- old-line new-line) "\n")) - space-padding (Text/join (repeat (i.- baseline new-column) " "))] + (-> Nat Cursor Cursor Text) + (if (n.= old-line new-line) + (Text/join (repeat (nat-to-int (n.- old-column new-column)) " ")) + (let [extra-lines (Text/join (repeat (nat-to-int (n.- old-line new-line)) "\n")) + space-padding (Text/join (repeat (nat-to-int (n.- baseline new-column)) " "))] (Text/append extra-lines space-padding)))) (def: (Text/size x) - (-> Text Int) - (_lux_proc ["jvm" "i2l"] - [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])) + (-> Text Nat) + (:! Nat + (_lux_proc ["jvm" "i2l"] + [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))) (def: (Text/trim x) (-> Text Text) @@ -4900,18 +4908,18 @@ (def: (update-cursor [file line column] ast-text) (-> Cursor Text Cursor) - [file line (i.+ column (Text/size ast-text))]) + [file line (n.+ column (Text/size ast-text))]) (def: (delim-update-cursor [file line column]) (-> Cursor Cursor) - [file line (i.inc column)]) + [file line (n.inc column)]) (def: rejoin-all-pairs (-> (List [AST AST]) (List AST)) (. List/join (map rejoin-pair))) (def: (doc-example->Text prev-cursor baseline example) - (-> Cursor Int AST [Cursor Text]) + (-> Cursor Nat AST [Cursor Text]) (case example (^template [ ] [new-cursor ( value)] @@ -4919,15 +4927,15 @@ [(update-cursor new-cursor as-text) (Text/append (cursor-padding baseline prev-cursor new-cursor) as-text)])) - ([#BoolS ->Text] - [#NatS Nat->Text] - [#IntS ->Text] - [#DegS Deg->Text] - [#RealS ->Text] + ([#BoolS Bool/encode] + [#NatS Nat/encode] + [#IntS Int/encode] + [#DegS Deg/encode] + [#RealS Real/encode] [#CharS Char/encode] [#TextS Text/encode] [#SymbolS Ident/encode] - [#TagS tag->Text]) + [#TagS Tag/encode]) (^template [ ] [group-cursor ( parts)] @@ -4947,7 +4955,7 @@ )) (def: (with-baseline baseline [file line column]) - (-> Int Cursor Cursor) + (-> Nat Cursor Cursor) [file line baseline]) (def: (doc-fragment->Text fragment) @@ -5166,7 +5174,7 @@ (compare (:: AST/encode show )) (compare true (:: Eq = ))] - [(bool true) "true" [["" -1 -1] (#;BoolS true)]] + [(bool true) "true" [_ (#;BoolS true)]] [(bool false) "false" [_ (#;BoolS false)]] [(int 123) "123" [_ (#;IntS 123)]] [(real 123.0) "123.0" [_ (#;RealS 123.0)]] @@ -5447,7 +5455,7 @@ (wrap (list (` (#ExT (~ (nat$ var-id)))))) #;None - (fail (Text/append "Indexed-type doesn't exist: " (->Text idx))))) + (fail (Text/append "Indexed-type doesn't exist: " (Nat/encode idx))))) _ (fail "Wrong syntax for $"))) @@ -5537,7 +5545,7 @@ (do Monad [cursor get-cursor] (let [[module line column] cursor - cursor-prefix ($_ hack_Text/append "[" module "," (->Text line) "," (->Text column) "] ")] + cursor-prefix ($_ hack_Text/append "[" module "," (Nat/encode line) "," (Nat/encode column) "] ")] (wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message))))))) _ @@ -5591,18 +5599,6 @@ _ (fail "Wrong syntax for @post"))) -(do-template [ ] - [(def: #export ( input) - (-> ) - (_lux_proc [input]))] - - [int-to-nat ["int" "to-nat"] Int Nat] - [nat-to-int ["nat" "to-int"] Nat Int] - - [real-to-deg ["real" "to-deg"] Real Deg] - [deg-to-real ["deg" "to-real"] Deg Real] - ) - (macro: #export (type-of tokens) {#;doc (doc "Generates the type corresponding to a given definition or variable." (let [my-num (: Int 123)] diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux index f78ffea17..5ed443040 100644 --- a/stdlib/source/lux/control/comonad.lux +++ b/stdlib/source/lux/control/comonad.lux @@ -18,6 +18,8 @@ split)) ## [Syntax] +(def: _cursor Cursor ["" +0 +0]) + (macro: #export (be tokens state) {#;doc (doc "A co-monadic parallel to the \"do\" macro." (let [square (lambda [n] (i.* n n))] @@ -26,9 +28,8 @@ (square (head inputs)))))} (case tokens (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) - (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])]) - g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) - g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])]) + (let [g!map (: AST [_cursor (#;SymbolS ["" " map "])]) + g!split (: AST [_cursor (#;SymbolS ["" " split "])]) body' (fold (: (-> [AST AST] AST AST) (lambda [binding body'] (let [[var value] binding] @@ -42,8 +43,8 @@ body (reverse (as-pairs bindings)))] (#;Right [state (#;Cons (` (;_lux_case (~ comonad) - (~ g!@) - (;_lux_case (~ g!@) + (~' @) + (;_lux_case (~' @) {#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)} (~ body')))) #;Nil)])) diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux index 5c540791a..a6d0d5988 100644 --- a/stdlib/source/lux/control/monad.lux +++ b/stdlib/source/lux/control/monad.lux @@ -49,6 +49,8 @@ join)) ## [Syntax] +(def: _cursor Cursor ["" +0 +0]) + (macro: #export (do tokens state) {#;doc (doc "Macro for easy concatenation of monadic operations." (do Monad @@ -57,10 +59,9 @@ (wrap (f3 z))))} (case tokens (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) - (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])]) - g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) - g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) - g!apply (: AST [["" -1 -1] (#;SymbolS ["" " apply "])]) + (let [g!map (: AST [_cursor (#;SymbolS ["" " map "])]) + g!join (: AST [_cursor (#;SymbolS ["" " join "])]) + g!apply (: AST [_cursor (#;SymbolS ["" " apply "])]) body' (fold (: (-> [AST AST] AST AST) (lambda [binding body'] (let [[var value] binding] @@ -74,8 +75,8 @@ body (reverse (as-pairs bindings)))] (#;Right [state (#;Cons (` (;_lux_case (~ monad) - (~ g!@) - (;_lux_case (~ g!@) + (~' @) + (;_lux_case (~' @) {#applicative {#A;functor {#F;map (~ g!map)} #A;wrap (~' wrap) #A;apply (~ g!apply)} diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux index 4d9d9c270..5f2ef3984 100644 --- a/stdlib/source/lux/data/coll/list.lux +++ b/stdlib/source/lux/data/coll/list.lux @@ -335,7 +335,7 @@ ## [Syntax] (def: (symbol$ name) (-> Text AST) - [["" -1 -1] (#;SymbolS "" name)]) + [["" +0 +0] (#;SymbolS "" name)]) (macro: #export (zip tokens state) {#;doc (doc "Create list zippers with the specified number of input lists." diff --git a/stdlib/source/lux/io.lux b/stdlib/source/lux/io.lux index 93c01ee85..8a9e6bb9e 100644 --- a/stdlib/source/lux/io.lux +++ b/stdlib/source/lux/io.lux @@ -19,7 +19,7 @@ "Some value...")))} (case tokens (^ (list value)) - (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] + (let [blank (: AST [["" +0 +0] (#;SymbolS ["" ""])])] (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) _ diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux index 49d68b5c3..6647307dd 100644 --- a/stdlib/source/lux/macro/ast.lux +++ b/stdlib/source/lux/macro/ast.lux @@ -27,7 +27,7 @@ ## (Meta Cursor (AST' (Meta Cursor)))) ## [Utils] -(def: _cursor Cursor ["" -1 -1]) +(def: _cursor Cursor ["" +0 +0]) ## [Functions] (do-template [ ] -- cgit v1.3.1 From 12dcb6e964e0c54f4001413bc62b8bcb526fa9c4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Feb 2017 19:58:26 -0400 Subject: - Now doing common array analysis/compilation. - Now doing common io/log! analysis/compilation. - Now doing common char/to-text analysis/compilation. - Expanded compilation of procedures in JS. - Expanded LuxRT in JS. - Fixed some bugs. --- luxc/src/lux/analyser.clj | 2 +- luxc/src/lux/analyser/proc/common.clj | 80 ++++++++- luxc/src/lux/analyser/proc/jvm.clj | 40 ----- luxc/src/lux/compiler/js/lux.clj | 24 +-- luxc/src/lux/compiler/js/proc/common.clj | 115 ++++++------- luxc/src/lux/compiler/js/rt.clj | 278 +++++++++++++++++++++---------- luxc/src/lux/compiler/jvm/host.clj | 89 +++++++++- luxc/src/lux/type.clj | 3 + stdlib/source/lux.lux | 17 +- 9 files changed, 436 insertions(+), 212 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index f5a200cad..e2aa64590 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -134,7 +134,7 @@ (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type (case ?category - "jvm" (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) + "jvm" (&&jvm/analyse-host analyse exo-type compilers ?proc ?args) ;; "js" ;; common (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index f6d1eef8e..3bbc47e88 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -179,17 +179,78 @@ ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + ^:private analyse-char-to-text &type/Char &type/Text ["char" "to-text"] - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + + ^:private analyse-lux-log! &type/Text &/$UnitT ["io" "log!"] ) +(defn ^:private analyse-array-new [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + =length (&&/analyse-1 analyse &type/Nat length) + _ (&type/check exo-type (&/$UnivQ (&/|list) (&type/Array (&/$BoundT 1)))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "new"]) (&/|list =length) (&/|list))))))) + +(defn ^:private analyse-array-get [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1 analyse (&type/Array $var) array) + =idx (&&/analyse-1 analyse &type/Nat idx) + _ (&type/check exo-type (&/$AppT &type/Maybe $var)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))))) + +(defn ^:private analyse-array-put [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + :let [array-type (&type/Array $var)] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse &type/Nat idx) + =elem (&&/analyse-1 analyse $var elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "put"]) (&/|list =array =idx =elem) (&/|list))))))))) + +(defn ^:private analyse-array-remove [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + :let [array-type (&type/Array $var)] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse &type/Nat idx) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "remove"]) (&/|list =array =idx) (&/|list))))))))) + +(defn ^:private analyse-array-size [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons array (&/$Nil)) ?values] + =array (&&/analyse-1 analyse (&type/Array $var) array) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "size"]) (&/|list =array) (&/|list))))))))) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" (case proc "==" (analyse-lux-== analyse exo-type ?values)) + "io" + (case proc + "log!" (analyse-lux-log! analyse exo-type ?values)) + "text" (case proc "=" (analyse-text-eq analyse exo-type ?values) @@ -205,13 +266,13 @@ "shift-right" (analyse-bit-shift-right analyse exo-type ?values) "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) - ;; "array" - ;; (case proc - ;; "new" (analyse-array-new analyse exo-type ?values) - ;; "get" (analyse-array-get analyse exo-type ?values) - ;; "put" (analyse-jvm-aastore analyse exo-type ?values) - ;; "remove" (analyse-array-remove analyse exo-type ?values) - ;; "size" (analyse-array-size analyse exo-type ?values)) + "array" + (case proc + "new" (analyse-array-new analyse exo-type ?values) + "get" (analyse-array-get analyse exo-type ?values) + "put" (analyse-array-put analyse exo-type ?values) + "remove" (analyse-array-remove analyse exo-type ?values) + "size" (analyse-array-size analyse exo-type ?values)) "nat" (case proc @@ -281,6 +342,7 @@ "char" (case proc + "to-text" (analyse-char-to-text analyse exo-type ?values) "to-nat" (analyse-char-to-nat analyse exo-type ?values) ) diff --git a/luxc/src/lux/analyser/proc/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj index 480cb341a..72b871686 100644 --- a/luxc/src/lux/analyser/proc/jvm.clj +++ b/luxc/src/lux/analyser/proc/jvm.clj @@ -881,46 +881,6 @@ (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-array-new [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) - array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] - gtype-env &/get-type-env - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-array-get [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-array-remove [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _cursor &/cursor - :let [=elem (&&/|meta inner-arr-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] - _ (&type/check exo-type array-type)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - (defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] (|do [module &/get-module-name _ (compile-interface interface-decl supers =anns =methods) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index a7b1217f0..61f21bf55 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -284,15 +284,18 @@ func-args (->> (&/|range* 0 (dec arity)) (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) (&/fold str ""))] - =env (&/map% (fn [=captured] - (|case =captured - [_ (&o/$captured ?scope ?captured-id ?source)] - (|do [=source (compile ?source)] - (return (str "var " (captured-name ?captured-id) " = " =source ";"))))) - (&/|vals ?env)) + =env-vars (&/map% (fn [=captured] + (|case =captured + [_ (&o/$captured ?scope ?captured-id ?source)] + (return (captured-name ?captured-id)))) + (&/|vals ?env)) + =env-values (&/map% (fn [=captured] + (|case =captured + [_ (&o/$captured ?scope ?captured-id ?source)] + (compile ?source))) + (&/|vals ?env)) =body (compile ?body)] - (return (str "(function() {" - (->> =env (&/fold str "")) + (return (str "(function(" (->> =env-vars (&/|interpose ",") (&/fold str "")) ") {" "return " (str "(function " function-name "() {" "\"use strict\";" @@ -316,7 +319,7 @@ " };" "}" "})") - ";})()")))) + ";})(" (->> =env-values (&/|interpose ",") (&/fold str "")) ")")))) (defn compile-def [compile ?name ?body def-meta] (|do [module-name &/get-module-name @@ -345,8 +348,7 @@ _ false) def-type (&a/expr-type* ?body) - _ (&/|log! (str "def-js >>\n" - (string/replace def-js "" "^@")))] + _ (&/|log! (string/replace def-js "" "^@"))] _ (&&/run-js! def-js) def-value (&&/run-js!+ var-name) _ (&/without-repl-closure diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 7e052892b..385761dbe 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -89,26 +89,26 @@ ^:private compile-nat-add "addI64" ^:private compile-nat-sub "subI64" ^:private compile-nat-mul "mulI64" - ;; ^:private compile-nat-div "/" - ;; ^:private compile-nat-rem "%" + ^:private compile-nat-div "divN64" + ^:private compile-nat-rem "remN64" ^:private compile-nat-eq "eqI64" - ;; ^:private compile-nat-lt "<" + ^:private compile-nat-lt "ltN64" ^:private compile-int-add "addI64" ^:private compile-int-sub "subI64" ^:private compile-int-mul "mulI64" - ;; ^:private compile-int-div "/" - ;; ^:private compile-int-rem "%" + ^:private compile-int-div "divI64" + ^:private compile-int-rem "remI64" ^:private compile-int-eq "eqI64" - ;; ^:private compile-int-lt "<" + ^:private compile-int-lt "ltI64" ^:private compile-deg-add "addI64" ^:private compile-deg-sub "subI64" - ;; ^:private compile-deg-mul "*" - ;; ^:private compile-deg-div "/" + ^:private compile-deg-mul "mulD64" + ^:private compile-deg-div "divD64" ^:private compile-deg-rem "subI64" ^:private compile-deg-eq "eqI64" - ;; ^:private compile-deg-lt "<" + ^:private compile-deg-lt "ltD64" ^:private compile-deg-scale "mulI64" ) @@ -128,6 +128,22 @@ ^:private compile-real-lt "<" ) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str &&rt/LuxRT "." "(" =x ")")))) + + ^:private compile-int-encode "encodeI64" + ^:private compile-nat-encode "encodeN64" + ^:private compile-deg-encode "encodeD64" + ) + +(defn ^:private compile-real-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "(" =x ")" ".toString()")))) + ;; (defn ^:private compile-nat-lt [compile ?values special-args] ;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ;; ^MethodVisitor *writer* &/get-writer @@ -166,35 +182,6 @@ ;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long ;; ) -;; (do-template [ ] -;; (do (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] -;; (return nil))) - -;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] -;; (return nil))))) - -;; ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" -;; ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" -;; ) - -(defn compile-int-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "(" =x ").toString()")))) - ;; (do-template [ ] ;; (defn [compile ?values special-args] ;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -261,24 +248,37 @@ ^:private compile-int-to-nat ) -(defn compile-text-eq [compile ?values special-args] +(defn ^:private compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] =x (compile ?x) =y (compile ?y)] (return (str "(" =x "===" =y ")")))) -(defn compile-text-append [compile ?values special-args] +(defn ^:private compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] =x (compile ?x) =y (compile ?y)] (return (str =x ".concat(" =y ")")))) +(defn ^:private compile-char-to-text [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] + (compile ?x))) + +(defn ^:private compile-lux-log! [compile ?values special-args] + (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] + =message (compile ?message)] + (return (str "LuxRT.log(" =message ")")))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category ;; "lux" ;; (case proc-name ;; "==" (compile-lux-== compile ?values special-args)) + "io" + (case proc-name + "log!" (compile-lux-log! compile ?values special-args)) + "text" (case proc-name "=" (compile-text-eq compile ?values special-args) @@ -303,11 +303,11 @@ "+" (compile-nat-add compile ?values special-args) "-" (compile-nat-sub compile ?values special-args) "*" (compile-nat-mul compile ?values special-args) - ;; "/" (compile-nat-div compile ?values special-args) - ;; "%" (compile-nat-rem compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) "=" (compile-nat-eq compile ?values special-args) - ;; "<" (compile-nat-lt compile ?values special-args) - ;; "encode" (compile-nat-encode compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) + "encode" (compile-nat-encode compile ?values special-args) ;; "decode" (compile-nat-decode compile ?values special-args) ;; "max-value" (compile-nat-max-value compile ?values special-args) ;; "min-value" (compile-nat-min-value compile ?values special-args) @@ -320,11 +320,11 @@ "+" (compile-int-add compile ?values special-args) "-" (compile-int-sub compile ?values special-args) "*" (compile-int-mul compile ?values special-args) - ;; "/" (compile-int-div compile ?values special-args) - ;; "%" (compile-int-rem compile ?values special-args) + "/" (compile-int-div compile ?values special-args) + "%" (compile-int-rem compile ?values special-args) "=" (compile-int-eq compile ?values special-args) - ;; "<" (compile-int-lt compile ?values special-args) - ;; "encode" (compile-int-encode compile ?values special-args) + "<" (compile-int-lt compile ?values special-args) + "encode" (compile-int-encode compile ?values special-args) ;; "decode" (compile-int-decode compile ?values special-args) ;; "max-value" (compile-int-max-value compile ?values special-args) ;; "min-value" (compile-int-min-value compile ?values special-args) @@ -335,12 +335,12 @@ (case proc-name "+" (compile-deg-add compile ?values special-args) "-" (compile-deg-sub compile ?values special-args) - ;; "*" (compile-deg-mul compile ?values special-args) - ;; "/" (compile-deg-div compile ?values special-args) + "*" (compile-deg-mul compile ?values special-args) + "/" (compile-deg-div compile ?values special-args) "%" (compile-deg-rem compile ?values special-args) "=" (compile-deg-eq compile ?values special-args) - ;; "<" (compile-deg-lt compile ?values special-args) - ;; "encode" (compile-deg-encode compile ?values special-args) + "<" (compile-deg-lt compile ?values special-args) + "encode" (compile-deg-encode compile ?values special-args) ;; "decode" (compile-deg-decode compile ?values special-args) ;; "max-value" (compile-deg-max-value compile ?values special-args) ;; "min-value" (compile-deg-min-value compile ?values special-args) @@ -357,17 +357,18 @@ "%" (compile-real-rem compile ?values special-args) "=" (compile-real-eq compile ?values special-args) "<" (compile-real-lt compile ?values special-args) - ;; "encode" (compile-real-encode compile ?values special-args) + "encode" (compile-real-encode compile ?values special-args) ;; "decode" (compile-real-decode compile ?values special-args) ;; "max-value" (compile-real-max-value compile ?values special-args) ;; "min-value" (compile-real-min-value compile ?values special-args) ;; "to-deg" (compile-real-to-deg compile ?values special-args) ) - ;; "char" - ;; (case proc-name - ;; "to-nat" (compile-char-to-nat compile ?values special-args) - ;; ) + "char" + (case proc-name + "to-text" (compile-char-to-text compile ?values special-args) + ;; "to-nat" (compile-char-to-nat compile ?values special-args) + ) ;; else (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 194248f10..ce5bf5d16 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -765,47 +765,6 @@ ;; (.visitInsn Opcodes/ARETURN) ;; (.visitMaxs 0 0) ;; (.visitEnd))) -;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 -;; _ (let [$too-big (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) -;; (.visitCode) -;; (.visitLdcInsn "+") -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LCMP) -;; (.visitJumpInsn Opcodes/IFLT $too-big) -;; ;; then -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") -;; (.visitInsn Opcodes/ARETURN) -;; ;; else -;; (.visitLabel $too-big) -;; ;; Set up parts of the number string... -;; ;; First digits -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/LUSHR) -;; (.visitLdcInsn (long 5)) -;; (.visitInsn Opcodes/LDIV) ;; quot -;; ;; Last digit -;; (.visitInsn Opcodes/DUP2) -;; (.visitLdcInsn (long 10)) -;; (.visitInsn Opcodes/LMUL) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; swap2 -;; (.visitInsn Opcodes/LSUB) ;; quot, rem -;; ;; Conversion to string... -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* -;; (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* -;; (.visitInsn Opcodes/POP) ;; rem*, quot -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* -;; (.visitInsn Opcodes/SWAP) ;; quot*, rem* -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") -;; (.visitInsn Opcodes/ARETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd))) ;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 ;; _ (let [$simple-case (new Label)] ;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) @@ -936,10 +895,57 @@ ;; (.visitEnd)))] ;; nil))) +(def ^:private adt-methods + {"product_getLeft" (str "(function product_getLeft(product,index) {" + "var index_min_length = (index+1);" + "if(product.length > index_min_length) {" + ;; No need for recursion + "return product[index];" + "}" + "else {" + ;; Needs recursion + "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" + "}" + "})") + "product_getRight" (str "(function product_getRight(product,index) {" + "var index_min_length = (index+1);" + "if(product.length === index_min_length) {" + ;; Last element. + "return product[index];" + "}" + "else if(product.length < index_min_length) {" + ;; Needs recursion + "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + "}" + "else {" + ;; Must slice + "return product.slice(index);" + "}" + "})") + "sum_get" (str "(function sum_get(sum,wantedTag,wantsLast) {" + "if(sum[0] === wantedTag && sum[1] === wantsLast) {" + ;; Exact match. + "return sum[2];" + "}" + "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" + "if(sum[1]) {" + ;; Must recurse. + "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" + "}" + ;; No match. + "else { return null; }" + "}" + ;; No match. + "else { return null; }" + "})") + }) + (def ^:private i64-methods {"makeI64" (str "(function makeI64(high,low) {" "return { H: (high|0), L: (low|0)};" "})") + "MIN_VALUE" "{ H: 0x80000000, L: 0}" + "ONE" "{ H: 0, L: 1}" "notI64" (str "(function notI64(i64) {" "return LuxRT.makeI64(~i64.H,~i64.L);" "})") @@ -1030,59 +1036,163 @@ "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" "}" "})") - }) - -(def ^:private adt-methods - {"product_getLeft" (str "(function product_getLeft(product,index) {" - "var index_min_length = (index+1);" - "if(product.length > index_min_length) {" - ;; No need for recursion - "return product[index];" - "}" - "else {" - ;; Needs recursion - "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" - "}" - "})") - "product_getRight" (str "(function product_getRight(product,index) {" - "var index_min_length = (index+1);" - "if(product.length === index_min_length) {" - ;; Last element. - "return product[index];" + "divI64" (str "(function divI64(l,r) {" + (str "if((r.H === 0) && (r.L === 0)) {" + ;; Special case: R = 0 + "throw Error('division by zero');" + "}" + "else if((l.H === 0) && (l.L === 0)) {" + ;; Special case: L = 0 + "return l;" + "}") + (str "if(LuxRT.eqI64(l,LuxRT.MIN_VALUE)) {" + ;; Special case: L = MIN + (str "if(LuxRT.eqI64(r,LuxRT.ONE) || LuxRT.eqI64(r,LuxRT.negateI64(LuxRT.ONE))) {" + ;; Special case: L = MIN, R = 1|-1 + "return LuxRT.MIN_VALUE;" "}" - "else if(product.length < index_min_length) {" - ;; Needs recursion - "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + ;; Special case: L = R = MIN + "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {" + "return LuxRT.ONE;" "}" + ;; Special case: L = MIN "else {" - ;; Must slice - "return product.slice(index);" + "var halfL = LuxRT.shrI64(l,LuxRT.ONE);" + "var approx = LuxRT.shlI64(LuxRT.divI64(halfL,r),LuxRT.ONE);" + (str "if((approx.H === 0) && (approx.L === 0)) {" + (str "if(r.H < 0) {" + "return LuxRT.ONE;" + "}" + "else {" + "return LuxRT.negateI64(LuxRT.ONE);" + "}") + "}" + "else {" + "var rem = LuxRT.subI64(l,LuxRT.mulI64(r,approx));" + "return LuxRT.addI64(approx,LuxRT.divI64(rem,r));" + "}") + "}") + "}" + "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {" + ;; Special case: R = MIN + "return LuxRT.makeI64(0,0);" + "}") + ;; Special case: negatives + (str "if(l.H < 0) {" + (str "if(r.H < 0) {" + ;; Both are negative + "return LuxRT.divI64(LuxRT.negateI64(l),LuxRT.negateI64(r));" "}" - "})") - "sum_get" (str "(function sum_get(sum,wantedTag,wantsLast) {" - "if(sum[0] === wantedTag && sum[1] === wantsLast) {" - ;; Exact match. - "return sum[2];" - "}" - "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" - "if(sum[1]) {" - ;; Must recurse. - "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" - "}" - ;; No match. - "else { return null; }" - "}" - ;; No match. - "else { return null; }" - "})") + "else {" + ;; Only L is negative + "return LuxRT.negateI64(LuxRT.divI64(LuxRT.negateI64(l),r));" + "}") + "}" + "else if(r.H < 0) {" + ;; R is negative + "return LuxRT.negateI64(LuxRT.divI64(l,LuxRT.negateI64(r)));" + "}") + ;; Common case + (str "var res = { H: 0, L: 0};" + "var rem = l;" + (str "while(LuxRT.ltI64(r,rem) || LuxRT.eqI64(r,rem)) {" + "var approx = Math.max(1, Math.floor(LuxRT.toNumberI64(rem) / LuxRT.toNumberI64(r)));" + "var log2 = Math.ceil(Math.log(approx) / Math.LN2);" + "var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48);" + "var approxRes = LuxRT.fromNumberI64(approx);" + "var approxRem = LuxRT.mulI64(approxRes,r);" + (str "while((approxRem.H < 0) || LuxRT.ltI64(rem,approxRem)) {" + "approx -= delta;" + "approxRes = LuxRT.fromNumberI64(approx);" + "approxRem = LuxRT.mulI64(approxRes,r);" + "}") + (str "if((approxRes.H === 0) && (approxRes.L === 0)) {" + "approxRes = LuxRT.ONE;" + "}") + "res = LuxRT.addI64(res,approxRes);" + "rem = LuxRT.subI64(rem,approxRem);" + "}") + "return res;") + "})") + "remI64" (str "(function remI64(l,r) {" + "return LuxRT.subI64(l,LuxRT.mulI64(LuxRT.divI64(l,r),r));" + "})") + "encodeI64" (str "(function encodeI64(input) {" + ;; If input = 0 + (str "if((input.H === 0) && (input.L === 0)) {" + "return '0';" + "}") + ;; If input < 0 + (str "if(input.H < 0) {" + (str "if(LuxRT.eqI64(input,LuxRT.MIN_VALUE)) {" + "var radix = LuxRT.makeI64(0,10);" + "var div = LuxRT.divI64(input,radix);" + "var rem = LuxRT.subI64(LuxRT.mulI64(div,radix),input);" + "return LuxRT.encodeI64(div).concat(rem.L+'');" + "}") + "}" + "else {" + "return '-'.concat(LuxRT.encodeI64(LuxRT.negateI64(input)));" + "}") + ;; If input > 0 + (str "var chunker = LuxRT.makeI64(0,1000000);" + "var rem = input;" + "var result = '';" + "while (true) {" + (str "var remDiv = LuxRT.divI64(rem,chunker);" + "var chunk = LuxRT.subI64(rem,LuxRT.mulI64(remDiv,chunker));" + "var digits = (chunk.L >>> 0)+'';" + "rem = remDiv;" + (str "if((rem.H === 0) && (rem.L === 0)) {" + "return digits.concat(result);" + "}" + "else {" + (str "while (digits.length < 6) {" + "digits = '0' + digits;" + "}") + "result = '' + digits + result;" + "}")) + "}") + "})") + "ltI64" (str "(function ltI64(l,r) {" + "var ln = l.H < 0;" + "var rn = r.H < 0;" + "if(ln && !rn) { return true; }" + "if(!ln && rn) { return false; }" + "return (LuxRT.subI64(l,r).H < 0);" + "})") + }) + +(def ^:private n64-methods + {"encodeN64" (str "(function encodeN64(input) {" + (str "if(input.H < 0) {" + ;; Too big + "var lastDigit = LuxRT.remI64(input, LuxRT.makeI64(0,10));" + "var minusLastDigit = LuxRT.divI64(input, LuxRT.makeI64(0,10));" + "return '+'.concat(LuxRT.encodeI64(minusLastDigit)).concat(LuxRT.encodeI64(lastDigit));" + "}" + "else {" + ;; Small enough + "return '+'.concat(LuxRT.encodeI64(input));" + "}") + "})") + }) + +(def ^:private io-methods + {"log" (str "(function log(message) {" + "console.log(message);" + (str "return " &&/unit ";") + "})") }) (def LuxRT "LuxRT") (def compile-LuxRT - (|do [_ (return nil) + (|do [_ (&&/run-js! "var console = { log: print };") :let [rt-object (str "{" (->> (merge adt-methods - i64-methods) + i64-methods + n64-methods + io-methods) (map (fn [[key val]] (str key ":" val))) (interpose ",") diff --git a/luxc/src/lux/compiler/jvm/host.clj b/luxc/src/lux/compiler/jvm/host.clj index 9583c3106..867dd1ff0 100644 --- a/luxc/src/lux/compiler/jvm/host.clj +++ b/luxc/src/lux/compiler/jvm/host.clj @@ -2290,6 +2290,16 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-array-new [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY "java/lang/Object")]] + (return nil))) + (defn ^:private compile-array-get [compile ?values special-args] (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values ;; (&/$Nil) special-args @@ -2323,6 +2333,54 @@ (.visitLabel $end))]] (return nil))) +(defn ^:private compile-array-put [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(defn ^:private compile-array-remove [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/AASTORE))]] + (return nil))) + +(defn ^:private compile-array-size [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] @@ -2611,6 +2669,14 @@ ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen )) +(defn ^:private compile-char-to-text [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;"))]] + (return nil))) + (do-template [] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] @@ -2645,12 +2711,28 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] (return nil))) +(defn compile-io-log! [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))] + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/String;)V") + (.visitLdcInsn &/unit-tag))]] + (return nil))) + (defn compile-host [compile proc-category proc-name ?values special-args] (case proc-category "lux" (case proc-name "==" (compile-lux-== compile ?values special-args)) + "io" + (case proc-name + "log!" (compile-io-log! compile ?values special-args)) + "text" (case proc-name "=" (compile-text-eq compile ?values special-args) @@ -2668,7 +2750,11 @@ "array" (case proc-name - "get" (compile-array-get compile ?values special-args)) + "new" (compile-array-new compile ?values special-args) + "get" (compile-array-get compile ?values special-args) + "put" (compile-array-put compile ?values special-args) + "remove" (compile-array-remove compile ?values special-args) + "size" (compile-array-size compile ?values special-args)) "nat" (case proc-name @@ -2733,6 +2819,7 @@ "char" (case proc-name "to-nat" (compile-char-to-nat compile ?values special-args) + "to-text" (compile-char-to-text compile ?values special-args) ) "jvm" diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index d37a061f8..d3805cabc 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -32,6 +32,9 @@ (def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil))) (def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text))) +(defn Array [elem-type] + (&/$HostT "#Array" (&/|list elem-type))) + (def Bottom (&/$NamedT (&/T ["lux" "Bottom"]) (&/$UnivQ empty-env diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 1c74cac80..06c0fd2fd 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2099,7 +2099,7 @@ #"\f" "\\f" #"\"" "\\\"" #"\\" "\\\\" - _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + _ (_lux_proc ["char" "to-text"] [x]))] ($_ Text/append "#\"" as-text "\""))) (macro:' #export (do-template tokens) @@ -2241,6 +2241,13 @@ (-> Bool Bool) (if x false true)) +(def:''' #export (log! message) + (list [["lux" "doc"] (#TextA "Logs message to standard output. + + Useful for debugging.")]) + (-> Text Unit) + (_lux_proc ["io" "log!"] [message])) + (def:''' (find-macro' modules current-module module name) #Nil (-> ($' List (& Text Module)) @@ -2998,14 +3005,6 @@ (#;Some (#;Right [])) (list (' #hidden)))) -(def:''' #export (log! message) - (list [["lux" "doc"] (#TextA "Logs message to standard output. - - Useful for debugging.")]) - (-> Text Unit) - (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"] - [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message])) - (macro:' #export (def: tokens) (list [["lux" "doc"] (#TextA "## Defines global constants/functions. (def: (rejoin-pair pair) -- cgit v1.3.1 From b0114f4871a6a2654fa2edc667a635a97ae76b19 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 16 Feb 2017 20:09:52 -0400 Subject: - Implemented several new procedures. - Improved Lux-to-JS interactions. - Parallel compilation works for the JS backend. - Added more primitive functionality to the JS runtime. - More common procedures. --- luxc/src/lux/analyser/proc/common.clj | 125 +++++++++++++++---- luxc/src/lux/compiler/js.clj | 3 +- luxc/src/lux/compiler/js/base.clj | 54 ++++++--- luxc/src/lux/compiler/js/lux.clj | 22 ++-- luxc/src/lux/compiler/js/proc/common.clj | 192 +++++++++++++++++++++--------- luxc/src/lux/compiler/js/rt.clj | 108 +++++++++++++++-- luxc/src/lux/compiler/jvm/proc/common.clj | 144 ++++++++++++++++++++-- luxc/src/lux/compiler/jvm/rt.clj | 30 ++++- stdlib/source/lux.lux | 162 +++++++++++++------------ stdlib/source/lux/data/number.lux | 105 +++++++--------- stdlib/source/lux/data/text.lux | 8 +- stdlib/source/lux/math/complex.lux | 8 +- stdlib/test/test/lux.lux | 16 +-- stdlib/test/test/lux/data/text.lux | 8 +- stdlib/test/test/lux/math/complex.lux | 16 +-- 15 files changed, 707 insertions(+), 294 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 3bbc47e88..4a4048c1c 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -6,7 +6,7 @@ [type :as &type]) (lux.analyser [base :as &&]))) -(defn ^:private analyse-lux-== [analyse exo-type ?values] +(defn ^:private analyse-lux-is [analyse exo-type ?values] (&type/with-var (fn [$var] (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] @@ -15,7 +15,7 @@ _ (&type/check exo-type &type/Bool) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + (&&/$proc (&/T ["lux" "is"]) (&/|list =left =right) (&/|list))))))))) (do-template [ ] (defn [analyse exo-type ?values] @@ -31,6 +31,66 @@ ^:private analyse-text-append ["text" "append"] &type/Text &type/Text ) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =part (&&/analyse-1 analyse &type/Text part) + _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ["text" ]) + (&/|list =text =part) + (&/|list))))))) + + ^:private analyse-text-index "index" + ^:private analyse-text-last-index "last-index" + ) + +(defn ^:private analyse-text-clip [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons from (&/$Cons to (&/$Nil)))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =from (&&/analyse-1 analyse &type/Nat from) + =to (&&/analyse-1 analyse &type/Nat to) + _ (&type/check exo-type (&/$AppT &type/Maybe &type/Text)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "clip"]) + (&/|list =text =from =to) + (&/|list))))))) + +(defn ^:private analyse-text-replace-all [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons to-find (&/$Cons replace-with (&/$Nil)))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =to-find (&&/analyse-1 analyse &type/Text to-find) + =replace-with (&&/analyse-1 analyse &type/Text replace-with) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "replace-all"]) + (&/|list =text =to-find =replace-with) + (&/|list))))))) + +(defn ^:private analyse-text-trim [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "trim"]) + (&/|list =text) + (&/|list))))))) + +(defn ^:private analyse-text-size [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ["text" "size"]) + (&/|list =text) + (&/|list))))))) + (do-template [ ] (defn [analyse exo-type ?values] (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] @@ -153,17 +213,20 @@ (return (&/|list (&&/|meta _cursor (&&/$proc (&/T ) (&/|list) (&/|list))))))) - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] - ^:private analyse-int-min-value &type/Int ["int" "min-value"] - ^:private analyse-int-max-value &type/Int ["int" "max-value"] + ^:private analyse-int-min-value &type/Int ["int" "min-value"] + ^:private analyse-int-max-value &type/Int ["int" "max-value"] - ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] - ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] + ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] - ^:private analyse-real-min-value &type/Real ["real" "min-value"] - ^:private analyse-real-max-value &type/Real ["real" "max-value"] + ^:private analyse-real-min-value &type/Real ["real" "min-value"] + ^:private analyse-real-max-value &type/Real ["real" "max-value"] + ^:private analyse-real-not-a-number &type/Real ["real" "not-a-number"] + ^:private analyse-real-positive-infinity &type/Real ["real" "positive-infinity"] + ^:private analyse-real-negative-infinity &type/Real ["real" "negative-infinity"] ) (do-template [ ] @@ -175,16 +238,23 @@ (return (&/|list (&&/|meta _cursor (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] - ^:private analyse-char-to-text &type/Char &type/Text ["char" "to-text"] + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-int-to-real &type/Int &type/Real ["int" "to-real"] + ^:private analyse-real-to-int &type/Real &type/Int ["real" "to-int"] + ^:private analyse-real-hash &type/Real &type/Nat ["real" "hash"] + + ^:private analyse-char-to-text &type/Char &type/Text ["char" "to-text"] - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ^:private analyse-lux-log! &type/Text &/$UnitT ["io" "log!"] + ^:private analyse-lux-log &type/Text &/$UnitT ["io" "log"] + ^:private analyse-lux-error &type/Text &type/Bottom ["io" "error"] ) (defn ^:private analyse-array-new [analyse exo-type ?values] @@ -245,16 +315,23 @@ (case category "lux" (case proc - "==" (analyse-lux-== analyse exo-type ?values)) + "is" (analyse-lux-is analyse exo-type ?values)) "io" (case proc - "log!" (analyse-lux-log! analyse exo-type ?values)) + "log" (analyse-lux-log analyse exo-type ?values) + "error" (analyse-lux-error analyse exo-type ?values)) "text" (case proc "=" (analyse-text-eq analyse exo-type ?values) - "append" (analyse-text-append analyse exo-type ?values)) + "append" (analyse-text-append analyse exo-type ?values) + "clip" (analyse-text-clip analyse exo-type ?values) + "index" (analyse-text-index analyse exo-type ?values) + "last-index" (analyse-text-last-index analyse exo-type ?values) + "size" (analyse-text-size analyse exo-type ?values) + "replace-all" (analyse-text-replace-all analyse exo-type ?values) + "trim" (analyse-text-trim analyse exo-type ?values)) "bit" (case proc @@ -305,6 +382,7 @@ "min-value" (analyse-int-min-value analyse exo-type ?values) "max-value" (analyse-int-max-value analyse exo-type ?values) "to-nat" (analyse-int-to-nat analyse exo-type ?values) + "to-real" (analyse-int-to-real analyse exo-type ?values) ) "deg" @@ -337,7 +415,12 @@ "decode" (analyse-real-decode analyse exo-type ?values) "min-value" (analyse-real-min-value analyse exo-type ?values) "max-value" (analyse-real-max-value analyse exo-type ?values) + "not-a-number" (analyse-real-not-a-number analyse exo-type ?values) + "positive-infinity" (analyse-real-positive-infinity analyse exo-type ?values) + "negative-infinity" (analyse-real-negative-infinity analyse exo-type ?values) "to-deg" (analyse-real-to-deg analyse exo-type ?values) + "to-int" (analyse-real-to-int analyse exo-type ?values) + "hash" (analyse-real-hash analyse exo-type ?values) ) "char" diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index a60afbc23..2e7d01d44 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -130,8 +130,7 @@ (let [file-name (str name ".lux")] (|do [file-content (&&io/read-file source-dirs file-name) :let [file-hash (hash file-content) - ;; compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs)) - compile-module!! (partial compile-module source-dirs)]] + compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] ;; (&/|eitherL (&&cache/load name)) (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] (|do [module-exists? (&a-module/exists? name)] diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index 62d440d6d..044a4f099 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -54,15 +54,31 @@ (&/adt->text obj) ))) +(defn ^:private _toString_simple [^String obj] + (reify JSObject + (isFunction [self] true) + (call [self this args] + obj + ))) + (def ^:private i64-mask (dec (bit-shift-left 1 32))) -(defn ^:private to-i64 [value] +(deftype I64 [value] + JSObject + (getMember [self member] + (condp = member + "H" (-> value (unsigned-bit-shift-right 32) (bit-and i64-mask) int) + "L" (-> value (bit-and i64-mask) int) + ;; else + (assert false (str "I64#getMember = " member))))) + +(defn ^:private encode-char [value] (reify JSObject (getMember [self member] (condp = member - "H" (-> value (unsigned-bit-shift-right 32) (bit-and i64-mask) int) - "L" (-> value (bit-and i64-mask) int) + "C" value + ;; "toString" (_toString_simple value) ;; else - (assert false (str "to-i64#getMember = " member)))))) + (assert false (str "encode-char#getMember = " member)))))) (deftype LuxJsObject [obj] JSObject @@ -73,7 +89,10 @@ (new LuxJsObject value) (instance? java.lang.Long value) - (to-i64 value) + (new I64 value) + + (instance? java.lang.Character value) + (encode-char (str value)) :else value))) @@ -81,15 +100,7 @@ (condp = member "toString" (_toString_ obj) "length" (alength obj) - "slice" (let [wrap-lux-obj #(cond (instance? lux-obj-class %) - (new LuxJsObject %) - - (instance? java.lang.Long %) - (to-i64 %) - - :else - %)] - (_slice_ wrap-lux-obj obj)) + "slice" (_slice_ #(new LuxJsObject %) obj) ;; else (assert false (str "wrap-lux-obj#getMember = " member))))) @@ -102,6 +113,13 @@ (and (.hasMember js-object "H") (.hasMember js-object "L"))) +(defn ^:private encoded-char? [^ScriptObjectMirror js-object] + (.hasMember js-object "C")) + +(defn ^:private decode-char [^ScriptObjectMirror js-object] + (-> (.getMember js-object "C") + (.charAt 0))) + (defn ^:private parse-int64 [^ScriptObjectMirror js-object] (+ (-> (.getMember js-object "H") long @@ -122,6 +140,9 @@ (instance? LuxJsObject js-object) (.-obj ^LuxJsObject js-object) + (instance? I64 js-object) + (.-value ^I64 js-object) + ;; (instance? Undefined js-object) ;; (assert false "UNDEFINED") @@ -149,6 +170,9 @@ (int64? js-object) (parse-int64 js-object) + (encoded-char? js-object) + (decode-char js-object) + :else (assert false (str "Unknown kind of JS object: " js-object)))) @@ -169,5 +193,5 @@ (let [^String module* (&host/->module-class module) module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] (do (.mkdirs (File. module-dir)) - (&&/write-file (str module-dir java.io.File/separator name ".js") (.getBytes script)))))]] + (&&/write-file (str module-dir java.io.File/separator (&host/def-name name) ".js") (.getBytes script)))))]] (return nil))) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 61f21bf55..f0ad777c6 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -19,8 +19,11 @@ )) ;; [Utils] +(defn ^:private js-module [module] + (string/replace module "/" "$")) + (defn ^:private js-var-name [module name] - (str (string/replace module "/" "$") "$" (&host/def-name name))) + (str (js-module module) "$" (&host/def-name name))) (defn ^:private captured-name [register] (str "$" register)) @@ -49,7 +52,7 @@ (return (str value))) (defn compile-char [value] - (return (str "\"" value "\""))) + (return (str "{C:\"" value "\"}"))) (defn compile-text [?value] (return (pr-str ?value))) @@ -279,7 +282,7 @@ (defn compile-function [compile arity ?scope ?env ?body] (|do [:let [??scope (&/|reverse ?scope) - function-name (str (&host/->module-class (&/|head ??scope)) + function-name (str (js-module (&/|head ??scope)) "$" (&host/location (&/|tail ??scope))) func-args (->> (&/|range* 0 (dec arity)) (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) @@ -323,12 +326,11 @@ (defn compile-def [compile ?name ?body def-meta] (|do [module-name &/get-module-name - class-loader &/loader - :let [var-name (js-var-name module-name ?name)]] + class-loader &/loader] (|case (&a-meta/meta-get &a-meta/alias-tag def-meta) (&/$Some (&/$IdentA [r-module r-name])) (if (= 1 (&/|length def-meta)) - (|do [def-value (&&/run-js! var-name) + (|do [def-value (&&/run-js! (js-var-name r-module r-name)) def-type (&a-module/def-type r-module r-name) _ (&/without-repl-closure (&a-module/define module-name ?name def-type def-meta def-value))] @@ -339,7 +341,8 @@ (&/fail-with-loc "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") _ - (|do [=body (compile ?body) + (|do [:let [var-name (js-var-name module-name ?name)] + =body (compile ?body) :let [def-js (str "var " var-name " = " =body ";") is-type? (|case (&a-meta/meta-get &a-meta/type?-tag def-meta) (&/$Some (&/$BoolA true)) @@ -348,8 +351,9 @@ _ false) def-type (&a/expr-type* ?body) - _ (&/|log! (string/replace def-js "" "^@"))] - _ (&&/run-js! def-js) + ;; _ (&/|log! (string/replace def-js "" "^@")) + ] + _ (&&/save-js! ?name def-js) def-value (&&/run-js!+ var-name) _ (&/without-repl-closure (&a-module/define module-name ?name def-type def-meta def-value)) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 385761dbe..23454914e 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -10,7 +10,8 @@ [optimizer :as &o]) [lux.analyser.base :as &a] (lux.compiler.js [base :as &&] - [rt :as &&rt]))) + [rt :as &&rt] + [lux :as &&lux]))) ;; [Resources] ;; (do-template [ ] @@ -62,22 +63,11 @@ ;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR ;; ) -;; (defn ^:private compile-lux-== [compile ?values special-args] -;; (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?left) -;; _ (compile ?right) -;; :let [$then (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; (.visitJumpInsn Opcodes/IF_ACMPEQ $then) -;; ;; else -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") -;; (.visitJumpInsn Opcodes/GOTO $end) -;; (.visitLabel $then) -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") -;; (.visitLabel $end))]] -;; (return nil))) +(defn ^:private compile-lux-is [compile ?values special-args] + (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] + =left (compile ?left) + =right (compile ?right)] + (return (str "(" =left " === " =right ")")))) (do-template [ ] (defn [compile ?values special-args] @@ -132,11 +122,42 @@ (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str &&rt/LuxRT "." "(" =x ")")))) + (return (str &&rt/LuxRT "." "(" =x ")")) + )) ^:private compile-int-encode "encodeI64" ^:private compile-nat-encode "encodeN64" ^:private compile-deg-encode "encodeD64" + + ^:private compile-int-decode "decodeI64" + ^:private compile-nat-decode "decodeN64" + ^:private compile-deg-decode "decodeD64" + + ^:private compile-real-decode "decodeReal" + + ^:private compile-real-hash "hashReal" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + ( ))) + + ^:private compile-nat-min-value &&lux/compile-nat 0 + ^:private compile-nat-max-value &&lux/compile-nat -1 + + ^:private compile-int-min-value &&lux/compile-int Long/MIN_VALUE + ^:private compile-int-max-value &&lux/compile-int Long/MAX_VALUE + + ^:private compile-deg-min-value &&lux/compile-deg 0 + ^:private compile-deg-max-value &&lux/compile-deg -1 + + ^:private compile-real-min-value &&lux/compile-real (* -1.0 Double/MAX_VALUE) + ^:private compile-real-max-value &&lux/compile-real Double/MAX_VALUE + + ^:private compile-real-not-a-number &&lux/compile-real "NaN" + ^:private compile-real-positive-infinity &&lux/compile-real "Infinity" + ^:private compile-real-negative-infinity &&lux/compile-real "-Infinity" ) (defn ^:private compile-real-encode [compile ?values special-args] @@ -166,22 +187,6 @@ ;; (.visitLabel $end))]] ;; (return nil))) -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Nil) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; :let [_ (doto *writer* -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long -;; ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long - -;; ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long -;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long -;; ) - ;; (do-template [ ] ;; (defn [compile ?values special-args] ;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -248,6 +253,26 @@ ^:private compile-int-to-nat ) +(defn ^:private compile-int-to-real [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.toNumberI64(" =x ")")))) + +(defn ^:private compile-real-to-int [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.fromNumberI64(" =x ")")))) + +(defn ^:private compile-deg-to-real [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.degToReal(" =x ")")))) + +(defn ^:private compile-real-to-deg [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.realToDeg(" =x ")")))) + (defn ^:private compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] =x (compile ?x) @@ -260,29 +285,78 @@ =y (compile ?y)] (return (str =x ".concat(" =y ")")))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + =text (compile ?text) + =part (compile ?part)] + (return (str "LuxRT" "." "(" =text "," =part ")")))) + + ^:private compile-text-last-index "lastIndex" + ^:private compile-text-index "index" + ) + +(defn ^:private compile-text-clip [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] + =text (compile ?text) + =from (compile ?from) + =to (compile ?to)] + (return (str "LuxRT.clip(" (str =text "," =from "," =to) ")")))) + +(defn ^:private compile-text-replace-all [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?to-find (&/$Cons ?replace-with (&/$Nil)))) ?values] + =text (compile ?text) + =to-find (compile ?to-find) + =replace-with (compile ?replace-with)] + (return (str "LuxRT.replaceAll(" (str =text "," =to-find "," =replace-with) ")")))) + +(defn ^:private compile-text-trim [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "(" =text ").trim()")))) + +(defn ^:private compile-text-size [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) + (defn ^:private compile-char-to-text [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] - (compile ?x))) + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "(" =x ").C")))) -(defn ^:private compile-lux-log! [compile ?values special-args] +(defn ^:private compile-lux-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] (return (str "LuxRT.log(" =message ")")))) +(defn ^:private compile-lux-error [compile ?values special-args] + (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] + =message (compile ?message)] + (return (str "LuxRT.error(" =message ")")))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category - ;; "lux" - ;; (case proc-name - ;; "==" (compile-lux-== compile ?values special-args)) + "lux" + (case proc-name + "is" (compile-lux-is compile ?values special-args)) "io" (case proc-name - "log!" (compile-lux-log! compile ?values special-args)) + "log" (compile-lux-log compile ?values special-args) + "error" (compile-lux-error compile ?values special-args)) "text" (case proc-name "=" (compile-text-eq compile ?values special-args) - "append" (compile-text-append compile ?values special-args)) + "append" (compile-text-append compile ?values special-args) + "clip" (compile-text-clip compile ?values special-args) + "index" (compile-text-index compile ?values special-args) + "last-index" (compile-text-last-index compile ?values special-args) + "size" (compile-text-size compile ?values special-args) + "replace-all" (compile-text-replace-all compile ?values special-args) + "trim" (compile-text-trim compile ?values special-args) + ) ;; "bit" ;; (case proc-name @@ -308,9 +382,9 @@ "=" (compile-nat-eq compile ?values special-args) "<" (compile-nat-lt compile ?values special-args) "encode" (compile-nat-encode compile ?values special-args) - ;; "decode" (compile-nat-decode compile ?values special-args) - ;; "max-value" (compile-nat-max-value compile ?values special-args) - ;; "min-value" (compile-nat-min-value compile ?values special-args) + "decode" (compile-nat-decode compile ?values special-args) + "max-value" (compile-nat-max-value compile ?values special-args) + "min-value" (compile-nat-min-value compile ?values special-args) "to-int" (compile-nat-to-int compile ?values special-args) ;; "to-char" (compile-nat-to-char compile ?values special-args) ) @@ -325,10 +399,11 @@ "=" (compile-int-eq compile ?values special-args) "<" (compile-int-lt compile ?values special-args) "encode" (compile-int-encode compile ?values special-args) - ;; "decode" (compile-int-decode compile ?values special-args) - ;; "max-value" (compile-int-max-value compile ?values special-args) - ;; "min-value" (compile-int-min-value compile ?values special-args) + "decode" (compile-int-decode compile ?values special-args) + "max-value" (compile-int-max-value compile ?values special-args) + "min-value" (compile-int-min-value compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) + "to-real" (compile-int-to-real compile ?values special-args) ) "deg" @@ -341,10 +416,10 @@ "=" (compile-deg-eq compile ?values special-args) "<" (compile-deg-lt compile ?values special-args) "encode" (compile-deg-encode compile ?values special-args) - ;; "decode" (compile-deg-decode compile ?values special-args) - ;; "max-value" (compile-deg-max-value compile ?values special-args) - ;; "min-value" (compile-deg-min-value compile ?values special-args) - ;; "to-real" (compile-deg-to-real compile ?values special-args) + "decode" (compile-deg-decode compile ?values special-args) + "max-value" (compile-deg-max-value compile ?values special-args) + "min-value" (compile-deg-min-value compile ?values special-args) + "to-real" (compile-deg-to-real compile ?values special-args) "scale" (compile-deg-scale compile ?values special-args) ) @@ -358,10 +433,15 @@ "=" (compile-real-eq compile ?values special-args) "<" (compile-real-lt compile ?values special-args) "encode" (compile-real-encode compile ?values special-args) - ;; "decode" (compile-real-decode compile ?values special-args) - ;; "max-value" (compile-real-max-value compile ?values special-args) - ;; "min-value" (compile-real-min-value compile ?values special-args) - ;; "to-deg" (compile-real-to-deg compile ?values special-args) + "decode" (compile-real-decode compile ?values special-args) + "max-value" (compile-real-max-value compile ?values special-args) + "min-value" (compile-real-min-value compile ?values special-args) + "not-a-number" (compile-real-not-a-number compile ?values special-args) + "positive-infinity" (compile-real-positive-infinity compile ?values special-args) + "negative-infinity" (compile-real-negative-infinity compile ?values special-args) + "to-deg" (compile-real-to-deg compile ?values special-args) + "to-int" (compile-real-to-int compile ?values special-args) + "hash" (compile-real-hash compile ?values special-args) ) "char" diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index ce5bf5d16..1cb4a6150 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -941,16 +941,50 @@ }) (def ^:private i64-methods - {"makeI64" (str "(function makeI64(high,low) {" + {"TWO_PWR_16" "(1 << 16)" + "TWO_PWR_32" "((1 << 16) * (1 << 16))" + "TWO_PWR_64" "(((1 << 16) * (1 << 16)) * ((1 << 16) * (1 << 16)))" + "TWO_PWR_63" "((((1 << 16) * (1 << 16)) * ((1 << 16) * (1 << 16))) / 2)" + "getLowBitsUnsigned" (str "(function getLowBitsUnsigned(i64) {" + "return (i64.L >= 0) ? i64.L : (LuxRT.TWO_PWR_32 + i64.L);" + "})") + "toNumberI64" (str "(function toNumberI64(i64) {" + "return (i64.H * LuxRT.TWO_PWR_32) + LuxRT.getLowBitsUnsigned(i64);" + "})") + "fromNumberI64" (str "(function fromNumberI64(num) {" + (str "if (isNaN(num)) {" + "return LuxRT.ZERO;" + "}") + (str "else if (num <= -LuxRT.TWO_PWR_63) {" + "return LuxRT.MIN_VALUE_I64;" + "}") + (str "else if ((num + 1) >= LuxRT.TWO_PWR_63) {" + "return LuxRT.MAX_VALUE_I64;" + "}") + (str "else if (num < 0) {" + "return LuxRT.negateI64(LuxRT.fromNumberI64(-num));" + "}") + (str "else {" + "return LuxRT.makeI64((num / LuxRT.TWO_PWR_32), (num % LuxRT.TWO_PWR_32));" + "}") + "})") + "makeI64" (str "(function makeI64(high,low) {" "return { H: (high|0), L: (low|0)};" "})") - "MIN_VALUE" "{ H: 0x80000000, L: 0}" - "ONE" "{ H: 0, L: 1}" + "MIN_VALUE_I64" "{ H: (0x80000000|0), L: (0|0)}" + "MAX_VALUE_I64" "{ H: (0x7FFFFFFF|0), L: (0xFFFFFFFF|0)}" + "ONE" "{ H: (0|0), L: (1|0)}" + "ZERO" "{ H: (0|0), L: (0|0)}" "notI64" (str "(function notI64(i64) {" "return LuxRT.makeI64(~i64.H,~i64.L);" "})") "negateI64" (str "(function negateI64(i64) {" - "return LuxRT.addI64(LuxRT.notI64(i64),LuxRT.makeI64(0,1));" + (str "if(LuxRT.eqI64(LuxRT.MIN_VALUE_I64,i64)) {" + "return LuxRT.MIN_VALUE_I64;" + "}") + (str "else {" + "return LuxRT.addI64(LuxRT.notI64(i64),LuxRT.ONE);" + "}") "})") "eqI64" (str "(function eqI64(l,r) {" "return (l.H === r.H) && (l.L === r.L);" @@ -1045,14 +1079,14 @@ ;; Special case: L = 0 "return l;" "}") - (str "if(LuxRT.eqI64(l,LuxRT.MIN_VALUE)) {" + (str "if(LuxRT.eqI64(l,LuxRT.MIN_VALUE_I64)) {" ;; Special case: L = MIN (str "if(LuxRT.eqI64(r,LuxRT.ONE) || LuxRT.eqI64(r,LuxRT.negateI64(LuxRT.ONE))) {" ;; Special case: L = MIN, R = 1|-1 - "return LuxRT.MIN_VALUE;" + "return LuxRT.MIN_VALUE_I64;" "}" ;; Special case: L = R = MIN - "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {" + "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE_I64)) {" "return LuxRT.ONE;" "}" ;; Special case: L = MIN @@ -1073,7 +1107,7 @@ "}") "}") "}" - "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {" + "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE_I64)) {" ;; Special case: R = MIN "return LuxRT.makeI64(0,0);" "}") @@ -1093,7 +1127,7 @@ "return LuxRT.negateI64(LuxRT.divI64(l,LuxRT.negateI64(r)));" "}") ;; Common case - (str "var res = { H: 0, L: 0};" + (str "var res = LuxRT.ZERO;" "var rem = l;" (str "while(LuxRT.ltI64(r,rem) || LuxRT.eqI64(r,rem)) {" "var approx = Math.max(1, Math.floor(LuxRT.toNumberI64(rem) / LuxRT.toNumberI64(r)));" @@ -1124,16 +1158,16 @@ "}") ;; If input < 0 (str "if(input.H < 0) {" - (str "if(LuxRT.eqI64(input,LuxRT.MIN_VALUE)) {" + (str "if(LuxRT.eqI64(input,LuxRT.MIN_VALUE_I64)) {" "var radix = LuxRT.makeI64(0,10);" "var div = LuxRT.divI64(input,radix);" "var rem = LuxRT.subI64(LuxRT.mulI64(div,radix),input);" "return LuxRT.encodeI64(div).concat(rem.L+'');" "}") "}" - "else {" - "return '-'.concat(LuxRT.encodeI64(LuxRT.negateI64(input)));" - "}") + (str "else {" + "return '-'.concat(LuxRT.encodeI64(LuxRT.negateI64(input)));" + "}")) ;; If input > 0 (str "var chunker = LuxRT.makeI64(0,1000000);" "var rem = input;" @@ -1176,6 +1210,11 @@ "return '+'.concat(LuxRT.encodeI64(input));" "}") "})") + "ltN64" (str "(function ltN64(l,r) {" + "var li = LuxRT.addI64(l,LuxRT.MIN_VALUE_I64);" + "var ri = LuxRT.addI64(r,LuxRT.MIN_VALUE_I64);" + "return LuxRT.ltI64(li,ri);" + "})") }) (def ^:private io-methods @@ -1183,6 +1222,48 @@ "console.log(message);" (str "return " &&/unit ";") "})") + "error" (str "(function error(message) {" + "throw new Error(message);" + (str "return null;") + "})") + }) + +(def ^:private const-none (str "[0,null," &&/unit "]")) +(defn ^:private make-some [value] + (str "[1,''," value "]")) + +(def ^:private text-methods + {"index" (str "(function index(text,part) {" + "var idx = text.indexOf(part);" + (str (str "if(idx === -1) {" + "return " const-none ";" + "}") + (str "else {" + (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") + "}")) + "})") + "lastIndex" (str "(function lastIndex(text,part) {" + "var idx = text.lastIndexOf(part);" + (str (str "if(idx === -1) {" + "return " const-none ";" + "}") + (str "else {" + (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") + "}")) + "})") + "clip" (str "(function clip(text,from,to) {" + "var clip = text.substring(from.L,to.L);" + (str (str "if(clip === '') {" + "return " const-none ";" + "}") + (str "else {" + "return " (make-some "clip") ";" + "}")) + "})") + "replaceAll" (str "(function replaceAll(text,toFind,replaceWith) {" + "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" + "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" + "})") }) (def LuxRT "LuxRT") @@ -1192,6 +1273,7 @@ :let [rt-object (str "{" (->> (merge adt-methods i64-methods n64-methods + text-methods io-methods) (map (fn [[key val]] (str key ":" val))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 4ed8134fd..c48403e52 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -162,7 +162,7 @@ ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR ) -(defn ^:private compile-lux-== [compile ?values special-args] +(defn ^:private compile-lux-is [compile ?values special-args] (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?left) @@ -209,11 +209,11 @@ ^:private compile-deg-rem Opcodes/LSUB &&/unwrap-long &&/wrap-long ^:private compile-deg-scale Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double + ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double ) (do-template [ ] @@ -450,6 +450,21 @@ ^:private compile-int-to-nat ) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-real-to-int &&/unwrap-double Opcodes/D2L &&/wrap-long + ^:private compile-int-to-real &&/unwrap-long Opcodes/L2D &&/wrap-double + ) + (defn compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer @@ -473,7 +488,93 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] (return nil))) -(defn compile-io-log! [compile ?values special-args] +(defn compile-text-clip [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?from) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?to) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;"))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?part) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;)I"))] + :let [$not-found (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $not-found) + (.visitInsn Opcodes/I2L) + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $not-found) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitLabel $end))]] + (return nil))) + + ^:private compile-text-index "indexOf" + ^:private compile-text-last-index "lastIndexOf" + ) + +(defn ^:private compile-text-size [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-text-replace-all [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?pattern (&/$Cons ?replacement (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?pattern) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?replacement) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]] + (return nil))) + +(defn ^:private compile-text-trim [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "trim" "()Ljava/lang/String;"))]] + (return nil))) + +(defn compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -485,20 +586,41 @@ (.visitLdcInsn &/unit-tag))]] (return nil))) +(defn compile-io-error [compile ?values special-args] + (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW "java/lang/Error") + (.visitInsn Opcodes/DUP))] + _ (compile ?message) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Error" "" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW))]] + (return nil))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category "lux" (case proc-name - "==" (compile-lux-== compile ?values special-args)) + "is" (compile-lux-is compile ?values special-args)) "io" (case proc-name - "log!" (compile-io-log! compile ?values special-args)) + "log" (compile-io-log compile ?values special-args) + "error" (compile-io-error compile ?values special-args)) "text" (case proc-name "=" (compile-text-eq compile ?values special-args) - "append" (compile-text-append compile ?values special-args)) + "append" (compile-text-append compile ?values special-args) + "clip" (compile-text-clip compile ?values special-args) + "index" (compile-text-index compile ?values special-args) + "last-index" (compile-text-last-index compile ?values special-args) + "size" (compile-text-size compile ?values special-args) + "replace-all" (compile-text-replace-all compile ?values special-args) + "trim" (compile-text-trim compile ?values special-args) + ) "bit" (case proc-name @@ -562,6 +684,7 @@ "=" (compile-int-eq compile ?values special-args) "<" (compile-int-lt compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) + "to-real" (compile-int-to-real compile ?values special-args) "encode" (compile-int-encode compile ?values special-args) ) @@ -575,6 +698,7 @@ "=" (compile-real-eq compile ?values special-args) "<" (compile-real-lt compile ?values special-args) "encode" (compile-real-encode compile ?values special-args) + "to-int" (compile-real-to-int compile ?values special-args) "to-deg" (compile-real-to-deg compile ?values special-args) ) diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 1beb9aa21..303d9ae0a 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -1204,6 +1204,33 @@ (.visitEnd))] nil)) +(defn ^:private compile-LuxRT-text-methods [^ClassWriter =class] + (|do [:let [_ (let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))]] + (return nil))) + (def compile-LuxRT-class (|do [_ (return nil) :let [full-name &&/lux-utils-class @@ -1264,6 +1291,7 @@ (compile-LuxRT-pm-methods) (compile-LuxRT-adt-methods) (compile-LuxRT-nat-methods) - (compile-LuxRT-deg-methods))]] + (compile-LuxRT-deg-methods) + (compile-LuxRT-text-methods))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 06c0fd2fd..c6018398b 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1666,6 +1666,13 @@ (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')])))) +(def:''' #export (log! message) + (list [["lux" "doc"] (#TextA "Logs message to standard output. + + Useful for debugging.")]) + (-> Text Unit) + (_lux_proc ["io" "log"] [message])) + (def:''' (Text/append x y) #Nil (-> Text Text Text) @@ -2241,13 +2248,6 @@ (-> Bool Bool) (if x false true)) -(def:''' #export (log! message) - (list [["lux" "doc"] (#TextA "Logs message to standard output. - - Useful for debugging.")]) - (-> Text Unit) - (_lux_proc ["io" "log!"] [message])) - (def:''' (find-macro' modules current-module module name) #Nil (-> ($' List (& Text Module)) @@ -2568,7 +2568,7 @@ (macro:' #export (Rec tokens) (list [["lux" "doc"] (#TextA "## Parameter-less recursive types. - ## A name has to be given to the whole type, to use it within it's body. + ## A name has to be given to the whole type, to use it within its body. (Rec Self [Int (List Self)])")]) (_lux_case tokens @@ -3223,42 +3223,81 @@ (#Some y)))) (def: (last-index-of part text) - (-> Text Text Int) - (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:lastIndexOf:java.lang.String"] [text part])])) + (-> Text Text (Maybe Nat)) + (_lux_proc ["text" "last-index"] [text part])) (def: (index-of part text) - (-> Text Text Int) - (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:indexOf:java.lang.String"] [text part])])) + (-> Text Text (Maybe Nat)) + (_lux_proc ["text" "index"] [text part])) + +(def: (clip1 from text) + (-> Nat Text (Maybe Text)) + (_lux_proc ["text" "clip"] [text from (_lux_proc ["text" "size"] [text])])) + +(def: (clip2 from to text) + (-> Nat Nat Text (Maybe Text)) + (_lux_proc ["text" "clip"] [text from to])) + +(def: #export (error! message) + {#;doc "## Causes an error, with the given error message. + (error! \"OH NO!\")"} + (-> Text Bottom) + (_lux_proc ["io" "error"] [message])) -(def: (substring1 idx text) - (-> Int Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [text (_lux_proc ["jvm" "l2i"] [idx])])) +(macro: #export (default tokens state) + {#;doc "## Allows you to provide a default value that will be used + ## if a (Maybe x) value turns out to be #;None. + (default 20 (#;Some 10)) => 10 -(def: (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [text (_lux_proc ["jvm" "l2i"] [idx1]) (_lux_proc ["jvm" "l2i"] [idx2])])) + (default 20 #;None) => 20"} + (case tokens + (^ (list else maybe)) + (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])]) + code (` (case (~ maybe) + (#;Some (~ g!temp)) + (~ g!temp) + + #;None + (~ else)))] + (#;Right [state (list code)])) + + _ + (#;Left "Wrong syntax for ?"))) (def: (split-text splitter input) (-> Text Text (List Text)) - (let [idx (index-of splitter input)] - (if (i.< 0 idx) - (#Cons input #Nil) - (#Cons (substring2 0 idx input) - (split-text splitter (substring1 (i.+ 1 idx) input)))))) + (case (index-of splitter input) + #;None + (#Cons input #Nil) + + (#;Some idx) + (#Cons (default (error! "UNDEFINED") + (clip2 +0 idx input)) + (split-text splitter + (default (error! "UNDEFINED") + (clip1 (n.+ +1 idx) input)))))) (def: (split-module-contexts module) (-> Text (List Text)) - (#Cons module (let [idx (last-index-of "/" module)] - (if (i.< 0 idx) - #Nil - (split-module-contexts (substring2 0 idx module)))))) + (#Cons module (case (last-index-of "/" module) + #;None + #Nil + + (#;Some idx) + (split-module-contexts (default (error! "UNDEFINED") + (clip2 +0 idx module)))))) (def: (split-module module) (-> Text (List Text)) - (let [idx (index-of "/" module)] - (if (i.< 0 idx) - (list module) - (list& (substring2 0 idx module) (split-module (substring1 (i.+ 1 idx) module)))))) + (case (index-of "/" module) + #;None + (list module) + + (#;Some idx) + (list& (default (error! "UNDEFINED") + (clip2 +0 idx module)) + (split-module (default (error! "UNDEFINED") + (clip1 (n.+ +1 idx) module)))))) (def: (nth idx xs) (All [a] @@ -3881,22 +3920,22 @@ (def: (replace pattern value template) (-> Text Text Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) + (_lux_proc ["text" "replace-all"] [template pattern value])) (def: (clean-module module) (-> Text (Lux Text)) (do Monad - [module-name current-module-name] + [current-module current-module-name] (case (split-module module) (^ (list& "." parts)) - (return (|> (list& module-name parts) (interpose "/") reverse (fold Text/append ""))) + (return (|> (list& current-module parts) (interpose "/") reverse (fold Text/append ""))) parts (let [[ups parts'] (split-with (Text/= "..") parts) num-ups (length ups)] (if (i.= num-ups 0) (return module) - (case (nth num-ups (split-module-contexts module-name)) + (case (nth num-ups (split-module-contexts current-module)) #None (fail (Text/append "Can't clean module: " module)) @@ -4378,26 +4417,6 @@ #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _ #module-state _} module]] (wrap (is-member? imports import-name)))) -(macro: #export (default tokens state) - {#;doc "## Allows you to provide a default value that will be used - ## if a (Maybe x) value turns out to be #;None. - (default 20 (#;Some 10)) => 10 - - (default 20 #;None) => 20"} - (case tokens - (^ (list else maybe)) - (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])]) - code (` (case (~ maybe) - (#;Some (~ g!temp)) - (~ g!temp) - - #;None - (~ else)))] - (#;Right [state (list code)])) - - _ - (#;Left "Wrong syntax for ?"))) - (def: (read-refer module-name options) (-> Text (List AST) (Lux Refer)) (do Monad @@ -4790,13 +4809,13 @@ _ (fail "Wrong syntax for ^template"))) -(do-template [ ] +(do-template [ ] [(def: #export ( n) (-> ) - (_lux_proc ["jvm" ] [n]))] + (_lux_proc [n]))] - [real-to-int Real Int "d2l"] - [int-to-real Int Real "l2d"] + [real-to-int Real Int ["real" "to-int"]] + [int-to-real Int Real ["int" "to-real"]] ) (def: (find-baseline-column ast) @@ -4874,11 +4893,10 @@ (-> ) (_lux_proc [input]))] - [int-to-nat ["int" "to-nat"] Int Nat] - [nat-to-int ["nat" "to-int"] Nat Int] - + [int-to-nat ["int" "to-nat"] Int Nat] + [nat-to-int ["nat" "to-int"] Nat Int] [real-to-deg ["real" "to-deg"] Real Deg] - [deg-to-real ["deg" "to-real"] Deg Real] + [deg-to-real ["deg" "to-real"] Deg Real] ) (def: (repeat n x) @@ -4897,13 +4915,11 @@ (def: (Text/size x) (-> Text Nat) - (:! Nat - (_lux_proc ["jvm" "i2l"] - [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))) + (_lux_proc ["text" "size"] [x])) (def: (Text/trim x) (-> Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:trim:"] [x])) + (_lux_proc ["text" "trim"] [x])) (def: (update-cursor [file line column] ast-text) (-> Cursor Text Cursor) @@ -5468,7 +5484,7 @@ "This one should fail:" (is 5 (i.+ 2 3)))} (All [a] (-> a a Bool)) - (_lux_proc ["lux" "=="] [left right])) + (_lux_proc ["lux" "is"] [left right])) (macro: #export (^@ tokens) {#;doc (doc "Allows you to simultaneously bind and de-structure a value." @@ -5514,12 +5530,6 @@ _ (fail "Wrong syntax for :!!"))) -(def: #export (error! message) - {#;doc (doc "Causes an error, with the given error message." - (error! "OH NO!"))} - (-> Text Bottom) - (_lux_proc ["jvm" "throw"] [(_lux_proc ["jvm" "new:java.lang.Error:java.lang.String"] [message])])) - (def: #hidden hack_Text/append (-> Text Text Text) Text/append) @@ -5735,3 +5745,7 @@ (type: #export (<.> f g) (All [a] (f (g a)))) + +(def: #export (assume mx) + (All [a] (-> (Maybe a) a)) + (default (undefined) mx)) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 998b42ea8..ce0d5f887 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -17,7 +17,7 @@ [ Nat n.=] [ Int i.=] - [Deg d.=] + [ Deg d.=] [Real r.=] ) @@ -29,9 +29,9 @@ (def: > ) (def: >= ))] - [ Nat Eq n.< n.<= n.> n.>=] - [ Int Eq i.< i.<= i.> i.>=] - [Deg Eq d.< d.<= d.> d.>=] + [ Nat Eq n.< n.<= n.> n.>=] + [ Int Eq i.< i.<= i.> i.>=] + [Deg Eq d.< d.<= d.> d.>=] [Real Eq r.< r.<= r.> r.>=] ) @@ -100,38 +100,34 @@ (def: top ) (def: bottom ))] - [ Nat Ord (_lux_proc ["nat" "max-value"] []) (_lux_proc ["nat" "min-value"] [])] - [ Int Ord (_lux_proc ["jvm" "getstatic:java.lang.Long:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Long:MIN_VALUE"] [])] - [Real Ord (_lux_proc ["jvm" "getstatic:java.lang.Double:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Double:MIN_VALUE"] [])] - [Deg Ord (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "min-value"] [])]) + [ Nat Ord (_lux_proc [ "nat" "max-value"] []) (_lux_proc [ "nat" "min-value"] [])] + [ Int Ord (_lux_proc [ "int" "max-value"] []) (_lux_proc [ "int" "min-value"] [])] + [Real Ord (_lux_proc ["real" "max-value"] []) (_lux_proc ["real" "min-value"] [])] + [ Deg Ord (_lux_proc [ "deg" "max-value"] []) (_lux_proc [ "deg" "min-value"] [])]) (do-template [ ] [(struct: #export (Monoid ) (def: unit ) (def: (append x y) ( x y)))] - [ Add@Monoid Nat +0 n.+] - [ Mul@Monoid Nat +1 n.*] + [ Add@Monoid Nat +0 n.+] + [ Mul@Monoid Nat +1 n.*] [ Max@Monoid Nat (:: Interval bottom) n.max] [ Min@Monoid Nat (:: Interval top) n.min] - [ Add@Monoid Int 0 i.+] - [ Mul@Monoid Int 1 i.*] + [ Add@Monoid Int 0 i.+] + [ Mul@Monoid Int 1 i.*] [ Max@Monoid Int (:: Interval bottom) i.max] [ Min@Monoid Int (:: Interval top) i.min] - [Add@Monoid Real 0.0 r.+] - [Mul@Monoid Real 1.0 r.*] + [Add@Monoid Real 0.0 r.+] + [Mul@Monoid Real 1.0 r.*] [Max@Monoid Real (:: Interval bottom) r.max] [Min@Monoid Real (:: Interval top) r.min] - [Add@Monoid Deg (:: Interval bottom) d.+] - [Mul@Monoid Deg (:: Interval top) d.*] - [Max@Monoid Deg (:: Interval bottom) d.max] - [Min@Monoid Deg (:: Interval top) d.min] + [ Add@Monoid Deg (:: Interval bottom) d.+] + [ Mul@Monoid Deg (:: Interval top) d.*] + [ Max@Monoid Deg (:: Interval bottom) d.max] + [ Min@Monoid Deg (:: Interval top) d.min] ) -(def: (text.replace pattern value template) - (-> Text Text Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) - (do-template [ ] [(struct: #export _ (Codec Text ) (def: (encode x) @@ -145,26 +141,10 @@ #;None (#;Left ))))] - [Nat ["nat" "encode"] ["nat" "decode"] "Couldn't decode Nat"] - [Deg ["deg" "encode"] ["deg" "decode"] "Couldn't decode Deg"] - ) - -(def: clean-number - (-> Text Text) - (text.replace "_" "")) - -(do-template [ ] - [(struct: #export _ (Codec Text ) - (def: (encode x) - (_lux_proc ["jvm" ] [x])) - - (def: (decode input) - (_lux_proc ["jvm" "try"] - [(#;Right (_lux_proc ["jvm" ] [(clean-number input)])) - (lambda [e] (#;Left ))])))] - - [ Int "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Long:parseLong:java.lang.String" "Couldn't parse Int"] - [Real "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Double:parseDouble:java.lang.String" "Couldn't parse Real"] + [ Nat [ "nat" "encode"] [ "nat" "decode"] "Couldn't decode Nat"] + [ Int [ "int" "encode"] [ "int" "decode"] "Couldn't decode Int"] + [ Deg [ "deg" "encode"] [ "deg" "decode"] "Couldn't decode Deg"] + [Real ["real" "encode"] ["real" "decode"] "Couldn't decode Real"] ) (struct: #export _ (Hash Nat) @@ -178,13 +158,24 @@ (struct: #export _ (Hash Real) (def: eq Eq) - (def: hash - (|>. (:: Codec encode) - [] - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"]) - [] - (_lux_proc ["jvm" "i2l"]) - int-to-nat))) + (def: (hash value) + (_lux_proc ["real" "hash"] [value]))) + +(do-template [ ] + [(def: #export + {#;doc } + Real + (_lux_proc ["real" ] []))] + + [not-a-number "not-a-number" "Not-a-number."] + [positive-infinity "positive-infinity" "Positive infinity."] + [negative-infinity "negative-infinity" "Negative infinity."] + ) + +(def: #export (not-a-number? number) + {#;doc "Tests whether a real is actually not-a-number."} + (-> Real Bool) + (not (r.= number number))) ## [Values & Syntax] (do-template [ ] @@ -221,19 +212,3 @@ (doc "Given syntax for a hexadecimal number, generates a Nat." (hex "deadBEEF"))] ) - -(do-template [ ] - [(def: #export - {#;doc } - Real - (_lux_proc ["jvm" ] []))] - - [nan "getstatic:java.lang.Double:NaN" "Not-a-number."] - [+inf "getstatic:java.lang.Double:POSITIVE_INFINITY" "Positive infinity."] - [-inf "getstatic:java.lang.Double:NEGATIVE_INFINITY" "Negative infinity."] - ) - -(def: #export (nan? number) - {#;doc "Tests whether a real is actually not-a-number."} - (-> Real Bool) - (not (r.= number number))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index bec6d7d2b..9375d6876 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -33,7 +33,7 @@ [trim "invokevirtual:java.lang.String:trim:"] ) -(def: #export (sub from to x) +(def: #export (clip from to x) (-> Nat Nat Text (Maybe Text)) (if (and (n.< to from) (n.<= (size x) to)) @@ -43,9 +43,9 @@ (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])])) #;None)) -(def: #export (sub' from x) +(def: #export (clip' from x) (-> Nat Text (Maybe Text)) - (sub from (size x) x)) + (clip from (size x) x)) (def: #export (replace pattern value template) (-> Text Text Text Text) @@ -158,7 +158,7 @@ (def: (decode input) (if (and (starts-with? "\"" input) (ends-with? "\"" input)) - (case (sub +1 (n.dec (size input)) input) + (case (clip +1 (n.dec (size input)) input) (#;Some input') (|> input' (replace "\\\\" "\\") diff --git a/stdlib/source/lux/math/complex.lux b/stdlib/source/lux/math/complex.lux index eae4fbe55..87b1a7d18 100644 --- a/stdlib/source/lux/math/complex.lux +++ b/stdlib/source/lux/math/complex.lux @@ -38,9 +38,9 @@ (def: #export zero Complex (complex 0.0 0.0)) -(def: #export (nan? complex) - (or (number;nan? (get@ #real complex)) - (number;nan? (get@ #imaginary complex)))) +(def: #export (not-a-number? complex) + (or (number;not-a-number? (get@ #real complex)) + (number;not-a-number? (get@ #imaginary complex)))) (def: #export (c.= param input) (-> Complex Complex Bool) @@ -317,7 +317,7 @@ (def: (decode input) (case (do Monad - [input' (text;sub +1 (n.- +1 (text;size input)) input)] + [input' (text;clip +1 (n.- +1 (text;size input)) input)] (text;split-with "," input')) #;None (#;Left (Text/append "Wrong syntax for complex numbers: " input)) diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index 9516ae317..92ed5e2ca 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -115,10 +115,10 @@ (|> x' (/ y) (* y) (= x')))) ))] - ["Nat" R;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id] - ["Int" R;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id] - ["Real" R;real r.= r.+ r.- r.* r./ r.% r.> 0.0 1.0 1000000.0 %r id math;floor] - ["Deg" R;deg d.= d.+ d.- d.* d./ d.% d.> .0 (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "max-value"] []) %f id id] + ["Nat" R;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id] + ["Int" R;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id] + ["Real" R;real r.= r.+ r.- r.* r./ r.% r.> 0.0 1.0 1000000.0 %r id math;floor] + ["Deg" R;deg d.= d.+ d.- d.* d./ d.% d.> .0 (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "max-value"] []) %f id id] ) (do-template [category rand-gen -> <- = %a %z] @@ -128,10 +128,10 @@ (assert "" (|> value -> <- (= value))))] - ["Int->Nat" R;int int-to-nat nat-to-int i.= (i.% 1000000) %i %n] - ["Nat->Int" R;nat nat-to-int int-to-nat n.= (n.% +1000000) %n %i] - ["Int->Real" R;int int-to-real real-to-int i.= (i.% 1000000) %i %r] - ["Real->Int" R;real real-to-int int-to-real r.= math;floor %r %i] + ["Int->Nat" R;int int-to-nat nat-to-int i.= (i.% 1000000) %i %n] + ["Nat->Int" R;nat nat-to-int int-to-nat n.= (n.% +1000000) %n %i] + ["Int->Real" R;int int-to-real real-to-int i.= (i.% 1000000) %i %r] + ["Real->Int" R;real real-to-int int-to-real r.= math;floor %r %i] ## [R;real real-to-deg deg-to-real r.= (r.% 1.0) %r %f] ) diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux index fd847001e..8ddd27a7c 100644 --- a/stdlib/test/test/lux/data/text.lux +++ b/stdlib/test/test/lux/data/text.lux @@ -77,10 +77,10 @@ _ false)) - (|> [(&;sub +0 sizeL sample) - (&;sub sizeL (&;size sample) sample) - (&;sub' sizeL sample) - (&;sub' +0 sample)] + (|> [(&;clip +0 sizeL sample) + (&;clip sizeL (&;size sample) sample) + (&;clip' sizeL sample) + (&;clip' +0 sample)] (case> [(#;Right _l) (#;Right _r) (#;Right _r') (#;Right _f)] (and (= sampleL _l) (= sampleR _r) diff --git a/stdlib/test/test/lux/math/complex.lux b/stdlib/test/test/lux/math/complex.lux index 04ebcb3c0..f965f9214 100644 --- a/stdlib/test/test/lux/math/complex.lux +++ b/stdlib/test/test/lux/math/complex.lux @@ -54,8 +54,8 @@ (r.= imaginary (get@ #&;imaginary r+i))))) (assert "If either the real part or the imaginary part is NaN, the composite is NaN." - (and (&;nan? (&;complex number;nan imaginary)) - (&;nan? (&;complex real number;nan)))) + (and (&;not-a-number? (&;complex number;not-a-number imaginary)) + (&;not-a-number? (&;complex real number;not-a-number)))) )) (test: "Absolute value" @@ -69,14 +69,14 @@ (r.>= (r/abs imaginary) abs)))) (assert "The absolute value of a complex number involving a NaN on either dimension, results in a NaN value." - (and (number;nan? (get@ #&;real (&;c.abs (&;complex number;nan imaginary)))) - (number;nan? (get@ #&;real (&;c.abs (&;complex real number;nan)))))) + (and (number;not-a-number? (get@ #&;real (&;c.abs (&;complex number;not-a-number imaginary)))) + (number;not-a-number? (get@ #&;real (&;c.abs (&;complex real number;not-a-number)))))) (assert "The absolute value of a complex number involving an infinity on either dimension, results in an infinite value." - (and (r.= number;+inf (get@ #&;real (&;c.abs (&;complex number;+inf imaginary)))) - (r.= number;+inf (get@ #&;real (&;c.abs (&;complex real number;+inf)))) - (r.= number;+inf (get@ #&;real (&;c.abs (&;complex number;-inf imaginary)))) - (r.= number;+inf (get@ #&;real (&;c.abs (&;complex real number;-inf)))))) + (and (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;positive-infinity imaginary)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;positive-infinity)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;negative-infinity imaginary)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;negative-infinity)))))) )) (test: "Addidion, substraction, multiplication and division" -- cgit v1.3.1 From 277747aee1b0b19e88a0e685299f278201737011 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 17 Feb 2017 18:24:45 -0400 Subject: - Added more common procedures. - Fixed some bugs in the type-checking of some common procedures. - Removed the "_name" field for generated classes. - Now compiling loops in JS. - Did some refactoring to the caching machinery. - Implemented binary, octal and hexadecimal encoding purely in Lux. --- luxc/src/lux/analyser/proc/common.clj | 56 ++++++++++++++++++--------- luxc/src/lux/base.clj | 1 - luxc/src/lux/compiler/js.clj | 7 ++-- luxc/src/lux/compiler/js/lux.clj | 29 ++++++-------- luxc/src/lux/compiler/js/proc/common.clj | 25 +++++++++--- luxc/src/lux/compiler/js/rt.clj | 11 ++++++ luxc/src/lux/compiler/jvm/cache.clj | 66 +++++++++++++------------------- luxc/src/lux/compiler/jvm/lux.clj | 4 -- stdlib/source/lux/data/number.lux | 42 ++++++++++++++++---- 9 files changed, 145 insertions(+), 96 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 4a4048c1c..bec0855e1 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -24,7 +24,7 @@ =y (&&/analyse-1 analyse y) _ (&type/check exo-type ) _cursor &/cursor] - (return (&/|list (&&/|meta _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool @@ -38,7 +38,7 @@ =part (&&/analyse-1 analyse &type/Text part) _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["text" ]) (&/|list =text =part) (&/|list))))))) @@ -71,24 +71,41 @@ (&/|list =text =to-find =replace-with) (&/|list))))))) -(defn ^:private analyse-text-trim [analyse exo-type ?values] +(defn ^:private analyse-text-size [analyse exo-type ?values] (|do [:let [(&/$Cons text (&/$Nil)) ?values] =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Text) + _ (&type/check exo-type &type/Nat) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["text" "trim"]) + (&&/$proc (&/T ["text" "size"]) (&/|list =text) (&/|list))))))) -(defn ^:private analyse-text-size [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Nil)) ?values] +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" ]) + (&/|list =text) + (&/|list))))))) + + ^:private analyse-text-trim "trim" + ^:private analyse-text-upper-case "upper-case" + ^:private analyse-text-lower-case "lower-case" + ) + +(defn ^:private analyse-text-char [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons idx (&/$Nil))) ?values] =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) + =idx (&&/analyse-1 analyse &type/Nat idx) + _ (&type/check exo-type (&/$AppT &type/Maybe &type/Char)) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ["text" "size"]) - (&/|list =text) + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "char"]) + (&/|list =text =idx) (&/|list))))))) (do-template [ ] @@ -136,7 +153,7 @@ =y (&&/analyse-1 analyse y) _ (&type/check exo-type ) _cursor &/cursor] - (return (&/|list (&&/|meta _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat @@ -178,7 +195,7 @@ =y (&&/analyse-1 analyse &type/Nat y) _ (&type/check exo-type &type/Deg) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Deg _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) (do-template [ ] @@ -187,7 +204,7 @@ =x (&&/analyse-1 analyse x) _ (&type/check exo-type &type/Text) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) (let [decode-type (&/$AppT &type/Maybe )] @@ -196,7 +213,7 @@ =x (&&/analyse-1 analyse &type/Text x) _ (&type/check exo-type decode-type) _cursor &/cursor] - (return (&/|list (&&/|meta decode-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat @@ -210,7 +227,7 @@ (|do [:let [(&/$Nil) ?values] _ (&type/check exo-type ) _cursor &/cursor] - (return (&/|list (&&/|meta _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list) (&/|list))))))) ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] @@ -235,7 +252,7 @@ =x (&&/analyse-1 analyse x) _ (&type/check exo-type ) _cursor &/cursor] - (return (&/|list (&&/|meta _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] @@ -331,7 +348,10 @@ "last-index" (analyse-text-last-index analyse exo-type ?values) "size" (analyse-text-size analyse exo-type ?values) "replace-all" (analyse-text-replace-all analyse exo-type ?values) - "trim" (analyse-text-trim analyse exo-type ?values)) + "trim" (analyse-text-trim analyse exo-type ?values) + "char" (analyse-text-char analyse exo-type ?values) + "upper-case" (analyse-text-upper-case analyse exo-type ?values) + "lower-case" (analyse-text-lower-case analyse exo-type ?values)) "bit" (case proc diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index f449a7b3c..1a9fadf63 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -220,7 +220,6 @@ ("DictA" 1)) ;; [Exports] -(def ^:const name-field "_name") (def ^:const hash-field "_hash") (def ^:const value-field "_value") (def ^:const compiler-field "_compiler") diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 2e7d01d44..5bb97728f 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -71,8 +71,8 @@ (&o/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?fn ?args) - ;; (&o/$loop _register-offset _inits _body) - ;; (&&lux/compile-loop compile-expression _register-offset _inits _body) + (&o/$loop _register-offset _inits _body) + (&&lux/compile-loop compile-expression _register-offset _inits _body) (&o/$iter _register-offset ?args) (&&lux/compile-iter compile-expression _register-offset ?args) @@ -157,8 +157,7 @@ ?state) (&/$Left ?message) - (&/fail* ?message))))))) - ) + (&/fail* ?message)))))))) )) (let [!err! *err*] diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index f0ad777c6..39f943dda 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -91,21 +91,15 @@ =args (&/map% compile ?args)] (return (str =fn "(" (->> =args (&/|interpose ",") (&/fold str "")) ")")))) -;; (defn compile-loop [compile-expression register-offset inits body] -;; (|do [^MethodVisitor *writer* &/get-writer -;; :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) -;; inits)] -;; _ (&/map% (fn [idx+_init] -;; (|do [:let [[idx _init] idx+_init -;; idx+ (+ register-offset idx)] -;; _ (compile-expression nil _init) -;; :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] -;; (return nil))) -;; idxs+inits) -;; :let [$begin (new Label) -;; _ (.visitLabel *writer* $begin)]] -;; (compile-expression $begin body) -;; )) +(defn compile-loop [compile register-offset inits body] + (|do [:let [registers (&/|map #(->> % (+ register-offset) register-name) + (&/|range* 0 (dec (&/|length inits))))] + register-inits (&/map% compile inits) + =body (compile body)] + (return (str "(function _loop(" (->> registers (&/|interpose ",") (&/fold str "")) ") {" + =body + "})(" (->> register-inits (&/|interpose ",") (&/fold str "")) ")")) + )) (defn compile-iter [compile register-offset ?args] ;; Can only optimize if it is a simple expression. @@ -128,7 +122,7 @@ ;; ?args)] ;; (return updates)) (|do [=args (&/map% compile ?args)] - (return (str "_0(" + (return (str "_loop(" (->> =args (&/|interpose ",") (&/fold str "")) ")"))) ) @@ -304,7 +298,8 @@ "\"use strict\";" "var num_args = arguments.length;" "if(num_args == " arity ") {" - "var " (register-name 0) " = " function-name ";" + (str "var " (register-name 0) " = " function-name ";") + (str "var _loop = " function-name ";") func-args (str "while(true) {" "return " =body ";" diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 23454914e..ee381add4 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -310,16 +310,28 @@ =replace-with (compile ?replace-with)] (return (str "LuxRT.replaceAll(" (str =text "," =to-find "," =replace-with) ")")))) -(defn ^:private compile-text-trim [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - =text (compile ?text)] - (return (str "(" =text ").trim()")))) - (defn ^:private compile-text-size [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] =text (compile ?text)] (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) +(defn ^:private compile-text-char [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] + =text (compile ?text) + =idx (compile ?idx)] + (return (str "LuxRT.textChar(" (str =text "," =idx) ")")))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "(" =text ")." "()")))) + + ^:private compile-text-trim "trim" + ^:private compile-text-upper-case "toUpperCase" + ^:private compile-text-lower-case "toLowerCase" + ) + (defn ^:private compile-char-to-text [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] @@ -356,6 +368,9 @@ "size" (compile-text-size compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) + "char" (compile-text-char compile ?values special-args) + "upper-case" (compile-text-upper-case compile ?values special-args) + "lower-case" (compile-text-lower-case compile ?values special-args) ) ;; "bit" diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 1cb4a6150..eaac37a6a 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1264,6 +1264,17 @@ "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") + "textChar" (str "(function textChar(text,idx) {" + "var result = text.charAt(idx);" + (str "if(result === '') {" + (str "return " (make-some "result") ";") + "}" + "else {" + (str "return " const-none ";") + "}") + "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" + "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" + "})") }) (def LuxRT "LuxRT") diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj index e75e09f1b..cfbaf3810 100644 --- a/luxc/src/lux/compiler/jvm/cache.clj +++ b/luxc/src/lux/compiler/jvm/cache.clj @@ -19,7 +19,8 @@ (:import (java.io File BufferedOutputStream FileOutputStream) - (java.lang.reflect Field))) + (java.lang.reflect Field) + )) ;; [Utils] (defn ^:private read-file [^File file] @@ -30,12 +31,6 @@ (.read reader buffer 0 length) buffer))) -(defn ^:private clean-file [^File file] - "(-> File (,))" - (doseq [^File f (seq (.listFiles file)) - :when (not (.isDirectory f))] - (.delete f))) - (defn ^:private get-field [^String field-name ^Class class] "(-> Text Class Object)" (-> class ^Field (.getField field-name) (.get nil))) @@ -43,20 +38,24 @@ ;; [Resources] (def module-class-file (str &/module-class-name ".class")) +(defn ^:private delete-all-module-files [^File file] + (doseq [^File f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) + +(defn ^:private module-path [module] + (str @&&core/!output-dir + java.io.File/separator + (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) + (defn cached? [module] "(-> Text Bool)" - (.exists (new File (str @&&core/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator) - java.io.File/separator - module-class-file)))) + (.exists (new File (str (module-path module) java.io.File/separator &&core/lux-module-descriptor-name)))) (defn delete [module] "(-> Text (Lux Null))" (fn [state] - (do (clean-file (new File (str @&&core/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator)))) + (do (delete-all-module-files (new File (module-path module))) (return* state nil)))) (defn ^:private module-dirs @@ -85,30 +84,19 @@ corrected-dir-module))) (filter outdated?))] (doseq [^String f outdated-modules] - (clean-file (new File (str output-dir-prefix f)))) + (delete-all-module-files (new File (str output-dir-prefix f)))) nil)) -(defn ^:private install-all-classes-in-module [!classes module* ^String module-path] - (let [classes+bytecode (for [^File file (seq (.listFiles (File. module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)] - :when (not= module-class-file file-name)] - [(second (re-find #"^(.*)\.class$" file-name)) - (read-file file)]) - _ (doseq [[class-name bytecode] classes+bytecode] - (swap! !classes assoc (str module* "." class-name) bytecode))] - (map first classes+bytecode))) - -(defn ^:private assume-async-result - "(-> (Error Compiler) (Lux Null))" - [result] - (fn [_] - (|case result - (&/$Left error) - (&/$Left error) - - (&/$Right compiler) - (return* compiler nil)))) +(defn ^:private install-all-defs-in-module [!classes module* ^String module-path] + (let [file-name+content (for [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)] + :when (not= module-class-file file-name)] + [(second (re-find #"^(.*)\.class$" file-name)) + (read-file file)]) + _ (doseq [[file-name content] file-name+content] + (swap! !classes assoc (str module* "." file-name) content))] + (map first file-name+content))) (defn ^:private parse-tag-groups [^String tags-section] (if (= "" tags-section) @@ -225,7 +213,7 @@ class-name (str module* "." &/module-class-name) ^Class module-class (do (swap! !classes assoc class-name (read-file (new File (str module-path java.io.File/separator module-class-file)))) (&&/load-class! loader class-name)) - installed-classes (install-all-classes-in-module !classes module* module-path) + installed-classes (install-all-defs-in-module !classes module* module-path) valid-cache? (and (= module-hash (get-field &/hash-field module-class)) (= &/compiler-version (get-field &/compiler-field module-class))) drop-cache! (|do [_ (uninstall-cache module) @@ -240,7 +228,7 @@ (return cache-table*)) drop-cache!)))) -(def !pre-loaded-cache (atom nil)) +(def ^:private !pre-loaded-cache (atom nil)) (defn pre-load-cache! [source-dirs] (|do [:let [fs-cached-modules (enumerate-cached-modules!)] pre-loaded-modules (&/fold% (fn [cache-table module-name] diff --git a/luxc/src/lux/compiler/jvm/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj index 64760bbb6..12a2f83c7 100644 --- a/luxc/src/lux/compiler/jvm/lux.clj +++ b/luxc/src/lux/compiler/jvm/lux.clj @@ -283,8 +283,6 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version class-flags current-class nil &&/function-class (into-array String [])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) (-> (.visitField field-flags &/value-field datum-sig nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] @@ -353,8 +351,6 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version class-flags current-class nil "java/lang/Object" (into-array String [])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) (-> (.visitField field-flags &/value-field datum-sig nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index ce0d5f887..cad152f2b 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -178,15 +178,38 @@ (not (r.= number number))) ## [Values & Syntax] -(do-template [ ] +(do-template [ ] [(struct: #export (Codec Text Nat) (def: (encode value) - (_lux_proc ["jvm" ] [(nat-to-int value)])) + (loop [input value + output ""] + (let [digit (assume (_lux_proc ["text" "char"] [ (n.% input)])) + output' (_lux_proc ["text" "append"] [(_lux_proc ["char" "to-text"] [digit]) + output]) + input' (n./ input)] + (if (n.= +0 input') + output' + (recur input' output'))))) (def: (decode repr) - (_lux_proc ["jvm" "try"] - [(#;Right (int-to-nat (_lux_proc ["jvm" "invokestatic:java.lang.Long:parseUnsignedLong:java.lang.String,int"] [repr (_lux_proc ["jvm" "l2i"] [])]))) - (lambda [ex] (#;Left ))]))) + (let [input-size (_lux_proc ["text" "size"] [repr])] + (if (n.= +0 input-size) + (#;Left "Empty input.") + (let [input (_lux_proc ["text" "upper-case"] [repr])] + (loop [idx +0 + output +0] + (if (n.< input-size idx) + (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] + (case (_lux_proc ["text" "index"] + [input + (_lux_proc ["char" "to-text"] [digit])]) + #;None + (#;Left ) + + (#;Some index) + (recur (n.inc idx) + (|> output (n.* ) (n.* index))))) + (#;Right output)))))))) (macro: #export ( tokens state) {#;doc } @@ -202,13 +225,16 @@ _ (#;Left )))] - [Binary@Codec "invokestatic:java.lang.Long:toBinaryString:long" 2 bin "Invalid binary syntax." + [Binary@Codec +2 bin "Invalid binary syntax." + "01" (doc "Given syntax for a binary number, generates a Nat." (bin "11001001"))] - [Octal@Codec "invokestatic:java.lang.Long:toOctalString:long" 8 oct "Invalid octal syntax." + [Octal@Codec +8 oct "Invalid octal syntax." + "01234567" (doc "Given syntax for an octal number, generates a Nat." (oct "615243"))] - [Hex@Codec "invokestatic:java.lang.Long:toHexString:long" 16 hex "Invalid hexadecimal syntax." + [Hex@Codec +16 hex "Invalid hexadecimal syntax." + "0123456789ABCDEF" (doc "Given syntax for a hexadecimal number, generates a Nat." (hex "deadBEEF"))] ) -- cgit v1.3.1 From 71d7ff61aa914e153965a4ef6a7ae72b4fb54581 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 17 Feb 2017 22:40:06 -0400 Subject: - Added support for the new common procedures to the JVM backend. - Fixed some bugs. --- luxc/src/lux/compiler/jvm/proc/common.clj | 105 ++++++++++++++++++++++++------ luxc/src/lux/compiler/jvm/rt.clj | 102 ++++++++++++++++++++++------- stdlib/source/lux/data/number.lux | 4 +- stdlib/source/lux/data/text.lux | 30 ++++----- 4 files changed, 177 insertions(+), 64 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index c48403e52..01048fd98 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -265,6 +265,16 @@ ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double ) +(defn ^:private compile-real-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "doubleToRawLongBits" "(D)J") + &&/wrap-long)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -328,8 +338,18 @@ ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + ^:private compile-int-min-value (.visitLdcInsn Long/MIN_VALUE) &&/wrap-long + ^:private compile-int-max-value (.visitLdcInsn Long/MAX_VALUE) &&/wrap-long + ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long + + ^:private compile-real-min-value (.visitLdcInsn (* -1.0 Double/MAX_VALUE)) &&/wrap-double + ^:private compile-real-max-value (.visitLdcInsn Double/MAX_VALUE) &&/wrap-double + + ^:private compile-real-not-a-number (.visitLdcInsn Double/NaN) &&/wrap-double + ^:private compile-real-positive-infinity (.visitLdcInsn Double/POSITIVE_INFINITY) &&/wrap-double + ^:private compile-real-negative-infinity (.visitLdcInsn Double/NEGATIVE_INFINITY) &&/wrap-double ) (do-template [ ] @@ -356,23 +376,34 @@ ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" ) -(defn ^:private compile-int-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;"))]] - (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + + (.visitMethodInsn Opcodes/INVOKESTATIC "toString" ))]] + (return nil))) + + ^:private compile-int-encode "java/lang/Long" "(J)Ljava/lang/String;" &&/unwrap-long + ^:private compile-real-encode "java/lang/Double" "(D)Ljava/lang/String;" &&/unwrap-double + ) -(defn ^:private compile-real-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-double - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]] - (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)[Ljava/lang/Object;"))]] + (return nil))) + + ^:private compile-int-decode "decode_int" + ^:private compile-real-decode "decode_real" + ) (do-template [ ] (defn [compile ?values special-args] @@ -565,13 +596,32 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]] (return nil))) -(defn ^:private compile-text-trim [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "()Ljava/lang/String;"))]] + (return nil))) + + ^:private compile-text-trim "trim" + ^:private compile-text-upper-case "toUpperCase" + ^:private compile-text-lower-case "toLowerCase" + ) + +(defn ^:private compile-text-char [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?text) :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "trim" "()Ljava/lang/String;"))]] + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;"))]] (return nil))) (defn compile-io-log [compile ?values special-args] @@ -620,6 +670,9 @@ "size" (compile-text-size compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) + "upper-case" (compile-text-upper-case compile ?values special-args) + "lower-case" (compile-text-lower-case compile ?values special-args) + "char" (compile-text-char compile ?values special-args) ) "bit" @@ -683,9 +736,12 @@ "%" (compile-int-rem compile ?values special-args) "=" (compile-int-eq compile ?values special-args) "<" (compile-int-lt compile ?values special-args) + "max-value" (compile-int-max-value compile ?values special-args) + "min-value" (compile-int-min-value compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) "to-real" (compile-int-to-real compile ?values special-args) "encode" (compile-int-encode compile ?values special-args) + "decode" (compile-int-decode compile ?values special-args) ) "real" @@ -697,9 +753,16 @@ "%" (compile-real-rem compile ?values special-args) "=" (compile-real-eq compile ?values special-args) "<" (compile-real-lt compile ?values special-args) - "encode" (compile-real-encode compile ?values special-args) + "hash" (compile-real-hash compile ?values special-args) + "max-value" (compile-real-max-value compile ?values special-args) + "min-value" (compile-real-min-value compile ?values special-args) + "not-a-number" (compile-real-not-a-number compile ?values special-args) + "positive-infinity" (compile-real-positive-infinity compile ?values special-args) + "negative-infinity" (compile-real-negative-infinity compile ?values special-args) "to-int" (compile-real-to-int compile ?values special-args) "to-deg" (compile-real-to-deg compile ?values special-args) + "encode" (compile-real-encode compile ?values special-args) + "decode" (compile-real-decode compile ?values special-args) ) "char" diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 303d9ae0a..7f193a1cd 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -1160,6 +1160,34 @@ (.visitEnd)))] nil))) +(do-template [ ] + (defn [^ClassWriter =class] + (do (let [$from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "(Ljava/lang/String;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC ) + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + nil)) + + ^:private compile-LuxRT-int-methods "decode_int" "java/lang/Long" "parseLong" "(Ljava/lang/String;)J" &&/wrap-long + ^:private compile-LuxRT-real-methods "decode_real" "java/lang/Double" "parseDouble" "(Ljava/lang/String;)D" &&/wrap-double + ) + (defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) (.visitCode) @@ -1205,31 +1233,53 @@ nil)) (defn ^:private compile-LuxRT-text-methods [^ClassWriter =class] - (|do [:let [_ (let [$from (new Label) - $to (new Label) - $handler (new Label) - $end (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException") - (.visitLabel $from) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $to) - (.visitLabel $handler) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))]] - (return nil))) + (do (let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + (let [$from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") + &&/wrap-char + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + nil)) (def compile-LuxRT-class (|do [_ (return nil) @@ -1291,7 +1341,9 @@ (compile-LuxRT-pm-methods) (compile-LuxRT-adt-methods) (compile-LuxRT-nat-methods) + (compile-LuxRT-int-methods) (compile-LuxRT-deg-methods) + (compile-LuxRT-real-methods) (compile-LuxRT-text-methods))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index cad152f2b..0c52653af 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -201,14 +201,14 @@ (if (n.< input-size idx) (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] (case (_lux_proc ["text" "index"] - [input + [ (_lux_proc ["char" "to-text"] [digit])]) #;None (#;Left ) (#;Some index) (recur (n.inc idx) - (|> output (n.* ) (n.* index))))) + (|> output (n.* ) (n.+ index))))) (#;Right output)))))))) (macro: #export ( tokens state) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 9375d6876..bc350cc3a 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -12,40 +12,38 @@ ## [Functions] (def: #export (size x) (-> Text Nat) - (int-to-nat (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))) + [(_lux_proc ["text" "size"] [x])]) -(def: #export (nth idx x) +(def: #export (nth idx input) (-> Nat Text (Maybe Char)) - (if (n.< (size x) idx) - (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:charAt:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int idx)])])) - #;None)) + (_lux_proc ["text" "char"] [input idx])) (def: #export (contains? sub text) (-> Text Text Bool) (_lux_proc ["jvm" "invokevirtual:java.lang.String:contains:java.lang.CharSequence"] [text sub])) (do-template [ ] - [(def: #export ( x) + [(def: #export ( input) (-> Text Text) - (_lux_proc ["jvm" ] [x]))] - [lower-case "invokevirtual:java.lang.String:toLowerCase:"] - [upper-case "invokevirtual:java.lang.String:toUpperCase:"] - [trim "invokevirtual:java.lang.String:trim:"] + (_lux_proc ["text" ] [input]))] + [lower-case "lower-case"] + [upper-case "upper-case"] + [trim "trim"] ) -(def: #export (clip from to x) +(def: #export (clip from to input) (-> Nat Nat Text (Maybe Text)) (if (and (n.< to from) - (n.<= (size x) to)) + (n.<= (size input) to)) (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] - [x + [input (_lux_proc ["jvm" "l2i"] [(nat-to-int from)]) (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])])) #;None)) -(def: #export (clip' from x) +(def: #export (clip' from input) (-> Nat Text (Maybe Text)) - (clip from (size x) x)) + (clip from (size input) input)) (def: #export (replace pattern value template) (-> Text Text Text Text) @@ -120,7 +118,7 @@ ## [Structures] (struct: #export _ (Eq Text) (def: (= test subject) - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [subject test]))) + (_lux_proc ["text" "="] [subject test]))) (struct: #export _ (ord;Ord Text) (def: eq Eq) -- cgit v1.3.1 From 38a81332a1cefb51ff89ee96a16bb4a65cee21bc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Feb 2017 18:01:05 -0400 Subject: - Implemented a variety of new procedures for text, chars, math and arrays. --- luxc/src/lux/analyser/proc/common.clj | 140 +++++++++++++++++--- luxc/src/lux/compiler/js/proc/common.clj | 150 ++++++++++++++++------ luxc/src/lux/compiler/js/rt.clj | 36 +++++- luxc/src/lux/compiler/jvm/proc/common.clj | 206 +++++++++++++++++++++++++++--- stdlib/source/lux.lux | 18 ++- stdlib/source/lux/data/char.lux | 50 ++++---- stdlib/source/lux/data/number.lux | 3 +- stdlib/source/lux/data/text.lux | 84 ++++++------ stdlib/source/lux/math.lux | 62 ++++----- stdlib/test/test/lux/data/text.lux | 8 +- 10 files changed, 564 insertions(+), 193 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index bec0855e1..9ab01801f 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -28,25 +28,38 @@ (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-lt ["text" "<"] &type/Text &type/Bool ^:private analyse-text-append ["text" "append"] &type/Text &type/Text ) -(do-template [ ] +(do-template [ ] (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Cons start (&/$Nil)))) ?values] =text (&&/analyse-1 analyse &type/Text text) =part (&&/analyse-1 analyse &type/Text part) - _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) + =start (&&/analyse-1 analyse &type/Nat start) + _ (&type/check exo-type ) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["text" ]) - (&/|list =text =part) + (&/|list =text =part =start) (&/|list))))))) - ^:private analyse-text-index "index" - ^:private analyse-text-last-index "last-index" + ^:private analyse-text-index "index" (&/$AppT &type/Maybe &type/Nat) + ^:private analyse-text-last-index "last-index" (&/$AppT &type/Maybe &type/Nat) ) +(defn ^:private analyse-text-contains? [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =part (&&/analyse-1 analyse &type/Text part) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "contains?"]) + (&/|list =text =part) + (&/|list))))))) + (defn ^:private analyse-text-clip [analyse exo-type ?values] (|do [:let [(&/$Cons text (&/$Cons from (&/$Cons to (&/$Nil)))) ?values] =text (&&/analyse-1 analyse &type/Text text) @@ -71,15 +84,20 @@ (&/|list =text =to-find =replace-with) (&/|list))))))) -(defn ^:private analyse-text-size [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Nil)) ?values] - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["text" "size"]) - (&/|list =text) - (&/|list))))))) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" ]) + (&/|list =text) + (&/|list))))))) + + ^:private analyse-text-size "size" + ^:private analyse-text-hash "hash" + ) (do-template [ ] (defn [analyse exo-type ?values] @@ -187,6 +205,9 @@ ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool + + ^:private analyse-char-eq ["char" "="] &type/Char &type/Bool + ^:private analyse-char-lt ["char" "<"] &type/Char &type/Bool ) (defn ^:private analyse-deg-scale [analyse exo-type ?values] @@ -328,6 +349,61 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["array" "size"]) (&/|list =array) (&/|list))))))))) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list) (&/|list))))))) + + ^:private analyse-math-e "e" + ^:private analyse-math-pi "pi" + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Real ?input) + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list =input) (&/|list))))))) + + ^:private analyse-math-cos "cos" + ^:private analyse-math-sin "sin" + ^:private analyse-math-tan "tan" + ^:private analyse-math-acos "acos" + ^:private analyse-math-asin "asin" + ^:private analyse-math-atan "atan" + ^:private analyse-math-cosh "cosh" + ^:private analyse-math-sinh "sinh" + ^:private analyse-math-tanh "tanh" + ^:private analyse-math-exp "exp" + ^:private analyse-math-log "log" + ^:private analyse-math-root2 "root2" + ^:private analyse-math-root3 "root3" + ^:private analyse-math-degrees "degrees" + ^:private analyse-math-radians "radians" + ^:private analyse-math-ceil "ceil" + ^:private analyse-math-floor "floor" + ^:private analyse-math-round "round" + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (&&/analyse-1 analyse &type/Real ?input) + =param (&&/analyse-1 analyse &type/Real ?param) + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list =input =param) (&/|list))))))) + + ^:private analyse-math-atan2 "atan2" + ^:private analyse-math-pow "pow" + ) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" @@ -342,16 +418,20 @@ "text" (case proc "=" (analyse-text-eq analyse exo-type ?values) + "<" (analyse-text-lt analyse exo-type ?values) "append" (analyse-text-append analyse exo-type ?values) "clip" (analyse-text-clip analyse exo-type ?values) "index" (analyse-text-index analyse exo-type ?values) "last-index" (analyse-text-last-index analyse exo-type ?values) "size" (analyse-text-size analyse exo-type ?values) + "hash" (analyse-text-hash analyse exo-type ?values) "replace-all" (analyse-text-replace-all analyse exo-type ?values) "trim" (analyse-text-trim analyse exo-type ?values) "char" (analyse-text-char analyse exo-type ?values) "upper-case" (analyse-text-upper-case analyse exo-type ?values) - "lower-case" (analyse-text-lower-case analyse exo-type ?values)) + "lower-case" (analyse-text-lower-case analyse exo-type ?values) + "contains?" (analyse-text-contains? analyse exo-type ?values) + ) "bit" (case proc @@ -445,9 +525,37 @@ "char" (case proc + "=" (analyse-char-eq analyse exo-type ?values) + "<" (analyse-char-lt analyse exo-type ?values) "to-text" (analyse-char-to-text analyse exo-type ?values) "to-nat" (analyse-char-to-nat analyse exo-type ?values) ) + + "math" + (case proc + "e" (analyse-math-e analyse exo-type ?values) + "pi" (analyse-math-pi analyse exo-type ?values) + "cos" (analyse-math-cos analyse exo-type ?values) + "sin" (analyse-math-sin analyse exo-type ?values) + "tan" (analyse-math-tan analyse exo-type ?values) + "acos" (analyse-math-acos analyse exo-type ?values) + "asin" (analyse-math-asin analyse exo-type ?values) + "atan" (analyse-math-atan analyse exo-type ?values) + "cosh" (analyse-math-cosh analyse exo-type ?values) + "sinh" (analyse-math-sinh analyse exo-type ?values) + "tanh" (analyse-math-tanh analyse exo-type ?values) + "exp" (analyse-math-exp analyse exo-type ?values) + "log" (analyse-math-log analyse exo-type ?values) + "root2" (analyse-math-root2 analyse exo-type ?values) + "root3" (analyse-math-root3 analyse exo-type ?values) + "degrees" (analyse-math-degrees analyse exo-type ?values) + "radians" (analyse-math-radians analyse exo-type ?values) + "ceil" (analyse-math-ceil analyse exo-type ?values) + "floor" (analyse-math-floor analyse exo-type ?values) + "round" (analyse-math-round analyse exo-type ?values) + "atan2" (analyse-math-atan2 analyse exo-type ?values) + "pow" (analyse-math-pow analyse exo-type ?values) + ) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index ee381add4..11fb9fd95 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -69,6 +69,43 @@ =right (compile ?right)] (return (str "(" =left " === " =right ")")))) +(defn ^:private compile-array-new [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] + =length (compile ?length)] + (return (str "new Array(" (str "LuxRT.toNumberI64(" =length ")") ")")))) + +(defn ^:private compile-array-get [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx)] + (return (str "LuxRT.arrayGet(" =array "," =idx ")")))) + +(defn ^:private compile-array-put [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx) + =elem (compile ?elem)] + (return (str "LuxRT.arrayPut(" =array "," =idx "," =elem ")")))) + +(defn ^:private compile-array-remove [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx)] + (return (str "LuxRT.arrayRemove(" =array "," =idx ")")))) + +(defn ^:private compile-array-size [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array)] + (return (str =array ".length")))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -134,10 +171,14 @@ ^:private compile-deg-decode "decodeD64" ^:private compile-real-decode "decodeReal" - - ^:private compile-real-hash "hashReal" ) +(defn ^:private compile-real-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str &&rt/LuxRT ".textHash(''+" =x ")")) + )) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Nil) ?values]] @@ -222,28 +263,6 @@ ;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long ;; ) -;; (let [widen (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/I2L))) -;; shrink (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/L2I) -;; (.visitInsn Opcodes/I2C)))] -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink -;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen -;; )) - (do-template [] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] @@ -273,11 +292,27 @@ =x (compile ?x)] (return (str "LuxRT.realToDeg(" =x ")")))) -(defn ^:private compile-text-eq [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x "===" =y ")")))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x =y ")")))) + + ^:private compile-text-eq "===" + ^:private compile-text-lt "<" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x ".C" " " " " =y ".C" ")")))) + + ^:private compile-char-eq "===" + ^:private compile-char-lt "<" + ) (defn ^:private compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -287,15 +322,26 @@ (do-template [ ] (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] =text (compile ?text) - =part (compile ?part)] - (return (str "LuxRT" "." "(" =text "," =part ")")))) + =part (compile ?part) + =start (compile ?start)] + (return (str "LuxRT" "." "(" =text "," =part "," =start ")")))) ^:private compile-text-last-index "lastIndex" ^:private compile-text-index "index" ) +(defn ^:private compile-text-contains? [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + =text (compile ?text) + =part (compile ?part)] + (return (str "(" (str (str "(" =text ")") + ".indexOf" + (str "(" =part ")")) + " !== " "-1" + ")")))) + (defn ^:private compile-text-clip [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] =text (compile ?text) @@ -315,6 +361,11 @@ =text (compile ?text)] (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) +(defn ^:private compile-text-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "LuxRT.textHash(" =text ")")))) + (defn ^:private compile-text-char [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] =text (compile ?text) @@ -337,6 +388,20 @@ =x (compile ?x)] (return (str "(" =x ").C")))) +(defn ^:private compile-char-to-nat [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.fromNumberI64(" (str "(" =x ").C" ".charCodeAt(0)") ")")))) + +(defn ^:private compile-nat-to-char [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "{C:" + (str "String.fromCharCode(" + (str "LuxRT.toNumberI64(" =x ")") + ")") + "}")))) + (defn ^:private compile-lux-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] @@ -361,16 +426,19 @@ "text" (case proc-name "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) "clip" (compile-text-clip compile ?values special-args) "index" (compile-text-index compile ?values special-args) "last-index" (compile-text-last-index compile ?values special-args) "size" (compile-text-size compile ?values special-args) + "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) "char" (compile-text-char compile ?values special-args) "upper-case" (compile-text-upper-case compile ?values special-args) "lower-case" (compile-text-lower-case compile ?values special-args) + "contains?" (compile-text-contains? compile ?values special-args) ) ;; "bit" @@ -383,9 +451,13 @@ ;; "shift-right" (compile-bit-shift-right compile ?values special-args) ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) - ;; "array" - ;; (case proc-name - ;; "get" (compile-array-get compile ?values special-args)) + "array" + (case proc-name + "new" (compile-array-new compile ?values special-args) + "get" (compile-array-get compile ?values special-args) + "put" (compile-array-put compile ?values special-args) + "remove" (compile-array-remove compile ?values special-args) + "size" (compile-array-size compile ?values special-args)) "nat" (case proc-name @@ -401,7 +473,7 @@ "max-value" (compile-nat-max-value compile ?values special-args) "min-value" (compile-nat-min-value compile ?values special-args) "to-int" (compile-nat-to-int compile ?values special-args) - ;; "to-char" (compile-nat-to-char compile ?values special-args) + "to-char" (compile-nat-to-char compile ?values special-args) ) "int" @@ -461,8 +533,10 @@ "char" (case proc-name - "to-text" (compile-char-to-text compile ?values special-args) - ;; "to-nat" (compile-char-to-nat compile ?values special-args) + "=" (compile-char-eq compile ?values special-args) + "<" (compile-char-lt compile ?values special-args) + "to-text" (compile-char-to-text compile ?values special-args) + "to-nat" (compile-char-to-nat compile ?values special-args) ) ;; else diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index eaac37a6a..cc00e2908 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1233,8 +1233,8 @@ (str "[1,''," value "]")) (def ^:private text-methods - {"index" (str "(function index(text,part) {" - "var idx = text.indexOf(part);" + {"index" (str "(function index(text,part,start) {" + "var idx = text.indexOf(part,LuxRT.toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") @@ -1242,8 +1242,8 @@ (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") "}")) "})") - "lastIndex" (str "(function lastIndex(text,part) {" - "var idx = text.lastIndexOf(part);" + "lastIndex" (str "(function lastIndex(text,part,start) {" + "var idx = text.lastIndexOf(part,LuxRT.toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") @@ -1275,6 +1275,33 @@ "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") + "textHash" (str "(function(input) {" + "var hash = 0;" + (str "for(var i = 0; i < input.length; i++) {" + "hash = (((hash << 5) - hash) + input.charCodeAt(i)) & 0xFFFFFFFF;" + "}") + "return LuxRT.fromNumberI64(hash);" + "})") + }) + +(def ^:private array-methods + {"arrayGet" (str "(function arrayGet(arr,idx) {" + "var temp = arr[LuxRT.toNumberI64(idx)];" + (str "if(temp !== undefined) {" + (str "return " (make-some "temp") ";") + "}" + "else {" + (str "return " const-none ";") + "}") + "})") + "arrayPut" (str "(function arrayPut(arr,idx,val) {" + "arr[LuxRT.toNumberI64(idx)] = val;" + "return arr;" + "})") + "arrayRemove" (str "(function arrayRemove(arr,idx) {" + "delete arr[LuxRT.toNumberI64(idx)];" + "return arr;" + "})") }) (def LuxRT "LuxRT") @@ -1285,6 +1312,7 @@ i64-methods n64-methods text-methods + array-methods io-methods) (map (fn [[key val]] (str key ":" val))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 01048fd98..63e7b9e76 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -265,6 +265,31 @@ ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double ) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-char-eq Opcodes/IF_ICMPEQ &&/unwrap-char + ^:private compile-char-lt Opcodes/IF_ICMPLT &&/unwrap-char + ) + (defn ^:private compile-real-hash [compile ?values special-args] (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer @@ -496,7 +521,7 @@ ^:private compile-int-to-real &&/unwrap-long Opcodes/L2D &&/wrap-double ) -(defn compile-text-eq [compile ?values special-args] +(defn ^:private compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?x) @@ -506,6 +531,28 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-text-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)I") + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + (defn compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer @@ -539,7 +586,7 @@ (do-template [ ] (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?text) :let [_ (doto *writer* @@ -547,8 +594,12 @@ _ (compile ?part) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?start) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;)I"))] + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;I)I"))] :let [$not-found (new Label) $end (new Label) _ (doto *writer* @@ -569,16 +620,21 @@ ^:private compile-text-last-index "lastIndexOf" ) -(defn ^:private compile-text-size [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "()I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + + ^:private compile-text-size "java/lang/String" "length" + ^:private compile-text-hash "java/lang/Object" "hashCode" + ) (defn ^:private compile-text-replace-all [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?pattern (&/$Cons ?replacement (&/$Nil)))) ?values] @@ -596,6 +652,20 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]] (return nil))) +(defn ^:private compile-text-contains? [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?sub (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?sub) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "contains" "(Ljava/lang/CharSequence;)Z") + &&/wrap-boolean)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] @@ -624,7 +694,7 @@ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;"))]] (return nil))) -(defn compile-io-log [compile ?values special-args] +(defn ^:private compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -636,7 +706,7 @@ (.visitLdcInsn &/unit-tag))]] (return nil))) -(defn compile-io-error [compile ?values special-args] +(defn ^:private compile-io-error [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -649,6 +719,79 @@ (.visitInsn Opcodes/ATHROW))]] (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Math" "D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-e "E" + ^:private compile-math-pi "PI" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "(D)D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-cos "cos" + ^:private compile-math-sin "sin" + ^:private compile-math-tan "tan" + ^:private compile-math-acos "acos" + ^:private compile-math-asin "asin" + ^:private compile-math-atan "atan" + ^:private compile-math-cosh "cosh" + ^:private compile-math-sinh "sinh" + ^:private compile-math-tanh "tanh" + ^:private compile-math-exp "exp" + ^:private compile-math-log "log" + ^:private compile-math-root2 "sqrt" + ^:private compile-math-root3 "cbrt" + ^:private compile-math-degrees "toDegrees" + ^:private compile-math-radians "toRadians" + ^:private compile-math-ceil "ceil" + ^:private compile-math-floor "floor" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double)] + _ (compile ?param) + :let [_ (doto *writer* + &&/unwrap-double)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "(DD)D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-atan2 "atan2" + ^:private compile-math-pow "pow" + ) + +(defn ^:private compile-math-round [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "round" "(D)J") + (.visitInsn Opcodes/L2D) + &&/wrap-double)]] + (return nil))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category "lux" @@ -663,16 +806,19 @@ "text" (case proc-name "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) "clip" (compile-text-clip compile ?values special-args) "index" (compile-text-index compile ?values special-args) "last-index" (compile-text-last-index compile ?values special-args) "size" (compile-text-size compile ?values special-args) + "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) + "char" (compile-text-char compile ?values special-args) "upper-case" (compile-text-upper-case compile ?values special-args) "lower-case" (compile-text-lower-case compile ?values special-args) - "char" (compile-text-char compile ?values special-args) + "contains?" (compile-text-contains? compile ?values special-args) ) "bit" @@ -767,9 +913,37 @@ "char" (case proc-name + "=" (compile-char-eq compile ?values special-args) + "<" (compile-char-lt compile ?values special-args) "to-nat" (compile-char-to-nat compile ?values special-args) "to-text" (compile-char-to-text compile ?values special-args) ) + + "math" + (case proc-name + "e" (compile-math-e compile ?values special-args) + "pi" (compile-math-pi compile ?values special-args) + "cos" (compile-math-cos compile ?values special-args) + "sin" (compile-math-sin compile ?values special-args) + "tan" (compile-math-tan compile ?values special-args) + "acos" (compile-math-acos compile ?values special-args) + "asin" (compile-math-asin compile ?values special-args) + "atan" (compile-math-atan compile ?values special-args) + "cosh" (compile-math-cosh compile ?values special-args) + "sinh" (compile-math-sinh compile ?values special-args) + "tanh" (compile-math-tanh compile ?values special-args) + "exp" (compile-math-exp compile ?values special-args) + "log" (compile-math-log compile ?values special-args) + "root2" (compile-math-root2 compile ?values special-args) + "root3" (compile-math-root3 compile ?values special-args) + "degrees" (compile-math-degrees compile ?values special-args) + "radians" (compile-math-radians compile ?values special-args) + "ceil" (compile-math-ceil compile ?values special-args) + "floor" (compile-math-floor compile ?values special-args) + "round" (compile-math-round compile ?values special-args) + "atan2" (compile-math-atan2 compile ?values special-args) + "pow" (compile-math-pow compile ?values special-args) + ) ;; else (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [proc-category proc-name])))) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index c6018398b..01064b829 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2100,6 +2100,7 @@ (-> Char Text) (let' [as-text (_lux_case x #"\t" "\\t" + #"\v" "\\v" #"\b" "\\b" #"\n" "\\n" #"\r" "\\r" @@ -3222,13 +3223,14 @@ (#Some y) (#Some y)))) -(def: (last-index-of part text) - (-> Text Text (Maybe Nat)) - (_lux_proc ["text" "last-index"] [text part])) +(do-template [ ] + [(def: ( part text) + (-> Text Text (Maybe Nat)) + (_lux_proc ["text" ] [text part ]))] -(def: (index-of part text) - (-> Text Text (Maybe Nat)) - (_lux_proc ["text" "index"] [text part])) + [index-of "index" +0] + [last-index-of "last-index" (_lux_proc ["text" "size"] [text])] + ) (def: (clip1 from text) (-> Nat Text (Maybe Text)) @@ -3954,7 +3956,8 @@ [_ (#SymbolS "" m-name)] (do Monad [m-name (clean-module m-name)] - (wrap (list [m-name #None {#refer-defs #All #refer-open (list)}]))) + (wrap (list [m-name #None {#refer-defs #All + #refer-open (list)}]))) (^ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) (do Monad @@ -4863,6 +4866,7 @@ (-> Text Text) (let [escaped (|> original (replace "\t" "\\t") + (replace "\v" "\\v") (replace "\b" "\\b") (replace "\n" "\\n") (replace "\r" "\\r") diff --git a/stdlib/source/lux/data/char.lux b/stdlib/source/lux/data/char.lux index 28877ae34..0db90898e 100644 --- a/stdlib/source/lux/data/char.lux +++ b/stdlib/source/lux/data/char.lux @@ -9,48 +9,43 @@ ## [Structures] (struct: #export _ (Eq Char) (def: (= x y) - (_lux_proc ["jvm" "ceq"] [x y]))) + (_lux_proc ["char" "="] [x y]))) (struct: #export _ (Hash Char) (def: eq Eq) - (def: hash - (|>. [] - (_lux_proc ["jvm" "c2i"]) - [] - (_lux_proc ["jvm" "i2l"]) - int-to-nat))) + (def: (hash input) + (_lux_proc ["char" "to-nat"] [input]))) (struct: #export _ (ord;Ord Char) (def: eq Eq) - (do-template [ ] - [(def: ( test subject) - (_lux_proc ["jvm" ] [subject test]))] + (def: (< test subject) + (_lux_proc ["char" "<"] [subject test])) - [< "clt"] - [> "cgt"] - ) + (def: (<= test subject) + (or (_lux_proc ["char" "="] [subject test]) + (_lux_proc ["char" "<"] [subject test]))) - (do-template [ ] - [(def: ( test subject) - (or (_lux_proc ["jvm" "ceq"] [subject test]) - (_lux_proc ["jvm" ] [subject test])))] + (def: (> test subject) + (_lux_proc ["char" "<"] [test subject])) - [<= "clt"] - [>= "cgt"] - )) + (def: (>= test subject) + (or (_lux_proc ["char" "="] [test subject]) + (_lux_proc ["char" "<"] [test subject]))) + ) (struct: #export _ (Codec Text Char) (def: (encode x) (let [as-text (case x #"\t" "\\t" + #"\v" "\\v" #"\b" "\\b" #"\n" "\\n" #"\r" "\\r" #"\f" "\\f" #"\"" "\\\"" #"\\" "\\\\" - _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + _ (_lux_proc ["char" "to-text"] [x]))] ($_ Text/append "#\"" as-text "\""))) (def: (decode y) @@ -70,13 +65,13 @@ [(#;Some #"\\") (#;Some char)] (case char #"t" (#;Right #"\t") + #"v" (#;Right #"\v") #"b" (#;Right #"\b") #"n" (#;Right #"\n") #"r" (#;Right #"\r") #"f" (#;Right #"\f") #"\"" (#;Right #"\"") #"\\" (#;Right #"\\") - #"t" (#;Right #"\t") _ (#;Left (Text/append "Wrong syntax for Char: " y))) _ @@ -84,14 +79,19 @@ (#;Left (Text/append "Wrong syntax for Char: " y)))))) ## [Values] -(def: #export (space? x) +(def: #export (space? char) {#;doc "Checks whether the character is white-space."} (-> Char Bool) - (_lux_proc ["jvm" "invokestatic:java.lang.Character:isWhitespace:char"] [x])) + (case char + (^or #"\t" #"\v" #" " #"\n" #"\r" #"\f") + true + + _ + false)) (def: #export (as-text x) (-> Char Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) + (_lux_proc ["char" "to-text"] [x])) (def: #export (char x) (-> Nat Char) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 0c52653af..1a29fc5b6 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -202,7 +202,8 @@ (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] (case (_lux_proc ["text" "index"] [ - (_lux_proc ["char" "to-text"] [digit])]) + (_lux_proc ["char" "to-text"] [digit]) + +0]) #;None (#;Left ) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index bc350cc3a..4869d9e82 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -20,7 +20,7 @@ (def: #export (contains? sub text) (-> Text Text Bool) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:contains:java.lang.CharSequence"] [text sub])) + (_lux_proc ["text" "contains?"] [text sub])) (do-template [ ] [(def: #export ( input) @@ -33,13 +33,7 @@ (def: #export (clip from to input) (-> Nat Nat Text (Maybe Text)) - (if (and (n.< to from) - (n.<= (size input) to)) - (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] - [input - (_lux_proc ["jvm" "l2i"] [(nat-to-int from)]) - (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])])) - #;None)) + (_lux_proc ["text" "clip"] [input from to])) (def: #export (clip' from input) (-> Nat Text (Maybe Text)) @@ -47,30 +41,24 @@ (def: #export (replace pattern value template) (-> Text Text Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) + (_lux_proc ["text" "replace-all"] [template pattern value])) -(do-template [ ] - [(def: #export ( pattern x) +(do-template [ ] + [(def: #export ( pattern input) (-> Text Text (Maybe Nat)) - (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" ] [x pattern])]) - -1 #;None - idx (#;Some (int-to-nat idx)))) + (_lux_proc ["text" ] [input pattern ])) - (def: #export ( pattern from x) + (def: #export ( pattern from input) (-> Text Nat Text (Maybe Nat)) - (if (n.< (size x) from) - (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" ] [x pattern (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])])]) - -1 #;None - idx (#;Some (int-to-nat idx))) - #;None))] - - [index-of "invokevirtual:java.lang.String:indexOf:java.lang.String" index-of' "invokevirtual:java.lang.String:indexOf:java.lang.String,int"] - [last-index-of "invokevirtual:java.lang.String:lastIndexOf:java.lang.String" last-index-of' "invokevirtual:java.lang.String:lastIndexOf:java.lang.String,int"] + (_lux_proc ["text" ] [input pattern from]))] + + [index-of index-of' "index" +0] + [last-index-of last-index-of' "last-index" (size input)] ) (def: #export (starts-with? prefix x) (-> Text Text Bool) - (case (index-of prefix x) + (case (index-of' prefix x) (#;Some +0) true @@ -79,7 +67,7 @@ (def: #export (ends-with? postfix x) (-> Text Text Bool) - (case (last-index-of postfix x) + (case (last-index-of' postfix x) (#;Some n) (n.= (size x) (n.+ (size postfix) n)) @@ -89,16 +77,17 @@ (def: #export (split at x) (-> Nat Text (Maybe [Text Text])) - (if (n.<= (size x) at) - (let [pre (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [x (_lux_proc ["jvm" "l2i"] [0]) (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])]) - post (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])] - (#;Some [pre post])) + (case [(clip +0 at x) (clip' at x)] + [(#;Some pre) (#;Some post)] + (#;Some [pre post]) + + _ #;None)) (def: #export (split-with token sample) (-> Text Text (Maybe [Text Text])) (do Monad - [index (index-of token sample) + [index (index-of' token sample) [pre post'] (split index sample) [_ post] (split (size token) post')] (wrap [pre post]))) @@ -123,20 +112,25 @@ (struct: #export _ (ord;Ord Text) (def: eq Eq) - (do-template [ ] - [(def: ( test subject) - ( 0 - (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:compareTo:java.lang.String"] [subject test])])))] + (def: (< test subject) + (_lux_proc ["text" "<"] [subject test])) + + (def: (<= test subject) + (or (_lux_proc ["text" "<"] [subject test]) + (_lux_proc ["text" "="] [subject test]))) - [< i.<] - [<= i.<=] - [> i.>] - [>= i.>=])) + (def: (> test subject) + (_lux_proc ["text" "<"] [test subject])) + + (def: (>= test subject) + (or (_lux_proc ["text" "<"] [test subject]) + (_lux_proc ["text" "="] [test subject]))) + ) (struct: #export _ (Monoid Text) (def: unit "") - (def: (append x y) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y]))) + (def: (append left right) + (_lux_proc ["text" "append"] [left right]))) (open Monoid) @@ -145,6 +139,7 @@ (let [escaped (|> original (replace "\\" "\\\\") (replace "\t" "\\t") + (replace "\v" "\\v") (replace "\b" "\\b") (replace "\n" "\\n") (replace "\r" "\\r") @@ -161,6 +156,7 @@ (|> input' (replace "\\\\" "\\") (replace "\\t" "\t") + (replace "\\v" "\v") (replace "\\b" "\b") (replace "\\n" "\n") (replace "\\r" "\r") @@ -175,12 +171,8 @@ (struct: #export _ (Hash Text) (def: eq Eq) - (def: hash - (|>. [] - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"]) - [] - (_lux_proc ["jvm" "i2l"]) - int-to-nat))) + (def: (hash input) + (_lux_proc ["text" "hash"] [input]))) (def: #export concat (-> (List Text) Text) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index e87bb1b1b..6f41b3e9b 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -5,7 +5,6 @@ [number "Int/" Number] [product] text/format) - host [compiler] (macro ["s" syntax #+ syntax: Syntax "s/" Functor] [ast]))) @@ -14,10 +13,10 @@ (do-template [ ] [(def: #export Real - (_lux_proc ["jvm" ] []))] + (_lux_proc ["math" ] []))] - [e "getstatic:java.lang.Math:E"] - [pi "getstatic:java.lang.Math:PI"] + [e "e"] + [pi "pi"] ) (def: #export tau @@ -26,52 +25,43 @@ 6.28318530717958647692) (do-template [ ] - [(def: #export ( n) + [(def: #export ( input) (-> Real Real) - (_lux_proc ["jvm" ] [n]))] + (_lux_proc ["math" ] [input]))] - [cos "invokestatic:java.lang.Math:cos:double"] - [sin "invokestatic:java.lang.Math:sin:double"] - [tan "invokestatic:java.lang.Math:tan:double"] + [cos "cos"] + [sin "sin"] + [tan "tan"] - [acos "invokestatic:java.lang.Math:acos:double"] - [asin "invokestatic:java.lang.Math:asin:double"] - [atan "invokestatic:java.lang.Math:atan:double"] + [acos "acos"] + [asin "asin"] + [atan "atan"] - [cosh "invokestatic:java.lang.Math:cosh:double"] - [sinh "invokestatic:java.lang.Math:sinh:double"] - [tanh "invokestatic:java.lang.Math:tanh:double"] + [cosh "cosh"] + [sinh "sinh"] + [tanh "tanh"] - [exp "invokestatic:java.lang.Math:exp:double"] - [log "invokestatic:java.lang.Math:log:double"] + [exp "exp"] + [log "log"] - [root2 "invokestatic:java.lang.Math:sqrt:double"] - [root3 "invokestatic:java.lang.Math:cbrt:double"] + [root2 "root2"] + [root3 "root3"] - [degrees "invokestatic:java.lang.Math:toDegrees:double"] - [radians "invokestatic:java.lang.Math:toRadians:double"] - ) + [degrees "degrees"] + [radians "radians"] -(do-template [ ] - [(def: #export ( n) - (-> Real Real) - (_lux_proc ["jvm" ] [n]))] - - [ceil "invokestatic:java.lang.Math:ceil:double"] - [floor "invokestatic:java.lang.Math:floor:double"] + [ceil "ceil"] + [floor "floor"] + [round "round"] ) -(def: #export (round n) - (-> Real Real) - (int-to-real (_lux_proc ["jvm" "invokestatic:java.lang.Math:round:double"] [n]))) - (do-template [ ] [(def: #export ( param subject) (-> Real Real Real) - (_lux_proc ["jvm" ] [subject param]))] + (_lux_proc ["math" ] [subject param]))] - [atan2 "invokestatic:java.lang.Math:atan2:double,double"] - [pow "invokestatic:java.lang.Math:pow:double,double"] + [atan2 "atan2"] + [pow "pow"] ) (def: #export (log' base input) diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux index 8ddd27a7c..883ff0b2b 100644 --- a/stdlib/test/test/lux/data/text.lux +++ b/stdlib/test/test/lux/data/text.lux @@ -32,10 +32,10 @@ (&;nth idx) (case> (^=> (#;Some char) [(char;as-text char) char'] - [[(&;index-of char' sample) - (&;last-index-of char' sample) - (&;index-of' char' idx sample) - (&;last-index-of' char' idx sample)] + [[(&;index-of' char' sample) + (&;last-index-of' char' sample) + (&;index-of char' idx sample) + (&;last-index-of char' idx sample)] [(#;Some io) (#;Some lio) (#;Some io') (#;Some lio')]]) (and (n.<= idx io) -- cgit v1.3.1 From 5fb0985b7a33ccfc6c53d65ce00a643f9d8d20ee Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 23 Feb 2017 18:12:42 -0400 Subject: - Re-designed atomic operations as common procedures. - Implemented atomic operations for the JVM. - Basic Lux types no longer rely on JVM classes. --- luxc/src/lux/analyser/proc/common.clj | 39 +++++++++++++++++ luxc/src/lux/compiler/jvm/proc/common.clj | 69 +++++++++++++++++++++++------ luxc/src/lux/type.clj | 25 ++++++----- luxc/src/lux/type/host.clj | 72 +++++++++++++++---------------- stdlib/source/lux.lux | 10 ++--- stdlib/source/lux/concurrency/atom.lux | 20 +++------ stdlib/source/lux/concurrency/stm.lux | 1 - 7 files changed, 156 insertions(+), 80 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 9ab01801f..51e0f3528 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -404,6 +404,38 @@ ^:private analyse-math-pow "pow" ) +(defn ^:private analyse-atom-new [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] + =init (&&/analyse-1 analyse $var ?init) + _ (&type/check exo-type (&type/Atom $var)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["atom" "new"]) (&/|list =init) (&/|list))))))))) + +(defn ^:private analyse-atom-get [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values] + =atom (&&/analyse-1 analyse (&type/Atom $var) ?atom) + _ (&type/check exo-type $var) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["atom" "get"]) (&/|list =atom) (&/|list))))))))) + +(defn ^:private analyse-atom-compare-and-swap [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values] + =atom (&&/analyse-1 analyse (&type/Atom $var) ?atom) + =old (&&/analyse-1 analyse $var ?old) + =new (&&/analyse-1 analyse $var ?new) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["atom" "compare-and-swap"]) (&/|list =atom =old =new) (&/|list))))))))) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" @@ -556,6 +588,13 @@ "atan2" (analyse-math-atan2 analyse exo-type ?values) "pow" (analyse-math-pow analyse exo-type ?values) ) + + "atom" + (case proc + "new" (analyse-atom-new analyse exo-type ?values) + "get" (analyse-atom-get analyse exo-type ?values) + "compare-and-swap" (analyse-atom-compare-and-swap analyse exo-type ?values) + ) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 63e7b9e76..dd59a41f0 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -792,19 +792,53 @@ &&/wrap-double)]] (return nil))) -(defn compile-proc [compile proc-category proc-name ?values special-args] - (case proc-category +(defn ^:private compile-atom-new [compile ?values special-args] + (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW "java/util/concurrent/atomic/AtomicReference") + (.visitInsn Opcodes/DUP))] + _ (compile ?init) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/util/concurrent/atomic/AtomicReference" "" "(Ljava/lang/Object;)V"))]] + (return nil))) + +(defn ^:private compile-atom-get [compile ?values special-args] + (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?atom) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/util/concurrent/atomic/AtomicReference"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/atomic/AtomicReference" "get" "()Ljava/lang/Object;"))]] + (return nil))) + +(defn ^:private compile-atom-compare-and-swap [compile ?values special-args] + (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?atom) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/util/concurrent/atomic/AtomicReference"))] + _ (compile ?old) + _ (compile ?new) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/atomic/AtomicReference" "compareAndSet" "(Ljava/lang/Object;Ljava/lang/Object;)Z") + &&/wrap-boolean)]] + (return nil))) + +(defn compile-proc [compile category proc ?values special-args] + (case category "lux" - (case proc-name + (case proc "is" (compile-lux-is compile ?values special-args)) "io" - (case proc-name + (case proc "log" (compile-io-log compile ?values special-args) "error" (compile-io-error compile ?values special-args)) "text" - (case proc-name + (case proc "=" (compile-text-eq compile ?values special-args) "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) @@ -822,7 +856,7 @@ ) "bit" - (case proc-name + (case proc "count" (compile-bit-count compile ?values special-args) "and" (compile-bit-and compile ?values special-args) "or" (compile-bit-or compile ?values special-args) @@ -832,7 +866,7 @@ "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) "array" - (case proc-name + (case proc "new" (compile-array-new compile ?values special-args) "get" (compile-array-get compile ?values special-args) "put" (compile-array-put compile ?values special-args) @@ -840,7 +874,7 @@ "size" (compile-array-size compile ?values special-args)) "nat" - (case proc-name + (case proc "+" (compile-nat-add compile ?values special-args) "-" (compile-nat-sub compile ?values special-args) "*" (compile-nat-mul compile ?values special-args) @@ -857,7 +891,7 @@ ) "deg" - (case proc-name + (case proc "+" (compile-deg-add compile ?values special-args) "-" (compile-deg-sub compile ?values special-args) "*" (compile-deg-mul compile ?values special-args) @@ -874,7 +908,7 @@ ) "int" - (case proc-name + (case proc "+" (compile-int-add compile ?values special-args) "-" (compile-int-sub compile ?values special-args) "*" (compile-int-mul compile ?values special-args) @@ -891,7 +925,7 @@ ) "real" - (case proc-name + (case proc "+" (compile-real-add compile ?values special-args) "-" (compile-real-sub compile ?values special-args) "*" (compile-real-mul compile ?values special-args) @@ -912,7 +946,7 @@ ) "char" - (case proc-name + (case proc "=" (compile-char-eq compile ?values special-args) "<" (compile-char-lt compile ?values special-args) "to-nat" (compile-char-to-nat compile ?values special-args) @@ -920,7 +954,7 @@ ) "math" - (case proc-name + (case proc "e" (compile-math-e compile ?values special-args) "pi" (compile-math-pi compile ?values special-args) "cos" (compile-math-cos compile ?values special-args) @@ -944,6 +978,13 @@ "atan2" (compile-math-atan2 compile ?values special-args) "pow" (compile-math-pow compile ?values special-args) ) + + "atom" + (case proc + "new" (compile-atom-new compile ?values special-args) + "get" (compile-atom-get compile ?values special-args) + "compare-and-swap" (compile-atom-compare-and-swap compile ?values special-args) + ) ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [proc-category proc-name])))) + (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index ad185e284..94c4e2ae7 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -23,17 +23,22 @@ (def empty-env &/$Nil) -(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))) +(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "#Bool" &/$Nil))) (def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil))) (def Deg (&/$NamedT (&/T ["lux" "Deg"]) (&/$HostT &&host/deg-data-tag &/$Nil))) -(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil))) -(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil))) -(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil))) -(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil))) +(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "#Int" &/$Nil))) +(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "#Real" &/$Nil))) +(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "#Char" &/$Nil))) +(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "#Text" &/$Nil))) (def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text))) -(defn Array [elem-type] - (&/$HostT "#Array" (&/|list elem-type))) +(do-template [ ] + (defn [elem-type] + (&/$HostT (&/|list elem-type))) + + Array "#Array" + Atom "#Atom" + ) (def Bottom (&/$NamedT (&/T ["lux" "Bottom"]) @@ -205,7 +210,7 @@ (&/$None) (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) - ts)) + ts)) state) nil)) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) @@ -215,7 +220,7 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) - ts)) + ts)) state) nil) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) @@ -225,7 +230,7 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %) - ts)) + ts)) state) nil) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) diff --git a/luxc/src/lux/type/host.clj b/luxc/src/lux/type/host.clj index b255f97c5..40a3373f0 100644 --- a/luxc/src/lux/type/host.clj +++ b/luxc/src/lux/type/host.clj @@ -250,45 +250,43 @@ (defn primitive-type? [type-name] (contains? primitive-types type-name))) +(def ^:private lux-jvm-type-combos + #{#{"java.lang.Boolean" "#Bool"} + #{"java.lang.Long" "#Int"} + #{"java.lang.Double" "#Real"} + #{"java.lang.Character" "#Char"} + #{"java.lang.String" "#Text"}}) + +(defn ^:private lux-type? [^String class-name] + (.startsWith class-name "#")) + (defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual] - (|let [[e!name e!params] expected - [a!name a!params] actual] - ;; TODO: Delete first branch. It smells like a hack... - (try (cond (or (= "java.lang.Object" e!name) - (and (= nat-data-tag e!name) - (= nat-data-tag a!name)) - (and (= deg-data-tag e!name) - (= deg-data-tag a!name)) - (and (= null-data-tag e!name) - (= null-data-tag a!name)) - (and (not (primitive-type? e!name)) - (= null-data-tag a!name))) - (return fixpoints) - - (or (and (= array-data-tag e!name) - (not= array-data-tag a!name)) - (= nat-data-tag e!name) (= nat-data-tag a!name) - (= deg-data-tag e!name) (= deg-data-tag a!name) - (= null-data-tag e!name) (= null-data-tag a!name)) - (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)) - - :else - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] - (cond (= e!name a!name) - (if (= (&/|length e!params) (&/|length a!params)) - (|do [_ (&/map2% check e!params a!params)] - (return fixpoints)) - (&/fail-with-loc (str "[Type Error] Amounts of generic parameters don't match: " e!name "(" (&/|length e!params) ")" " vs " a!name "(" (&/|length a!params) ")"))) - - (not invariant??) - (|do [actual* (->super-type existential class-loader e!name a!name a!params)] - (check (&/$HostT e!name e!params) actual*)) - - :else - (&/fail-with-loc (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) + (|let [[^String e!name e!params] expected + [^String a!name a!params] actual] + (try (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (cond (= e!name a!name) + (if (= (&/|length e!params) (&/|length a!params)) + (|do [_ (&/map2% check e!params a!params)] + (return fixpoints)) + (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))) + + (or (lux-type? e!name) + (lux-type? a!name)) + (if (or (= "java.lang.Object" e!name) + (contains? lux-jvm-type-combos #{e!name a!name}) + (and (not (primitive-type? e!name)) + (= null-data-tag a!name))) + (return fixpoints) + (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))) + + (not invariant??) + (|do [actual* (->super-type existential class-loader e!name a!name a!params)] + (check (&/$HostT e!name e!params) actual*)) + + :else + (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)))) (catch Exception e - (prn 'check-host-types e [e!name a!name]) (throw e))))) (defn gtype->gclass [gtype] diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 01064b829..7ae8c2847 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1,7 +1,7 @@ ## Basic types (_lux_def Bool (+12 ["lux" "Bool"] - (+0 "java.lang.Boolean" (+0))) + (+0 "#Bool" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill boolean values.")] @@ -19,7 +19,7 @@ (_lux_def Int (+12 ["lux" "Int"] - (+0 "java.lang.Long" (+0))) + (+0 "#Int" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill integer numbers.")] @@ -27,7 +27,7 @@ (_lux_def Real (+12 ["lux" "Real"] - (+0 "java.lang.Double" (+0))) + (+0 "#Real" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill floating-point numbers.")] @@ -45,7 +45,7 @@ (_lux_def Char (+12 ["lux" "Char"] - (+0 "java.lang.Character" (+0))) + (+0 "#Char" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill character values.")] @@ -53,7 +53,7 @@ (_lux_def Text (+12 ["lux" "Text"] - (+0 "java.lang.String" (+0))) + (+0 "#Text" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill string values.")] diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux index 09dd642ed..f2ec8b46c 100644 --- a/stdlib/source/lux/concurrency/atom.lux +++ b/stdlib/source/lux/concurrency/atom.lux @@ -1,31 +1,25 @@ (;module: lux - (lux [io #- run] - host)) - -(jvm-import (java.util.concurrent.atomic.AtomicReference V) - (new [V]) - (compareAndSet [V V] boolean) - (get [] V)) + (lux [io #- run])) (type: #export (Atom a) {#;doc "Atomic references that are safe to mutate concurrently."} - (AtomicReference a)) + (#;HostT "#Atom" (#;Cons a #;Nil))) (def: #export (atom value) (All [a] (-> a (Atom a))) - (AtomicReference.new [value])) + (_lux_proc ["atom" "new"] [value])) (def: #export (get atom) (All [a] (-> (Atom a) (IO a))) - (io (AtomicReference.get [] atom))) + (io (_lux_proc ["atom" "get"] [atom]))) (def: #export (compare-and-swap current new atom) {#;doc "Only mutates an atom if you can present it's current value. That guarantees that atom wasn't updated since you last read from it."} (All [a] (-> a a (Atom a) (IO Bool))) - (io (AtomicReference.compareAndSet [current new] atom))) + (io (_lux_proc ["atom" "compare-and-swap"] [atom current new]))) (def: #export (update f atom) {#;doc "Updates an atom by applying a function to its current value. @@ -34,8 +28,8 @@ The retries will be done with the new values of the atom, as they show up."} (All [a] (-> (-> a a) (Atom a) (IO Unit))) - (io (let [old (AtomicReference.get [] atom)] - (if (AtomicReference.compareAndSet [old (f old)] atom) + (io (let [old (_lux_proc ["atom" "get"] [atom])] + (if (_lux_proc ["atom" "compare-and-swap"] [atom old (f old)]) [] (io;run (update f atom)))))) diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index 36eb6854e..c1c3153dd 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -12,7 +12,6 @@ maybe [number "Nat/" Codec] text/format) - host [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]) -- cgit v1.3.1 From 8ff8934813562f28f79cc08014947eb282256e6a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 23 Feb 2017 19:46:22 -0400 Subject: - Re-designed (and implemented) the primitives for running processes/threads as Lux procedures. --- luxc/src/lux/analyser/proc/common.clj | 31 +++++++++ luxc/src/lux/compiler/jvm.clj | 3 +- luxc/src/lux/compiler/jvm/proc/common.clj | 39 +++++++++++ luxc/src/lux/compiler/jvm/rt.clj | 106 +++++++++++++++++++++++++++++- luxc/src/lux/type.clj | 5 ++ stdlib/source/lux/concurrency/promise.lux | 47 ++----------- 6 files changed, 186 insertions(+), 45 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 51e0f3528..7703aa8a6 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -436,6 +436,30 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["atom" "compare-and-swap"]) (&/|list =atom =old =new) (&/|list))))))))) +(defn ^:private analyse-process-concurrency-level [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["process" "concurrency-level"]) (&/|list) (&/|list))))))) + +(defn ^:private analyse-process-future [analyse exo-type ?values] + (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values] + =procedure (&&/analyse-1 analyse (&/$AppT &type/IO &type/Top) ?procedure) + _ (&type/check exo-type &/$UnitT) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["process" "future"]) (&/|list =procedure) (&/|list))))))) + +(defn ^:private analyse-process-schedule [analyse exo-type ?values] + (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values] + =milliseconds (&&/analyse-1 analyse &type/Nat ?milliseconds) + =procedure (&&/analyse-1 analyse (&/$AppT &type/IO &type/Top) ?procedure) + _ (&type/check exo-type &/$UnitT) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["process" "schedule"]) (&/|list =milliseconds =procedure) (&/|list))))))) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" @@ -595,6 +619,13 @@ "get" (analyse-atom-get analyse exo-type ?values) "compare-and-swap" (analyse-atom-compare-and-swap analyse exo-type ?values) ) + + "process" + (case proc + "concurrency-level" (analyse-process-concurrency-level analyse exo-type ?values) + "future" (analyse-process-future analyse exo-type ?values) + "schedule" (analyse-process-schedule analyse exo-type ?values) + ) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 5cc3c1f79..7fd764e56 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -192,7 +192,8 @@ (.visitSource file-name nil))] _ (if (= "lux" name) (|do [_ &&rt/compile-Function-class - _ &&rt/compile-LuxRT-class] + _ &&rt/compile-LuxRT-class + _ &&rt/compile-LuxRunnable-class] (return nil)) (return nil))] (fn [state] diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index dd59a41f0..0afcdc9e0 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -826,6 +826,38 @@ &&/wrap-boolean)]] (return nil))) +(defn ^:private compile-process-concurrency-level [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "concurrency_level" "I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-process-future [compile ?values special-args] + (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?procedure) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "lux/Function"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "future" "(Llux/Function;)Ljava/lang/Object;"))]] + (return nil))) + +(defn ^:private compile-process-schedule [compile ?values special-args] + (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?milliseconds) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?procedure) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "lux/Function"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "schedule" "(JLlux/Function;)Ljava/lang/Object;"))]] + (return nil))) + (defn compile-proc [compile category proc ?values special-args] (case category "lux" @@ -985,6 +1017,13 @@ "get" (compile-atom-get compile ?values special-args) "compare-and-swap" (compile-atom-compare-and-swap compile ?values special-args) ) + + "process" + (case proc + "concurrency-level" (compile-process-concurrency-level compile ?values special-args) + "future" (compile-process-future compile ?values special-args) + "schedule" (compile-process-schedule compile ?values special-args) + ) ;; else (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 7f193a1cd..0f86325f2 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -25,6 +25,7 @@ (def init-method "") ;; [Resources] +;; Functions (def compile-Function-class (|do [_ (return nil) :let [super-class "java/lang/Object" @@ -65,6 +66,37 @@ (&&/save-class! (second (string/split &&/function-class #"/")) (.toByteArray (doto =class .visitEnd))))) +;; Custom Runnable +(def compile-LuxRunnable-class + (|do [_ (return nil) + :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + "lux/LuxRunnable" nil "java/lang/Object" (into-array String ["java/lang/Runnable"]))) + _ (doto (.visitField =class Opcodes/ACC_PUBLIC "procedure" "Llux/Function;" nil nil) + (.visitEnd)) + _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(Llux/Function;)V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" init-method "()V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD "lux/LuxRunnable" "procedure" "Llux/Function;") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "run" "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD "lux/LuxRunnable" "procedure" "Llux/Function;") + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1)) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (&&/save-class! "LuxRunnable" + (.toByteArray (doto =class .visitEnd))))) + +;; Runtime infrastructure (defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] (|let [_ (let [$begin (new Label) $not-rec (new Label)] @@ -1281,6 +1313,77 @@ (.visitEnd))) nil)) +(defn ^:private compile-LuxRT-process-methods [^ClassWriter =class] + (do (doto (.visitField =class + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) + "concurrency_level" "I" nil nil) + (.visitEnd)) + (doto (.visitField =class + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) + "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;" nil nil) + (.visitEnd)) + (doto (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (.visitCode) + ;; concurrency_level + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Runtime" "getRuntime" "()Ljava/lang/Runtime;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Runtime" "availableProcessors" "()I") + (.visitFieldInsn Opcodes/PUTSTATIC "lux/LuxRT" "concurrency_level" "I") + ;; executor + (.visitTypeInsn Opcodes/NEW "java/util/concurrent/ScheduledThreadPoolExecutor") + (.visitInsn Opcodes/DUP) + (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "concurrency_level" "I") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/util/concurrent/ScheduledThreadPoolExecutor" "" "(I)V") + (.visitFieldInsn Opcodes/PUTSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;") + ;; DONE + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "future" "(Llux/Function;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW "java/lang/Thread") + (.visitInsn Opcodes/DUP) + (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable") + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "" "(Llux/Function;)V") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Thread" "" "(Ljava/lang/Runnable;)V") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Thread" "start" "()V") + (.visitLdcInsn &/unit-tag) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (let [$immediately (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "schedule" "(JLlux/Function;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFEQ $immediately) + ;; Schedule for later + (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;") + (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable") + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "" "(Llux/Function;)V") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitFieldInsn Opcodes/GETSTATIC "java/util/concurrent/TimeUnit" "MILLISECONDS" "Ljava/util/concurrent/TimeUnit;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/ScheduledThreadPoolExecutor" "schedule" "(Ljava/lang/Runnable;JLjava/util/concurrent/TimeUnit;)Ljava/util/concurrent/ScheduledFuture;") + (.visitLdcInsn &/unit-tag) + (.visitInsn Opcodes/ARETURN) + ;; Run immediately + (.visitLabel $immediately) + (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;") + (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable") + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "" "(Llux/Function;)V") + (.visitMethodInsn Opcodes/INVOKEINTERFACE "java/util/concurrent/Executor" "execute" "(Ljava/lang/Runnable;)V") + (.visitLdcInsn &/unit-tag) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + nil)) + (def compile-LuxRT-class (|do [_ (return nil) :let [full-name &&/lux-utils-class @@ -1344,6 +1447,7 @@ (compile-LuxRT-int-methods) (compile-LuxRT-deg-methods) (compile-LuxRT-real-methods) - (compile-LuxRT-text-methods))]] + (compile-LuxRT-text-methods) + (compile-LuxRT-process-methods))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index 94c4e2ae7..854472c94 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -45,6 +45,11 @@ (&/$UnivQ empty-env (&/$BoundT 1)))) +(def Top + (&/$NamedT (&/T ["lux" "Top"]) + (&/$ExQ empty-env + (&/$BoundT 1)))) + (def IO (&/$NamedT (&/T ["lux/codata" "IO"]) (&/$UnivQ empty-env diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 3c10e785d..ef7efd923 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -12,47 +12,11 @@ [compiler] (macro ["s" syntax #+ syntax: Syntax]) (concurrency [atom #+ Atom atom]) - host )) -(jvm-import java.lang.Runtime - (#static getRuntime [] Runtime) - (availableProcessors [] int)) - -(jvm-import java.lang.Runnable) - -(jvm-import java.lang.Thread - (new [Runnable]) - (start [] void)) - -(jvm-import java.util.concurrent.Executor - (execute [Runnable] void)) - -(jvm-import java.util.concurrent.TimeUnit - (#enum MILLISECONDS)) - -(jvm-import (java.util.concurrent.ScheduledFuture a)) - -(jvm-import java.util.concurrent.ScheduledThreadPoolExecutor - (new [int]) - (schedule [Runnable long TimeUnit] (ScheduledFuture Object))) - (def: #export concurrency-level Nat - (|> (Runtime.getRuntime []) - (Runtime.availableProcessors []) - int-to-nat)) - -(def: executor - ScheduledThreadPoolExecutor - (ScheduledThreadPoolExecutor.new [(nat-to-int concurrency-level)])) - -(syntax: (runnable expr) - (wrap (list (`' (object [java.lang.Runnable] - [] - (java.lang.Runnable (run) void - (exec (~ expr) - []))))))) + (_lux_proc ["process" "concurrency-level"] [])) (type: (Promise-State a) {#value (Maybe a) @@ -218,18 +182,15 @@ {#;doc "Runs an I/O computation on its own process and returns an Promise that will eventually host its result."} (All [a] (-> (IO a) (Promise a))) (let [!out (promise ($ +0))] - (exec (Thread.start [] (Thread.new [(runnable (io;run (resolve (io;run computation) - !out)))])) + (exec (_lux_proc ["process" "future"] [(io (io;run (resolve (io;run computation) + !out)))]) !out))) (def: #export (wait time) {#;doc "Returns a Promise that will be resolved after the specified amount of milliseconds."} (-> Nat (Promise Unit)) (let [!out (promise Unit)] - (exec (ScheduledThreadPoolExecutor.schedule [(runnable (io;run (resolve [] !out))) - (nat-to-int time) - TimeUnit.MILLISECONDS] - executor) + (exec (_lux_proc ["process" "schedule"] [time (resolve [] !out)]) !out))) (def: #export (time-out time promise) -- cgit v1.3.1 From cbeafbafc0ab02d8c8335ccc106a90545d562985 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 25 Feb 2017 19:57:30 -0400 Subject: - Exiting the program and getting the current time (in milliseconds) is now done through procedures. --- luxc/src/lux/analyser/proc/common.clj | 19 +++++++++++++++---- luxc/src/lux/compiler/js/proc/common.clj | 8 ++++---- luxc/src/lux/compiler/jvm/proc/common.clj | 23 ++++++++++++++++++++++- stdlib/source/lux/test.lux | 15 ++++++++------- 4 files changed, 49 insertions(+), 16 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 7703aa8a6..c91074676 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -291,10 +291,18 @@ ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ^:private analyse-lux-log &type/Text &/$UnitT ["io" "log"] - ^:private analyse-lux-error &type/Text &type/Bottom ["io" "error"] + ^:private analyse-io-log &type/Text &/$UnitT ["io" "log"] + ^:private analyse-io-error &type/Text &type/Bottom ["io" "error"] + ^:private analyse-io-exit &type/Int &type/Bottom ["io" "exit"] ) +(defn ^:private analyse-io-current-time [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Int) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["io" "current-time"]) (&/|list) (&/|list))))))) + (defn ^:private analyse-array-new [analyse exo-type ?values] (|do [:let [(&/$Cons length (&/$Nil)) ?values] =length (&&/analyse-1 analyse &type/Nat length) @@ -468,8 +476,11 @@ "io" (case proc - "log" (analyse-lux-log analyse exo-type ?values) - "error" (analyse-lux-error analyse exo-type ?values)) + "log" (analyse-io-log analyse exo-type ?values) + "error" (analyse-io-error analyse exo-type ?values) + "exit" (analyse-io-exit analyse exo-type ?values) + "current-time" (analyse-io-current-time analyse exo-type ?values) + ) "text" (case proc diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 11fb9fd95..284139248 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -402,12 +402,12 @@ ")") "}")))) -(defn ^:private compile-lux-log [compile ?values special-args] +(defn ^:private compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] (return (str "LuxRT.log(" =message ")")))) -(defn ^:private compile-lux-error [compile ?values special-args] +(defn ^:private compile-io-error [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] (return (str "LuxRT.error(" =message ")")))) @@ -420,8 +420,8 @@ "io" (case proc-name - "log" (compile-lux-log compile ?values special-args) - "error" (compile-lux-error compile ?values special-args)) + "log" (compile-io-log compile ?values special-args) + "error" (compile-io-error compile ?values special-args)) "text" (case proc-name diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 0afcdc9e0..6a952e6d3 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -719,6 +719,24 @@ (.visitInsn Opcodes/ATHROW))]] (return nil))) +(defn ^:private compile-io-exit [compile ?values special-args] + (|do [:let [(&/$Cons ?code (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?code) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "exit" "(I)V"))]] + (return nil))) + +(defn ^:private compile-io-current-time [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "currentTimeMillis" "()J") + &&/wrap-long)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Nil) ?values] @@ -867,7 +885,10 @@ "io" (case proc "log" (compile-io-log compile ?values special-args) - "error" (compile-io-error compile ?values special-args)) + "error" (compile-io-error compile ?values special-args) + "exit" (compile-io-exit compile ?values special-args) + "current-time" (compile-io-current-time compile ?values special-args) + ) "text" (case proc diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 82fcabed9..bab513cc4 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -17,12 +17,13 @@ [host #- try])) ## [Host] -(jvm-import java.lang.System - (#static exit [int] #io void) - (#static currentTimeMillis [] #io long)) +(def: now + (IO Int) + (io (_lux_proc ["io" "current-time"] []))) (do-template [ ] - [(def: #hidden (IO Unit) (System.exit ))] + [(def: #hidden (IO Bottom) + (io (_lux_proc ["io" "exit"] [])))] [exit 0] [die 1] @@ -51,9 +52,9 @@ [#let [test-runs (List/map (: (-> [Text (IO Test) Text] (Promise Nat)) (lambda [[module test description]] (do @ - [#let [pre (io;run (System.currentTimeMillis []))] + [#let [pre (io;run now)] outcome (io;run test) - #let [post (io;run (System.currentTimeMillis [])) + #let [post (io;run now) description+ (:: text;Codec encode description)]] (case outcome (#;Left error) @@ -107,7 +108,7 @@ (def: #hidden (repeat ?seed times random-test) (-> (Maybe Nat) Nat (R;Random Test) Test) - (repeat' (default (int-to-nat (io;run (System.currentTimeMillis []))) + (repeat' (default (int-to-nat (io;run now)) ?seed) (case ?seed #;None times -- cgit v1.3.1 From d8bba8c477525a0e70eab4f289e043cfe352bd62 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 14:48:52 -0400 Subject: - Implemented math procedures for JS. - Degree<->radian conversions are no longer math procedures. --- luxc/src/lux/analyser/proc/common.clj | 4 -- luxc/src/lux/compiler/js/proc/common.clj | 68 +++++++++++++++++++++++++++++++ luxc/src/lux/compiler/jvm/proc/common.clj | 4 -- stdlib/source/lux/math.lux | 3 -- stdlib/test/test/lux/math.lux | 3 -- 5 files changed, 68 insertions(+), 14 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index c91074676..050877ed5 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -391,8 +391,6 @@ ^:private analyse-math-log "log" ^:private analyse-math-root2 "root2" ^:private analyse-math-root3 "root3" - ^:private analyse-math-degrees "degrees" - ^:private analyse-math-radians "radians" ^:private analyse-math-ceil "ceil" ^:private analyse-math-floor "floor" ^:private analyse-math-round "round" @@ -615,8 +613,6 @@ "log" (analyse-math-log analyse exo-type ?values) "root2" (analyse-math-root2 analyse exo-type ?values) "root3" (analyse-math-root3 analyse exo-type ?values) - "degrees" (analyse-math-degrees analyse exo-type ?values) - "radians" (analyse-math-radians analyse exo-type ?values) "ceil" (analyse-math-ceil analyse exo-type ?values) "floor" (analyse-math-floor analyse exo-type ?values) "round" (analyse-math-round analyse exo-type ?values) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 60ade9300..942f24c79 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -439,6 +439,50 @@ (str "LuxRT.toNumberI64(" =milliseconds ")") ")")))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + (return (str "Math." )))) + + ^:private compile-math-e "E" + ^:private compile-math-pi "PI" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + =input (compile ?input)] + (return (str "Math." "(" =input ")")))) + + ^:private compile-math-cos "cos" + ^:private compile-math-sin "sin" + ^:private compile-math-tan "tan" + ^:private compile-math-acos "acos" + ^:private compile-math-asin "asin" + ^:private compile-math-atan "atan" + ^:private compile-math-cosh "cosh" + ^:private compile-math-sinh "sinh" + ^:private compile-math-tanh "tanh" + ^:private compile-math-exp "exp" + ^:private compile-math-log "log" + ^:private compile-math-root2 "sqrt" + ^:private compile-math-root3 "cbrt" + ^:private compile-math-ceil "ceil" + ^:private compile-math-floor "floor" + ^:private compile-math-round "round" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (compile ?input) + =param (compile ?param)] + (return (str "Math." "(" =input "," =param ")")))) + + ^:private compile-math-atan2 "atan2" + ^:private compile-math-pow "pow" + ) + (defn compile-proc [compile category proc ?values special-args] (case category "lux" @@ -566,6 +610,30 @@ "to-nat" (compile-char-to-nat compile ?values special-args) ) + "math" + (case proc + "e" (compile-math-e compile ?values special-args) + "pi" (compile-math-pi compile ?values special-args) + "cos" (compile-math-cos compile ?values special-args) + "sin" (compile-math-sin compile ?values special-args) + "tan" (compile-math-tan compile ?values special-args) + "acos" (compile-math-acos compile ?values special-args) + "asin" (compile-math-asin compile ?values special-args) + "atan" (compile-math-atan compile ?values special-args) + "cosh" (compile-math-cosh compile ?values special-args) + "sinh" (compile-math-sinh compile ?values special-args) + "tanh" (compile-math-tanh compile ?values special-args) + "exp" (compile-math-exp compile ?values special-args) + "log" (compile-math-log compile ?values special-args) + "root2" (compile-math-root2 compile ?values special-args) + "root3" (compile-math-root3 compile ?values special-args) + "ceil" (compile-math-ceil compile ?values special-args) + "floor" (compile-math-floor compile ?values special-args) + "round" (compile-math-round compile ?values special-args) + "atan2" (compile-math-atan2 compile ?values special-args) + "pow" (compile-math-pow compile ?values special-args) + ) + "atom" (case proc "new" (compile-atom-new compile ?values special-args) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 6a952e6d3..b7e80dd2e 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -774,8 +774,6 @@ ^:private compile-math-log "log" ^:private compile-math-root2 "sqrt" ^:private compile-math-root3 "cbrt" - ^:private compile-math-degrees "toDegrees" - ^:private compile-math-radians "toRadians" ^:private compile-math-ceil "ceil" ^:private compile-math-floor "floor" ) @@ -1023,8 +1021,6 @@ "log" (compile-math-log compile ?values special-args) "root2" (compile-math-root2 compile ?values special-args) "root3" (compile-math-root3 compile ?values special-args) - "degrees" (compile-math-degrees compile ?values special-args) - "radians" (compile-math-radians compile ?values special-args) "ceil" (compile-math-ceil compile ?values special-args) "floor" (compile-math-floor compile ?values special-args) "round" (compile-math-round compile ?values special-args) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 6f41b3e9b..c49e82969 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -47,9 +47,6 @@ [root2 "root2"] [root3 "root3"] - [degrees "degrees"] - [radians "radians"] - [ceil "ceil"] [floor "floor"] [round "round"] diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux index 18cb1545c..769a6f889 100644 --- a/stdlib/test/test/lux/math.lux +++ b/stdlib/test/test/lux/math.lux @@ -35,9 +35,6 @@ ## (assert "Tangent and arc-tangent are inverse functions." ## (|> angle &;tan &;atan (within? margin angle))) - -## (assert "Can freely go between degrees and radians." -## (|> angle &;degrees &;radians (within? margin angle))) ## )) (test: "Roots" -- cgit v1.3.1 From 79c10caf4c7e370dc53c4c60c57cc16ccec48773 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 19:36:21 -0400 Subject: - Added a new try-catch procedure. --- luxc/src/lux/analyser/proc/common.clj | 15 ++++++++++++++- luxc/src/lux/compiler/jvm/proc/common.clj | 12 +++++++++++- luxc/src/lux/compiler/jvm/rt.clj | 23 +++++++++++++++++++++++ stdlib/source/lux/test.lux | 5 ++--- stdlib/test/test/lux/data/char.lux | 3 +-- 5 files changed, 51 insertions(+), 7 deletions(-) (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 050877ed5..9a295b1eb 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -17,6 +17,18 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["lux" "is"]) (&/|list =left =right) (&/|list))))))))) +(defn ^:private analyse-lux-try [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons op (&/$Nil)) ?values] + =op (&&/analyse-1 analyse (&/$AppT &type/IO $var) op) + _ (&type/check exo-type (&/$SumT &type/Text ;; lux;Left + $var ;; lux;Right + )) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list))))))))) + (do-template [ ] (defn [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] @@ -470,7 +482,8 @@ (case category "lux" (case proc - "is" (analyse-lux-is analyse exo-type ?values)) + "is" (analyse-lux-is analyse exo-type ?values) + "try" (analyse-lux-try analyse exo-type ?values)) "io" (case proc diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index b7e80dd2e..d434e0365 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -179,6 +179,15 @@ (.visitLabel $end))]] (return nil))) +(defn ^:private compile-lux-try [compile ?values special-args] + (|do [:let [(&/$Cons ?op (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?op) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "lux/Function") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "runTry" "(Llux/Function;)[Ljava/lang/Object;"))]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -878,7 +887,8 @@ (case category "lux" (case proc - "is" (compile-lux-is compile ?values special-args)) + "is" (compile-lux-is compile ?values special-args) + "try" (compile-lux-try compile ?values special-args)) "io" (case proc diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 0f86325f2..97c7d849c 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -1440,6 +1440,29 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd)) + _ (let [$from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" "(Llux/Function;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Throwable") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) ;; T + (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; TI + (.visitInsn Opcodes/ACONST_NULL) ;; TI? + swap2x1 ;; I?T + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;") ;; I?S + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) _ (doto =class (compile-LuxRT-pm-methods) (compile-LuxRT-adt-methods) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index bab513cc4..d953b7d65 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -13,8 +13,7 @@ text/format [error #- fail "Error/" Monad]) [io #- run] - ["R" random] - [host #- try])) + ["R" random])) ## [Host] (def: now @@ -156,7 +155,7 @@ (def: #hidden (try-body lazy-body) (-> (IO Test) Test) - (case (host;try (io;run lazy-body)) + (case (_lux_proc ["lux" "try"] [lazy-body]) (#;Right output) output diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux index 67332f282..88a5d86ae 100644 --- a/stdlib/test/test/lux/data/char.lux +++ b/stdlib/test/test/lux/data/char.lux @@ -6,8 +6,7 @@ [text] text/format) ["R" random] - pipe - [host #- try]) + pipe) lux/test) (test: "Char operations" -- cgit v1.3.1 From 6f554dc5a4172cd2afd7bde30b5edcaf0266f63d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Mar 2017 00:04:09 -0400 Subject: - Implemented custom JS host procedures. --- luxc/src/lux/analyser.clj | 6 +- luxc/src/lux/analyser/proc/js.clj | 93 ++ luxc/src/lux/compiler/js.clj | 5 +- luxc/src/lux/compiler/js/proc/host.clj | 86 ++ luxc/src/lux/compiler/js/rt.clj | 17 +- luxc/src/lux/compiler/jvm/proc/host.clj | 1 - stdlib/source/lux/host.js.lux | 83 ++ stdlib/source/lux/host.jvm.lux | 2169 +++++++++++++++++++++++++++++++ stdlib/source/lux/host.lux | 2169 ------------------------------- stdlib/test/test/lux/host.js.lux | 32 + stdlib/test/test/lux/host.jvm.lux | 121 ++ stdlib/test/test/lux/host.lux | 121 -- 12 files changed, 2607 insertions(+), 2296 deletions(-) create mode 100644 luxc/src/lux/analyser/proc/js.clj create mode 100644 luxc/src/lux/compiler/js/proc/host.clj create mode 100644 stdlib/source/lux/host.js.lux create mode 100644 stdlib/source/lux/host.jvm.lux delete mode 100644 stdlib/source/lux/host.lux create mode 100644 stdlib/test/test/lux/host.js.lux create mode 100644 stdlib/test/test/lux/host.jvm.lux delete mode 100644 stdlib/test/test/lux/host.lux (limited to 'stdlib/source') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 5f35d3c25..aaf441713 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -12,7 +12,8 @@ [module :as &&module] [parser :as &&a-parser]) (lux.analyser.proc [common :as &&common] - [jvm :as &&jvm]))) + [jvm :as &&jvm] + [js :as &&js]))) ;; [Utils] (defn analyse-variant+ [analyse exo-type ident values] @@ -136,7 +137,8 @@ (case ?category "jvm" (|do [_ &/jvm-host] (&&jvm/analyse-host analyse exo-type compilers ?proc ?args)) - ;; "js" + "js" (|do [_ &/js-host] + (&&js/analyse-host analyse exo-type ?proc ?args)) ;; common (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) )) diff --git a/luxc/src/lux/analyser/proc/js.clj b/luxc/src/lux/analyser/proc/js.clj new file mode 100644 index 000000000..2d36dd0d9 --- /dev/null +++ b/luxc/src/lux/analyser/proc/js.clj @@ -0,0 +1,93 @@ +(ns lux.analyser.proc.js + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type]) + (lux.analyser [base :as &&]))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (&&/analyse-1 analyse (&/$HostT "function" &/$Nil) ?function) + =args (&/map% (partial &&/analyse-1+ analyse) ?args) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/$Cons =function =args) (&/|list))))))) + + ^:private analyse-js-new "new" + ^:private analyse-js-call "call" + ) + +(defn ^:private analyse-js-object-call [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field ?args)) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + =args (&/map% (partial &&/analyse-1+ analyse) ?args) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "object-call"]) (&/$Cons =object (&/$Cons =field =args)) (&/|list))))))) + +(defn ^:private analyse-js-ref [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS ?ref-name)] (&/$Nil)) ?values] + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "ref"]) (&/|list) (&/|list ?ref-name))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/|list =object =field) (&/|list))))))) + + ^:private analyse-js-get-field "get-field" + ^:private analyse-js-delete-field "delete-field" + ) + +(defn ^:private analyse-js-set-field [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Cons ?value (&/$Nil)))) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + =value (&&/analyse-1+ analyse ?value) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "set-field"]) (&/|list =object =field =value) (&/|list))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$HostT &/$Nil)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/|list) (&/|list))))))) + + ^:private analyse-js-object "object" "object" + ^:private analyse-js-null "null" "object" + ^:private analyse-js-undefined "undefined" "undefined" + ) + +(defn analyse-host [analyse exo-type proc ?values] + (case proc + "new" (analyse-js-new analyse exo-type ?values) + "call" (analyse-js-call analyse exo-type ?values) + "object-call" (analyse-js-object-call analyse exo-type ?values) + "ref" (analyse-js-ref analyse exo-type ?values) + "object" (analyse-js-object analyse exo-type ?values) + "get-field" (analyse-js-get-field analyse exo-type ?values) + "set-field" (analyse-js-set-field analyse exo-type ?values) + "delete-field" (analyse-js-delete-field analyse exo-type ?values) + "null" (analyse-js-null analyse exo-type ?values) + "undefined" (analyse-js-undefined analyse exo-type ?values) + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown JS procedure: " proc))) + ) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 4f0546bf0..1537bb7de 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -23,7 +23,8 @@ [lux :as &&lux] [rt :as &&rt] [cache :as &&js-cache]) - (lux.compiler.js.proc [common :as &&common]) + (lux.compiler.js.proc [common :as &&common] + [host :as &&host]) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory NashornScriptEngine @@ -100,7 +101,7 @@ (&o/$proc [?proc-category ?proc-name] ?args special-args) (case ?proc-category - ;; "js" ... + "js" (&&host/compile-proc compile-expression ?proc-name ?args special-args) ;; common (&&common/compile-proc compile-expression ?proc-category ?proc-name ?args special-args)) diff --git a/luxc/src/lux/compiler/js/proc/host.clj b/luxc/src/lux/compiler/js/proc/host.clj new file mode 100644 index 000000000..3c0392a6b --- /dev/null +++ b/luxc/src/lux/compiler/js/proc/host.clj @@ -0,0 +1,86 @@ +(ns lux.compiler.js.proc.host + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]]))) + +(defn ^:private compile-js-ref [compile ?values special-args] + (|do [:let [(&/$Cons ?name (&/$Nil)) special-args]] + (return ?name))) + +(defn ^:private compile-js-new [compile ?values special-args] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (compile ?function) + =args (&/map% compile ?args)] + (return (str "new (" =function ")(" + (->> =args + (&/|interpose ",") + (&/fold str "")) + ")")))) + +(defn ^:private compile-js-call [compile ?values special-args] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (compile ?function) + =args (&/map% compile ?args)] + (return (str "(" =function ")(" + (->> =args + (&/|interpose ",") + (&/fold str "")) + ")")))) + +(defn ^:private compile-js-object-call [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field ?args)) ?values] + =object (compile ?object) + =field (compile ?field) + =args (&/map% compile ?args)] + (return (str "LuxRT." "jsObjectCall" + "(" =object + "," =field + "," (str "[" (->> =args (&/|interpose ",") (&/fold str "")) "]") + ")")))) + +(defn ^:private compile-js-object [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + (return "{}"))) + +(defn ^:private compile-js-get-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (compile ?object) + =field (compile ?field)] + (return (str "(" =object ")" "[" =field "]")))) + +(defn ^:private compile-js-set-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Cons ?input (&/$Nil)))) ?values] + =object (compile ?object) + =field (compile ?field) + =input (compile ?input)] + (return (str "LuxRT." "jsSetField" "(" =object "," =field "," =input ")")))) + +(defn ^:private compile-js-delete-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (compile ?object) + =field (compile ?field)] + (return (str "LuxRT." "jsDeleteField" "(" =object "," =field ")")))) + +(do-template [ ] + (defn [compile ?values special-args] + (return )) + + ^:private compile-js-null "null" + ^:private compile-js-undefined "undefined" + ) + +(defn compile-proc [compile proc-name ?values special-args] + (case proc-name + "new" (compile-js-new compile ?values special-args) + "call" (compile-js-call compile ?values special-args) + "object-call" (compile-js-object-call compile ?values special-args) + "ref" (compile-js-ref compile ?values special-args) + "object" (compile-js-object compile ?values special-args) + "get-field" (compile-js-get-field compile ?values special-args) + "set-field" (compile-js-set-field compile ?values special-args) + "delete-field" (compile-js-delete-field compile ?values special-args) + "null" (compile-js-null compile ?values special-args) + "undefined" (compile-js-undefined compile ?values special-args) + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["js" proc-name])))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index c2b3cba01..cdd83883d 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -755,6 +755,20 @@ "})") }) +(def ^:private js-methods + {"jsSetField" (str "(function jsSetField(object, field, input) {" + "object[field] = input;" + "return object;" + "})") + "jsDeleteField" (str "(function jsDeleteField(object, field) {" + "delete object[field];" + "return object;" + "})") + "jsObjectCall" (str "(function jsObjectCall(object, method, args) {" + "return object[method].apply(object, args);" + "})") + }) + (def LuxRT "LuxRT") (def compile-LuxRT @@ -766,7 +780,8 @@ text-methods array-methods bit-methods - io-methods) + io-methods + js-methods) (map (fn [[key val]] (str key ":" val))) (interpose ",") diff --git a/luxc/src/lux/compiler/jvm/proc/host.clj b/luxc/src/lux/compiler/jvm/proc/host.clj index 0e299f123..365a26937 100644 --- a/luxc/src/lux/compiler/jvm/proc/host.clj +++ b/luxc/src/lux/compiler/jvm/proc/host.clj @@ -1042,7 +1042,6 @@ (return nil))) (defn compile-proc [compile proc-name ?values special-args] - "jvm" (case proc-name "synchronized" (compile-jvm-synchronized compile ?values special-args) "load-class" (compile-jvm-load-class compile ?values special-args) diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux new file mode 100644 index 000000000..f935dc8d6 --- /dev/null +++ b/stdlib/source/lux/host.js.lux @@ -0,0 +1,83 @@ +(;module: + lux + (lux (control monad) + (data (coll [list #* "L/" Fold])) + [compiler #+ with-gensyms] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + )) + +(do-template [ ] + [(type: #export (#;HostT #;Nil))] + + [Object "object"] + [Function "function"] + [Symbol "symbol"] + [Undefined "undefined"] + ) + +(do-template [ ] + [(type: #export )] + + [String Text] + [Number Real] + [Boolean Bool] + ) + +## [Syntax] +(syntax: #export (set! field-name field-value object) + {#;doc (doc "A way to set fields from objects." + (set! "foo" 1234 some-object))} + (wrap (list (` (;_lux_proc ["js" "set-field"] [(~ object) (~ field-name) (~ field-value)]))))) + +(syntax: #export (delete! field-name object) + {#;doc (doc "A way to delete fields from objects." + (delete! "foo" some-object))} + (wrap (list (` (;_lux_proc ["js" "delete-field"] [(~ object) (~ field-name)]))))) + +(syntax: #export (get field-name type object) + {#;doc (doc "A way to get fields from objects." + (get "ceil" (ref "Math")) + (get "ceil" (-> Real Real) (ref "Math")))} + (wrap (list (` (:! (~ type) + (;_lux_proc ["js" "get-field"] [(~ object) (~ field-name)])))))) + +(syntax: #export (object [kvs (s;some (s;seq s;any s;any))]) + {#;doc (doc "A way to create JavaScript objects." + (object) + (object "foo" foo "bar" (inc bar)))} + (wrap (list (L/fold (lambda [[k v] object] + (` (set! (~ k) (~ v) (~ object)))) + (` (;_lux_proc ["js" "object"] [])) + kvs)))) + +(syntax: #export (ref [name s;text] [type (s;opt s;any)]) + {#;doc (doc "A way to refer to JavaScript variables." + (ref "document") + (ref "Math.ceil" (-> Real Real)))} + (wrap (list (` (:! (~ (default (' ;;Object) type)) + (;_lux_proc ["js" "ref"] [(~ (ast;text name))])))))) + +(do-template [ ] + [(syntax: #export () + {#;doc (doc + ())} + (wrap (list (` (;_lux_proc ["js" ] [])))))] + + [null "null" "Null object reference."] + [undef "undefined" "Undefined."] + ) + +(syntax: #export (call! [shape (s;alt ($_ s;seq s;any (s;tuple (s;some s;any)) (s;opt s;any)) + ($_ s;seq s;any s;text (s;tuple (s;some s;any)) (s;opt s;any)))]) + {#;doc (doc "A way to call JavaScript functions and methods." + (call! (ref "Math.ceil") [123.45]) + (call! (ref "Math") "ceil" [123.45]))} + (case shape + (#;Left [function args ?type]) + (wrap (list (` (:! (~ (default (' ;;Object) ?type)) + (;_lux_proc ["js" "call"] [(~ function) (~@ args)]))))) + + (#;Right [object field args ?type]) + (wrap (list (` (:! (~ (default (' ;;Object) ?type)) + (;_lux_proc ["js" "object-call"] [(~ object) (~ (ast;text field)) (~@ args)]))))))) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux new file mode 100644 index 000000000..41d567165 --- /dev/null +++ b/stdlib/source/lux/host.jvm.lux @@ -0,0 +1,2169 @@ +(;module: + lux + (lux (control monad + [enum]) + [io #+ IO Monad io] + (codata function) + (data (coll [list #* "" Functor Fold "List/" Monad Monoid] + [array #+ Array]) + number + maybe + [product] + [text "Text/" Eq Monoid] + text/format + [bool "Bool/" Codec]) + [compiler #+ with-gensyms Functor Monad] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + [type] + )) + +(do-template [ ] + [(def: #export ( value) + {#;doc (doc "Type converter." + "From:" + + "To:" + )} + (-> (host ) (host )) + (_lux_proc ["jvm" ] [value]))] + + [b2l "b2l" java.lang.Byte java.lang.Long] + + [s2l "s2l" java.lang.Short java.lang.Long] + + [d2i "d2i" java.lang.Double java.lang.Integer] + [d2l "d2l" java.lang.Double java.lang.Long] + [d2f "d2f" java.lang.Double java.lang.Float] + + [f2i "f2i" java.lang.Float java.lang.Integer] + [f2l "f2l" java.lang.Float java.lang.Long] + [f2d "f2d" java.lang.Float java.lang.Double] + + [i2b "i2b" java.lang.Integer java.lang.Byte] + [i2s "i2s" java.lang.Integer java.lang.Short] + [i2l "i2l" java.lang.Integer java.lang.Long] + [i2f "i2f" java.lang.Integer java.lang.Float] + [i2d "i2d" java.lang.Integer java.lang.Double] + [i2c "i2c" java.lang.Integer java.lang.Character] + + [l2b "l2b" java.lang.Long java.lang.Byte] + [l2s "l2s" java.lang.Long java.lang.Short] + [l2i "l2i" java.lang.Long java.lang.Integer] + [l2f "l2f" java.lang.Long java.lang.Float] + [l2d "l2d" java.lang.Long java.lang.Double] + + [c2b "c2b" java.lang.Character java.lang.Byte] + [c2s "c2s" java.lang.Character java.lang.Short] + [c2i "c2i" java.lang.Character java.lang.Integer] + [c2l "c2l" java.lang.Character java.lang.Long] + ) + +## [Utils] +(def: array-type-name "#Array") +(def: constructor-method-name "") +(def: member-separator ".") + +## Types +(do-template [ ] + [(type: #export + (#;HostT #;Nil))] + + ["[Z" Boolean-Array] + ["[B" Byte-Array] + ["[S" Short-Array] + ["[I" Int-Array] + ["[J" Long-Array] + ["[F" Float-Array] + ["[D" Double-Array] + ["[C" Char-Array] + ) + +(type: Code Text) + +(type: BoundKind + #UpperBound + #LowerBound) + +(type: #rec GenericType + (#GenericTypeVar Text) + (#GenericClass [Text (List GenericType)]) + (#GenericArray GenericType) + (#GenericWildcard (Maybe [BoundKind GenericType]))) + +(type: TypeParam + [Text (List GenericType)]) + +(type: Primitive-Mode + #ManualPrM + #AutoPrM) + +(type: PrivacyModifier + #PublicPM + #PrivatePM + #ProtectedPM + #DefaultPM) + +(type: StateModifier + #VolatileSM + #FinalSM + #DefaultSM) + +(type: InheritanceModifier + #FinalIM + #AbstractIM + #DefaultIM) + +(type: ClassKind + #Class + #Interface) + +(type: ClassDecl + {#class-name Text + #class-params (List TypeParam)}) + +(type: StackFrame (host java.lang.StackTraceElement)) +(type: StackTrace (Array StackFrame)) + +(type: SuperClassDecl + {#super-class-name Text + #super-class-params (List GenericType)}) + +(type: AnnotationParam + [Text AST]) + +(type: Annotation + {#ann-name Text + #ann-params (List AnnotationParam)}) + +(type: MemberDecl + {#member-name Text + #member-privacy PrivacyModifier + #member-anns (List Annotation)}) + +(type: FieldDecl + (#ConstantField GenericType AST) + (#VariableField StateModifier GenericType)) + +(type: MethodDecl + {#method-tvars (List TypeParam) + #method-inputs (List GenericType) + #method-output GenericType + #method-exs (List GenericType)}) + +(type: ArgDecl + {#arg-name Text + #arg-type GenericType}) + +(type: ConstructorArg + [GenericType AST]) + +(type: MethodDef + (#ConstructorMethod [Bool + (List TypeParam) + (List ArgDecl) + (List ConstructorArg) + AST + (List GenericType)]) + (#VirtualMethod [Bool + Bool + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#OverridenMethod [Bool + ClassDecl + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#StaticMethod [Bool + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#AbstractMethod [(List TypeParam) + (List ArgDecl) + GenericType + (List GenericType)]) + (#NativeMethod [(List TypeParam) + (List ArgDecl) + GenericType + (List GenericType)])) + +(type: PartialCall + {#pc-method AST + #pc-args AST}) + +(type: ImportMethodKind + #StaticIMK + #VirtualIMK) + +(type: ImportMethodCommons + {#import-member-mode Primitive-Mode + #import-member-alias Text + #import-member-kind ImportMethodKind + #import-member-tvars (List TypeParam) + #import-member-args (List [Bool GenericType]) + #import-member-maybe? Bool + #import-member-try? Bool + #import-member-io? Bool}) + +(type: ImportConstructorDecl + {}) + +(type: ImportMethodDecl + {#import-method-name Text + #import-method-return GenericType}) + +(type: ImportFieldDecl + {#import-field-mode Primitive-Mode + #import-field-name Text + #import-field-static? Bool + #import-field-maybe? Bool + #import-field-setter? Bool + #import-field-type GenericType}) + +(type: ImportMemberDecl + (#EnumDecl (List Text)) + (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) + (#MethodDecl [ImportMethodCommons ImportMethodDecl]) + (#FieldAccessDecl ImportFieldDecl)) + +(type: ClassImports + (List [Text Text])) + +## Utils +(def: (short-class-name name) + (-> Text Text) + (case (reverse (text;split-all-with "." name)) + (#;Cons short-name _) + short-name + + #;Nil + name)) + +(def: (manual-primitive-to-type class) + (-> Text (Maybe AST)) + (case class + (^template [ ] + + (#;Some (' ))) + (["boolean" (;^ java.lang.Boolean)] + ["byte" (;^ java.lang.Byte)] + ["short" (;^ java.lang.Short)] + ["int" (;^ java.lang.Integer)] + ["long" (;^ java.lang.Long)] + ["float" (;^ java.lang.Float)] + ["double" (;^ java.lang.Double)] + ["char" (;^ java.lang.Character)] + ["void" ;Unit]) + + _ + #;None)) + +(def: (auto-primitive-to-type class) + (-> Text (Maybe AST)) + (case class + (^template [ ] + + (#;Some (' ))) + (["boolean" ;Bool] + ["byte" ;Int] + ["short" ;Int] + ["int" ;Int] + ["long" ;Int] + ["float" ;Real] + ["double" ;Real] + ["char" ;Char] + ["void" ;Unit]) + + _ + #;None)) + +(def: (generic-class->type' mode type-params in-array? name+params + class->type') + (-> Primitive-Mode (List TypeParam) Bool [Text (List GenericType)] + (-> Primitive-Mode (List TypeParam) Bool GenericType AST) + AST) + (case [name+params mode in-array?] + (^=> [[prim #;Nil] #ManualPrM false] + [(manual-primitive-to-type prim) (#;Some output)]) + output + + (^=> [[prim #;Nil] #AutoPrM false] + [(auto-primitive-to-type prim) (#;Some output)]) + output + + [[name params] _ _] + (let [=params (map (class->type' mode type-params in-array?) params)] + (` (host (~ (ast;symbol ["" name])) [(~@ =params)]))))) + +(def: (class->type' mode type-params in-array? class) + (-> Primitive-Mode (List TypeParam) Bool GenericType AST) + (case class + (#GenericTypeVar name) + (case (find (lambda [[pname pbounds]] + (and (Text/= name pname) + (not (list;empty? pbounds)))) + type-params) + #;None + (ast;symbol ["" name]) + + (#;Some [pname pbounds]) + (class->type' mode type-params in-array? (default (undefined) (list;head pbounds)))) + + (#GenericClass name+params) + (generic-class->type' mode type-params in-array? name+params + class->type') + + (#GenericArray param) + (let [=param (class->type' mode type-params true param)] + (` (host (~ (ast;symbol ["" array-type-name])) [(~ =param)]))) + + (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) + (' (;Ex [*] *)) + + (#GenericWildcard (#;Some [#UpperBound upper-bound])) + (class->type' mode type-params in-array? upper-bound) + )) + +(def: (class->type mode type-params class) + (-> Primitive-Mode (List TypeParam) GenericType AST) + (class->type' mode type-params false class)) + +(def: (type-param-type$ [name bounds]) + (-> TypeParam AST) + (ast;symbol ["" name])) + +(def: (class-decl-type$ (^slots [#class-name #class-params])) + (-> ClassDecl AST) + (let [=params (map (: (-> TypeParam AST) + (lambda [[pname pbounds]] + (case pbounds + #;Nil + (ast;symbol ["" pname]) + + (#;Cons bound1 _) + (class->type #ManualPrM class-params bound1)))) + class-params)] + (` (host (~ (ast;symbol ["" class-name])) [(~@ =params)])))) + +(def: (stack-trace->text trace) + (-> StackTrace Text) + (let [size (_lux_proc ["jvm" "arraylength"] [trace]) + idxs (list;n.range +0 (n.dec size))] + (|> idxs + (map (: (-> Nat Text) + (lambda [idx] + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] + [(_lux_proc ["jvm" "aaload"] [trace idx])])))) + (text;join-with "\n") + ))) + +(def: (get-stack-trace t) + (-> (host java.lang.Throwable) StackTrace) + (_lux_proc ["jvm" "invokevirtual:java.lang.Throwable:getStackTrace:"] [t])) + +(def: #hidden (throwable->text t) + (All [a] (-> (host java.lang.Throwable) (Either Text a))) + (#;Left (format (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [t]) + "\n" + (|> t get-stack-trace stack-trace->text)))) + +(def: empty-imports + ClassImports + (list)) + +(def: (get-import name imports) + (-> Text ClassImports (Maybe Text)) + (:: Functor map product;right + (find (|>. product;left (Text/= name)) + imports))) + +(def: (add-import short+full imports) + (-> [Text Text] ClassImports ClassImports) + (#;Cons short+full imports)) + +(def: (class-imports compiler) + (-> Compiler ClassImports) + (case (compiler;run compiler + (: (Lux ClassImports) + (do Monad + [current-module compiler;current-module-name + defs (compiler;defs current-module)] + (wrap (fold (: (-> [Text Def] ClassImports ClassImports) + (lambda [[short-name [_ meta _]] imports] + (case (compiler;get-text-ann (ident-for #;;jvm-class) meta) + (#;Some full-class-name) + (add-import [short-name full-class-name] imports) + + _ + imports))) + empty-imports + defs))))) + (#;Left _) (list) + (#;Right imports) imports)) + +(def: java.lang-classes + (List Text) + (list ## Interfaces + "Appendable" + "AutoCloseable" + "CharSequence" + "Cloneable" + "Comparable" + "Iterable" + "Readable" + "Runnable" + + ## Classes + "Boolean" + "Byte" + "Character" + "Class" + "ClassLoader" + "ClassValue" + "Compiler" + "Double" + "Enum" + "Float" + "InheritableThreadLocal" + "Integer" + "Long" + "Math" + "Number" + "Object" + "Package" + "Process" + "ProcessBuilder" + "Runtime" + "RuntimePermission" + "SecurityManager" + "Short" + "StackTraceElement" + "StrictMath" + "String" + "StringBuffer" + "StringBuilder" + "System" + "Thread" + "ThreadGroup" + "ThreadLocal" + "Throwable" + "Void" + + ## Exceptions + "ArithmeticException" + "ArrayIndexOutOfBoundsException" + "ArrayStoreException" + "ClassCastException" + "ClassNotFoundException" + "CloneNotSupportedException" + "EnumConstantNotPresentException" + "Exception" + "IllegalAccessException" + "IllegalArgumentException" + "IllegalMonitorStateException" + "IllegalStateException" + "IllegalThreadStateException" + "IndexOutOfBoundsException" + "InstantiationException" + "InterruptedException" + "NegativeArraySizeException" + "NoSuchFieldException" + "NoSuchMethodException" + "NullPointerException" + "NumberFormatException" + "ReflectiveOperationException" + "RuntimeException" + "SecurityException" + "StringIndexOutOfBoundsException" + "TypeNotPresentException" + "UnsupportedOperationException" + + ## Annotations + "Deprecated" + "Override" + "SafeVarargs" + "SuppressWarnings")) + +(def: (fully-qualified-class-name? name) + (-> Text Bool) + (text;contains? "." name)) + +(def: (fully-qualify-class-name imports name) + (-> ClassImports Text Text) + (cond (fully-qualified-class-name? name) + name + + (member? text;Eq java.lang-classes name) + (format "java.lang." name) + + ## else + (default name (get-import name imports)))) + +(def: type-var-class Text "java.lang.Object") + +(def: (simple-class$ params class) + (-> (List TypeParam) GenericType Text) + (case class + (#GenericTypeVar name) + (case (find (lambda [[pname pbounds]] + (and (Text/= name pname) + (not (list;empty? pbounds)))) + params) + #;None + type-var-class + + (#;Some [pname pbounds]) + (simple-class$ params (default (undefined) (list;head pbounds)))) + + (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) + type-var-class + + (#GenericWildcard (#;Some [#UpperBound upper-bound])) + (simple-class$ params upper-bound) + + (#GenericClass name params) + name + + (#GenericArray param') + (case param' + (#GenericArray param) + (format "[" (simple-class$ params param)) + + (^template [ ] + (#GenericClass #;Nil) + ) + (["boolean" "[Z"] + ["byte" "[B"] + ["short" "[S"] + ["int" "[I"] + ["long" "[J"] + ["float" "[F"] + ["double" "[D"] + ["char" "[C"]) + + param + (format "[L" (simple-class$ params param) ";")) + )) + +(def: (make-get-const-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." field-name)] + _ (s;this! (ast;symbol ["" dotted-name]))] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" class-name ":" field-name)))] []))))) + +(def: (make-get-var-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." field-name)] + _ (s;this! (ast;symbol ["" dotted-name]))] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this]))))) + +(def: (make-put-var-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." field-name)] + [_ _ value] (: (Syntax [Unit Unit AST]) + (s;form ($_ s;seq (s;this! (' :=)) (s;this! (ast;symbol ["" dotted-name])) s;any)))] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)]))))) + +(def: (pre-walk-replace f input) + (-> (-> AST AST) AST AST) + (case (f input) + (^template [] + [meta ( parts)] + [meta ( (map (pre-walk-replace f) parts))]) + ([#;FormS] + [#;TupleS]) + + [meta (#;RecordS pairs)] + [meta (#;RecordS (map (: (-> [AST AST] [AST AST]) + (lambda [[key val]] + [(pre-walk-replace f key) (pre-walk-replace f val)])) + pairs))] + + ast' + ast')) + +(def: (parser->replacer p ast) + (-> (Syntax AST) (-> AST AST)) + (case (s;run (list ast) p) + (#;Right [#;Nil ast']) + ast' + + _ + ast + )) + +(def: (field->parser class-name [[field-name _ _] field]) + (-> Text [MemberDecl FieldDecl] (Syntax AST)) + (case field + (#ConstantField _) + (make-get-const-parser class-name field-name) + + (#VariableField _) + (s;either (make-get-var-parser class-name field-name) + (make-put-var-parser class-name field-name)))) + +(def: (make-constructor-parser params class-name arg-decls) + (-> (List TypeParam) Text (List ArgDecl) (Syntax AST)) + (do s;Monad + [[_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;this! (' .new!)) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))] + [(~@ args)]))))) + +(def: (make-static-method-parser params class-name method-name arg-decls) + (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." method-name "!")] + [_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] + [(~@ args)]))))) + +(do-template [ ] + [(def: ( params class-name method-name arg-decls) + (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." method-name "!")] + [_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] + [(~' _jvm_this) (~@ args)])))))] + + [make-special-method-parser "invokespecial"] + [make-virtual-method-parser "invokevirtual"] + ) + +(def: (method->parser params class-name [[method-name _ _] meth-def]) + (-> (List TypeParam) Text [MemberDecl MethodDef] (Syntax AST)) + (case meth-def + (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) + (make-constructor-parser params class-name args) + + (#StaticMethod strict? type-vars args return-type return-expr exs) + (make-static-method-parser params class-name method-name args) + + (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs)) + (make-special-method-parser params class-name method-name args) + + (#AbstractMethod type-vars args return-type exs) + (make-virtual-method-parser params class-name method-name args) + + (#NativeMethod type-vars args return-type exs) + (make-virtual-method-parser params class-name method-name args))) + +## Syntaxs +(def: (full-class-name^ imports) + (-> ClassImports (Syntax Text)) + (do s;Monad + [name s;local-symbol] + (wrap (fully-qualify-class-name imports name)))) + +(def: privacy-modifier^ + (Syntax PrivacyModifier) + (let [(^open) s;Monad] + ($_ s;alt + (s;this! (' #public)) + (s;this! (' #private)) + (s;this! (' #protected)) + (wrap [])))) + +(def: inheritance-modifier^ + (Syntax InheritanceModifier) + (let [(^open) s;Monad] + ($_ s;alt + (s;this! (' #final)) + (s;this! (' #abstract)) + (wrap [])))) + +(def: bound-kind^ + (Syntax BoundKind) + (s;alt (s;this! (' <)) + (s;this! (' >)))) + +(def: (generic-type^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax GenericType)) + ($_ s;either + (do s;Monad + [_ (s;this! (' ?))] + (wrap (#GenericWildcard #;None))) + (s;tuple (do s;Monad + [_ (s;this! (' ?)) + bound-kind bound-kind^ + bound (generic-type^ imports type-vars)] + (wrap (#GenericWildcard (#;Some [bound-kind bound]))))) + (do s;Monad + [name (full-class-name^ imports)] + (let% [ (do-template [ ] + [(Text/= name) + (wrap (#GenericClass (list)))] + + ["[Z" "Boolean-Array"] + ["[B" "Byte-Array"] + ["[S" "Short-Array"] + ["[I" "Int-Array"] + ["[J" "Long-Array"] + ["[F" "Float-Array"] + ["[D" "Double-Array"] + ["[C" "Char-Array"])] + (cond (member? text;Eq (map product;left type-vars) name) + (wrap (#GenericTypeVar name)) + + + + ## else + (wrap (#GenericClass name (list)))))) + (s;form (do s;Monad + [name (s;this! (' Array)) + component (generic-type^ imports type-vars)] + (case component + (^template [ ] + (#GenericClass #;Nil) + (wrap (#GenericClass (list)))) + (["[Z" "boolean"] + ["[B" "byte"] + ["[S" "short"] + ["[I" "int"] + ["[J" "long"] + ["[F" "float"] + ["[D" "double"] + ["[C" "char"]) + + _ + (wrap (#GenericArray component))))) + (s;form (do s;Monad + [name (full-class-name^ imports) + params (s;some (generic-type^ imports type-vars)) + _ (s;assert (format name " can't be a type-parameter!") + (not (member? text;Eq (map product;left type-vars) name)))] + (wrap (#GenericClass name params)))) + )) + +(def: (type-param^ imports) + (-> ClassImports (Syntax TypeParam)) + (s;either (do s;Monad + [param-name s;local-symbol] + (wrap [param-name (list)])) + (s;tuple (do s;Monad + [param-name s;local-symbol + _ (s;this! (' <)) + bounds (s;many (generic-type^ imports (list)))] + (wrap [param-name bounds]))))) + +(def: (type-params^ imports) + (-> ClassImports (Syntax (List TypeParam))) + (s;tuple (s;some (type-param^ imports)))) + +(def: (class-decl^ imports) + (-> ClassImports (Syntax ClassDecl)) + (s;either (do s;Monad + [name (full-class-name^ imports)] + (wrap [name (list)])) + (s;form (do s;Monad + [name (full-class-name^ imports) + params (s;some (type-param^ imports))] + (wrap [name params]))) + )) + +(def: (super-class-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax SuperClassDecl)) + (s;either (do s;Monad + [name (full-class-name^ imports)] + (wrap [name (list)])) + (s;form (do s;Monad + [name (full-class-name^ imports) + params (s;some (generic-type^ imports type-vars))] + (wrap [name params]))))) + +(def: annotation-params^ + (Syntax (List AnnotationParam)) + (s;record (s;some (s;seq s;local-tag s;any)))) + +(def: (annotation^ imports) + (-> ClassImports (Syntax Annotation)) + (s;either (do s;Monad + [ann-name (full-class-name^ imports)] + (wrap [ann-name (list)])) + (s;form (s;seq (full-class-name^ imports) + annotation-params^)))) + +(def: (annotations^' imports) + (-> ClassImports (Syntax (List Annotation))) + (do s;Monad + [_ (s;this! (' #ann))] + (s;tuple (s;some (annotation^ imports))))) + +(def: (annotations^ imports) + (-> ClassImports (Syntax (List Annotation))) + (do s;Monad + [anns?? (s;opt (annotations^' imports))] + (wrap (default (list) anns??)))) + +(def: (throws-decl'^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List GenericType))) + (do s;Monad + [_ (s;this! (' #throws))] + (s;tuple (s;some (generic-type^ imports type-vars))))) + +(def: (throws-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List GenericType))) + (do s;Monad + [exs? (s;opt (throws-decl'^ imports type-vars))] + (wrap (default (list) exs?)))) + +(def: (method-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl])) + (s;form (do s;Monad + [tvars (s;default (list) (type-params^ imports)) + name s;local-symbol + anns (annotations^ imports) + inputs (s;tuple (s;some (generic-type^ imports type-vars))) + output (generic-type^ imports type-vars) + exs (throws-decl^ imports type-vars)] + (wrap [[name #PublicPM anns] {#method-tvars tvars + #method-inputs inputs + #method-output output + #method-exs exs}])))) + +(def: state-modifier^ + (Syntax StateModifier) + ($_ s;alt + (s;this! (' #volatile)) + (s;this! (' #final)) + (:: s;Monad wrap []))) + +(def: (field-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl])) + (s;either (s;form (do s;Monad + [_ (s;this! (' #const)) + name s;local-symbol + anns (annotations^ imports) + type (generic-type^ imports type-vars) + body s;any] + (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) + (s;form (do s;Monad + [pm privacy-modifier^ + sm state-modifier^ + name s;local-symbol + anns (annotations^ imports) + type (generic-type^ imports type-vars)] + (wrap [[name pm anns] (#VariableField [sm type])]))))) + +(def: (arg-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax ArgDecl)) + (s;tuple (s;seq s;local-symbol + (generic-type^ imports type-vars)))) + +(def: (arg-decls^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List ArgDecl))) + (s;some (arg-decl^ imports type-vars))) + +(def: (constructor-arg^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax ConstructorArg)) + (s;tuple (s;seq (generic-type^ imports type-vars) s;any))) + +(def: (constructor-args^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List ConstructorArg))) + (s;tuple (s;some (constructor-arg^ imports type-vars)))) + +(def: (constructor-method^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + strict-fp? (s;this? (' #strict)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append class-vars method-vars)] + [_ arg-decls] (s;form (s;seq (s;this! (' new)) + (arg-decls^ imports total-vars))) + constructor-args (constructor-args^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name constructor-method-name + #member-privacy pm + #member-anns annotations} + (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)])))) + +(def: (virtual-method-def^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + strict-fp? (s;this? (' #strict)) + final? (s;this? (' #final)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append class-vars method-vars)] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)])))) + +(def: (overriden-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [strict-fp? (s;this? (' #strict)) + owner-class (class-decl^ imports) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append (product;right owner-class) method-vars)] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy #PublicPM + #member-anns annotations} + (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)])))) + +(def: (static-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + strict-fp? (s;this? (' #strict)) + _ (s;this! (' #static)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)])))) + +(def: (abstract-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + _ (s;this! (' #abstract)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports)] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#AbstractMethod method-vars arg-decls return-type exs)])))) + +(def: (native-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + _ (s;this! (' #native)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports)] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#NativeMethod method-vars arg-decls return-type exs)])))) + +(def: (method-def^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + ($_ s;either + (constructor-method^ imports class-vars) + (virtual-method-def^ imports class-vars) + (overriden-method-def^ imports) + (static-method-def^ imports) + (abstract-method-def^ imports) + (native-method-def^ imports))) + +(def: partial-call^ + (Syntax PartialCall) + (s;form (s;seq s;any s;any))) + +(def: class-kind^ + (Syntax ClassKind) + (s;either (do s;Monad + [_ (s;this! (' #class))] + (wrap #Class)) + (do s;Monad + [_ (s;this! (' #interface))] + (wrap #Interface)) + )) + +(def: import-member-alias^ + (Syntax (Maybe Text)) + (s;opt (do s;Monad + [_ (s;this! (' #as))] + s;local-symbol))) + +(def: (import-member-args^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType]))) + (s;tuple (s;some (s;seq (s;this? (' #?)) (generic-type^ imports type-vars))))) + +(def: import-member-return-flags^ + (Syntax [Bool Bool Bool]) + ($_ s;seq (s;this? (' #io)) (s;this? (' #try)) (s;this? (' #?)))) + +(def: primitive-mode^ + (Syntax Primitive-Mode) + (s;alt (s;this! (' #manual)) + (s;this! (' #auto)))) + +(def: (import-member-decl^ imports owner-vars) + (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl)) + ($_ s;either + (s;form (do s;Monad + [_ (s;this! (' #enum)) + enum-members (s;some s;local-symbol)] + (wrap (#EnumDecl enum-members)))) + (s;form (do s;Monad + [tvars (s;default (list) (type-params^ imports)) + _ (s;this! (' new)) + ?alias import-member-alias^ + #let [total-vars (List/append owner-vars tvars)] + ?prim-mode (s;opt primitive-mode^) + args (import-member-args^ imports total-vars) + [io? try? maybe?] import-member-return-flags^] + (wrap (#ConstructorDecl [{#import-member-mode (default #AutoPrM ?prim-mode) + #import-member-alias (default "new" ?alias) + #import-member-kind #VirtualIMK + #import-member-tvars tvars + #import-member-args args + #import-member-maybe? maybe? + #import-member-try? try? + #import-member-io? io?} + {}])) + )) + (s;form (do s;Monad + [kind (: (Syntax ImportMethodKind) + (s;alt (s;this! (' #static)) + (wrap []))) + tvars (s;default (list) (type-params^ imports)) + name s;local-symbol + ?alias import-member-alias^ + #let [total-vars (List/append owner-vars tvars)] + ?prim-mode (s;opt primitive-mode^) + args (import-member-args^ imports total-vars) + [io? try? maybe?] import-member-return-flags^ + return (generic-type^ imports total-vars)] + (wrap (#MethodDecl [{#import-member-mode (default #AutoPrM ?prim-mode) + #import-member-alias (default name ?alias) + #import-member-kind kind + #import-member-tvars tvars + #import-member-args args + #import-member-maybe? maybe? + #import-member-try? try? + #import-member-io? io?} + {#import-method-name name + #import-method-return return + }])))) + (s;form (do s;Monad + [static? (s;this? (' #static)) + name s;local-symbol + ?prim-mode (s;opt primitive-mode^) + gtype (generic-type^ imports owner-vars) + maybe? (s;this? (' #?)) + setter? (s;this? (' #!))] + (wrap (#FieldAccessDecl {#import-field-mode (default #AutoPrM ?prim-mode) + #import-field-name name + #import-field-static? static? + #import-field-maybe? maybe? + #import-field-setter? setter? + #import-field-type gtype})))) + )) + +## Generators +(def: with-parens + (-> Code Code) + (text;enclose ["(" ")"])) + +(def: with-brackets + (-> Code Code) + (text;enclose ["[" "]"])) + +(def: spaced + (-> (List Code) Code) + (text;join-with " ")) + +(def: (privacy-modifier$ pm) + (-> PrivacyModifier Code) + (case pm + #PublicPM "public" + #PrivatePM "private" + #ProtectedPM "protected" + #DefaultPM "default")) + +(def: (inheritance-modifier$ im) + (-> InheritanceModifier Code) + (case im + #FinalIM "final" + #AbstractIM "abstract" + #DefaultIM "default")) + +(def: (annotation-param$ [name value]) + (-> AnnotationParam Code) + (format name "=" (ast;to-text value))) + +(def: (annotation$ [name params]) + (-> Annotation Code) + (format "(" name " " "{" (text;join-with "\t" (map annotation-param$ params)) "}" ")")) + +(def: (bound-kind$ kind) + (-> BoundKind Code) + (case kind + #UpperBound "<" + #LowerBound ">")) + +(def: (generic-type$ gtype) + (-> GenericType Code) + (case gtype + (#GenericTypeVar name) + name + + (#GenericClass name params) + (format "(" name " " (spaced (map generic-type$ params)) ")") + + (#GenericArray param) + (format "(" array-type-name " " (generic-type$ param) ")") + + (#GenericWildcard #;None) + "?" + + (#GenericWildcard (#;Some [bound-kind bound])) + (format (bound-kind$ bound-kind) (generic-type$ bound)))) + +(def: (type-param$ [name bounds]) + (-> TypeParam Code) + (format "(" name " " (spaced (map generic-type$ bounds)) ")")) + +(def: (class-decl$ (^open)) + (-> ClassDecl Code) + (format "(" class-name " " (spaced (map type-param$ class-params)) ")")) + +(def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) + (-> SuperClassDecl Code) + (format "(" super-class-name " " (spaced (map generic-type$ super-class-params)) ")")) + +(def: (method-decl$ [[name pm anns] method-decl]) + (-> [MemberDecl MethodDecl] Code) + (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] + (with-parens + (spaced (list name + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ method-tvars))) + (with-brackets (spaced (map generic-type$ method-exs))) + (with-brackets (spaced (map generic-type$ method-inputs))) + (generic-type$ method-output)) + )))) + +(def: (state-modifier$ sm) + (-> StateModifier Code) + (case sm + #VolatileSM "volatile" + #FinalSM "final" + #DefaultSM "default")) + +(def: (field-decl$ [[name pm anns] field]) + (-> [MemberDecl FieldDecl] Code) + (case field + (#ConstantField class value) + (with-parens + (spaced (list "constant" name + (with-brackets (spaced (map annotation$ anns))) + (generic-type$ class) + (ast;to-text value)) + )) + + (#VariableField sm class) + (with-parens + (spaced (list "variable" name + (privacy-modifier$ pm) + (state-modifier$ sm) + (with-brackets (spaced (map annotation$ anns))) + (generic-type$ class)) + )) + )) + +(def: (arg-decl$ [name type]) + (-> ArgDecl Code) + (with-parens + (spaced (list name (generic-type$ type))))) + +(def: (constructor-arg$ [class term]) + (-> ConstructorArg Code) + (with-brackets + (spaced (list (generic-type$ class) (ast;to-text term))))) + +(def: (method-def$ replacer super-class [[name pm anns] method-def]) + (-> (-> AST AST) SuperClassDecl [MemberDecl MethodDef] Code) + (case method-def + (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs) + (with-parens + (spaced (list "init" + (privacy-modifier$ pm) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (with-brackets (spaced (map constructor-arg$ constructor-args))) + (ast;to-text (pre-walk-replace replacer body)) + ))) + + (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs) + (with-parens + (spaced (list "virtual" + name + (privacy-modifier$ pm) + (Bool/encode final?) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (ast;to-text (pre-walk-replace replacer body))))) + + (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) + (let [super-replacer (parser->replacer (s;form (do s;Monad + [_ (s;this! (' .super!)) + args (s;tuple (s;exactly (list;size arg-decls) s;any)) + #let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right) + arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))] + [(~' _jvm_this) (~@ args)]))))))] + (with-parens + (spaced (list "override" + (class-decl$ class-decl) + name + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (|> body + (pre-walk-replace replacer) + (pre-walk-replace super-replacer) + (ast;to-text)) + )))) + + (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) + (with-parens + (spaced (list "static" + name + (privacy-modifier$ pm) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (ast;to-text (pre-walk-replace replacer body))))) + + (#AbstractMethod type-vars arg-decls return-type exs) + (with-parens + (spaced (list "abstract" + name + (privacy-modifier$ pm) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type)))) + + (#NativeMethod type-vars arg-decls return-type exs) + (with-parens + (spaced (list "native" + name + (privacy-modifier$ pm) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type)))) + )) + +(def: (complete-call$ obj [method args]) + (-> AST PartialCall AST) + (` ((~ method) (~ args) (~ obj)))) + +## [Syntax] +(def: object-super-class + SuperClassDecl + {#super-class-name "java.lang.Object" + #super-class-params (list)}) + +(syntax: #export (class: [#let [imports (class-imports *compiler*)]] + [im inheritance-modifier^] + [class-decl (class-decl^ imports)] + [#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]] + [#let [class-vars (product;right class-decl)]] + [super (s;default object-super-class + (super-class-decl^ imports class-vars))] + [interfaces (s;default (list) + (s;tuple (s;some (super-class-decl^ imports class-vars))))] + [annotations (annotations^ imports)] + [fields (s;some (field-decl^ imports class-vars))] + [methods (s;some (method-def^ imports class-vars))]) + {#;doc (doc "Allows defining JVM classes in Lux code." + "For example:" + (class: #final (JvmPromise A) [] + ## Fields + (#private resolved boolean) + (#private datum A) + (#private waitingList (java.util.List lux.Function)) + ## Methods + (#public [] new [] [] + (exec (:= .resolved false) + (:= .waitingList (ArrayList.new [])) + [])) + (#public [] resolve [{value A}] boolean + (let [container (.new! [])] + (synchronized _jvm_this + (if .resolved + false + (exec (:= .datum value) + (:= .resolved true) + (let [sleepers .waitingList + sleepers-count (java.util.List.size [] sleepers)] + (map (lambda [idx] + (let [sleeper (java.util.List.get [(l2i idx)] sleepers)] + (Executor.execute [(@runnable (lux.Function.apply [(:! Object value)] sleeper))] + executor))) + (i.range 0 (i.dec (i2l sleepers-count))))) + (:= .waitingList (null)) + true))))) + (#public [] poll [] A + .datum) + (#public [] wasResolved [] boolean + (synchronized _jvm_this + .resolved)) + (#public [] waitOn [{callback lux.Function}] void + (synchronized _jvm_this + (exec (if .resolved + (lux.Function.apply [(:! Object .datum)] callback) + (:! Object (java.util.List.add [callback] .waitingList))) + []))) + (#public #static [A] make [{value A}] (lux.concurrency.promise.JvmPromise A) + (let [container (.new! [])] + (exec (.resolve! (:! (host lux.concurrency.promise.JvmPromise [Unit]) container) [(:! Unit value)]) + container)))) + + "The vector corresponds to parent interfaces." + "An optional super-class can be specified before the vector. If not specified, java.lang.Object will be assumed." + "Fields and methods defined in the class can be used with special syntax." + "For example:" + ".resolved, for accessing the \"resolved\" field." + "(:= .resolved true) for modifying it." + "(.new! []) for calling the class's constructor." + "(.resolve! container [value]) for calling the \"resolve\" method." + )} + (do Monad + [current-module compiler;current-module-name + #let [fully-qualified-class-name (format (text;replace "/" "." current-module) "." full-class-name) + field-parsers (map (field->parser fully-qualified-class-name) fields) + method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods) + replacer (parser->replacer (fold s;either + (s;fail "") + (List/append field-parsers method-parsers))) + def-code (format "class:" + (spaced (list (class-decl$ class-decl) + (super-class-decl$ super) + (with-brackets (spaced (map super-class-decl$ interfaces))) + (inheritance-modifier$ im) + (with-brackets (spaced (map annotation$ annotations))) + (with-brackets (spaced (map field-decl$ fields))) + (with-brackets (spaced (map (method-def$ replacer super) methods))))))]] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) + +(syntax: #export (interface: [#let [imports (class-imports *compiler*)]] + [class-decl (class-decl^ imports)] + [#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]] + [#let [class-vars (product;right class-decl)]] + [supers (s;default (list) + (s;tuple (s;some (super-class-decl^ imports class-vars))))] + [annotations (annotations^ imports)] + [members (s;some (method-decl^ imports class-vars))]) + {#;doc (doc "Allows defining JVM interfaces." + (interface: TestInterface + ([] foo [boolean String] void #throws [Exception])))} + (let [def-code (format "interface:" + (spaced (list (class-decl$ class-decl) + (with-brackets (spaced (map super-class-decl$ supers))) + (with-brackets (spaced (map annotation$ annotations))) + (spaced (map method-decl$ members)))))] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))) + )) + +(syntax: #export (object [#let [imports (class-imports *compiler*)]] + [#let [class-vars (list)]] + [super (s;default object-super-class + (super-class-decl^ imports class-vars))] + [interfaces (s;default (list) + (s;tuple (s;some (super-class-decl^ imports class-vars))))] + [constructor-args (constructor-args^ imports class-vars)] + [methods (s;some (overriden-method-def^ imports))]) + {#;doc (doc "Allows defining anonymous classes." + "The 1st vector corresponds to parent interfaces." + "The 2nd vector corresponds to arguments to the super class constructor." + "An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed." + (object [java.lang.Runnable] + [] + (java.lang.Runnable (run) void + (exec (do-something some-input) + []))) + )} + (let [def-code (format "anon-class:" + (spaced (list (super-class-decl$ super) + (with-brackets (spaced (map super-class-decl$ interfaces))) + (with-brackets (spaced (map constructor-arg$ constructor-args))) + (with-brackets (spaced (map (method-def$ id super) methods))))))] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) + +(syntax: #export (null) + {#;doc (doc "Null object reference." + (null))} + (wrap (list (` (;_lux_proc ["jvm" "null"] []))))) + +(def: #export (null? obj) + {#;doc (doc "Test for null object reference." + (null? (null)) + "=>" + true + (null? "YOLO") + "=>" + false)} + (-> (host java.lang.Object) Bool) + (;_lux_proc ["jvm" "null?"] [obj])) + +(syntax: #export (??? expr) + {#;doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." + (??? (: java.lang.String (null))) + "=>" + #;None + (??? "YOLO") + "=>" + (#;Some "YOLO"))} + (with-gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ expr)] + (if (;_lux_proc ["jvm" "null?"] [(~ g!temp)]) + #;None + (#;Some (~ g!temp))))))))) + +(syntax: #export (!!! expr) + {#;doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." + "A #;None would get translated into a (null)." + (!!! (??? (: java.lang.Thread (null)))) + "=>" + (null) + (!!! (??? "YOLO")) + "=>" + "YOLO")} + (with-gensyms [g!value] + (wrap (list (` (;_lux_case (~ expr) + (#;Some (~ g!value)) + (~ g!value) + + #;None + (;_lux_proc ["jvm" "null"] []))))))) + +(syntax: #export (try expr) + {#;doc (doc "Covers the expression in a try-catch block." + "If it succeeds, you get (#;Right result)." + "If it fails, you get (#;Left error+stack-traces-as-text)." + (try (risky-computation input)))} + (wrap (list (`' (_lux_proc ["jvm" "try"] + [(#;Right (~ expr)) + ;;throwable->text]))))) + +(syntax: #export (instance? [#let [imports (class-imports *compiler*)]] + [class (generic-type^ imports (list))] + [obj (s;opt s;any)]) + {#;doc (doc "Checks whether an object is an instance of a particular class." + "Caveat emptor: Can't check for polymorphism, so avoid using parameterized classes." + (instance? String "YOLO"))} + (case obj + (#;Some obj) + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)])))) + + #;None + (do @ + [g!obj (compiler;gensym "obj")] + (wrap (list (` (: (-> (host (~' java.lang.Object)) Bool) + (lambda [(~ g!obj)] + (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ g!obj)]))))))) + )) + +(syntax: #export (synchronized lock body) + {#;doc (doc "Evaluates body, while holding a lock on a given object." + (synchronized object-to-be-locked + (exec (do-something ...) + (do-something-else ...) + (finish-the-computation ...))))} + (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)]))))) + +(syntax: #export (do-to obj [methods (s;some partial-call^)]) + {#;doc (doc "Call a variety of methods on an object; then return the object." + (do-to vreq + (HttpServerRequest.setExpectMultipart [true]) + (ReadStream.handler [(object [(Handler Buffer)] + [] + ((Handler A) (handle [buffer A]) void + (io;run (do Monad + [_ (write (Buffer.getBytes [] buffer) body)] + (wrap [])))) + )]) + (ReadStream.endHandler [[(object [(Handler Void)] + [] + ((Handler A) (handle [_ A]) void + (exec (do Monad + [#let [_ (io;run (close body))] + response (handler (request$ vreq body))] + (respond! response vreq)) + [])) + )]])))} + (with-gensyms [g!obj] + (wrap (list (` (let [(~ g!obj) (~ obj)] + (exec (~@ (map (complete-call$ g!obj) methods)) + (~ g!obj)))))))) + +(def: (class-import$ long-name? [full-name params]) + (-> Bool ClassDecl AST) + (let [def-name (if long-name? + full-name + (short-class-name full-name))] + (case params + #;Nil + (` (def: (~ (ast;symbol ["" def-name])) + {#;type? true + #;;jvm-class (~ (ast;text full-name))} + Type + (host (~ (ast;symbol ["" full-name]))))) + + (#;Cons _) + (let [params' (map (lambda [[p _]] (ast;symbol ["" p])) params)] + (` (def: (~ (ast;symbol ["" def-name])) + {#;type? true + #;;jvm-class (~ (ast;text full-name))} + Type + (All [(~@ params')] + (host (~ (ast;symbol ["" full-name])) + [(~@ params')])))))))) + +(def: (member-type-vars class-tvars member) + (-> (List TypeParam) ImportMemberDecl (List TypeParam)) + (case member + (#ConstructorDecl [commons _]) + (List/append class-tvars (get@ #import-member-tvars commons)) + + (#MethodDecl [commons _]) + (case (get@ #import-member-kind commons) + #StaticIMK + (get@ #import-member-tvars commons) + + _ + (List/append class-tvars (get@ #import-member-tvars commons))) + + _ + class-tvars)) + +(def: (member-def-arg-bindings type-params class member) + (-> (List TypeParam) ClassDecl ImportMemberDecl (Lux [(List AST) (List AST) (List Text) (List AST)])) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (let [(^slots [#import-member-tvars #import-member-args]) commons] + (do Monad + [arg-inputs (mapM @ + (: (-> [Bool GenericType] (Lux [AST AST])) + (lambda [[maybe? _]] + (with-gensyms [arg-name] + (wrap [arg-name (if maybe? + (` (!!! (~ arg-name))) + arg-name)])))) + import-member-args) + #let [arg-classes (: (List Text) + (map (. (simple-class$ (List/append type-params import-member-tvars)) product;right) + import-member-args)) + arg-types (map (: (-> [Bool GenericType] AST) + (lambda [[maybe? arg]] + (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] + (if maybe? + (` (Maybe (~ arg-type))) + arg-type)))) + import-member-args) + arg-lambda-inputs (map product;left arg-inputs) + arg-method-inputs (map product;right arg-inputs)]] + (wrap [arg-lambda-inputs arg-method-inputs arg-classes arg-types]))) + + _ + (:: Monad wrap [(list) (list) (list) (list)]))) + +(def: (member-def-return mode type-params class member) + (-> Primitive-Mode (List TypeParam) ClassDecl ImportMemberDecl (Lux AST)) + (case member + (#ConstructorDecl _) + (:: Monad wrap (class-decl-type$ class)) + + (#MethodDecl [_ method]) + (:: Monad wrap (class->type mode type-params (get@ #import-method-return method))) + + _ + (compiler;fail "Only methods have return values."))) + +(def: (decorate-return-maybe member [return-type return-term]) + (-> ImportMemberDecl [AST AST] [AST AST]) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ #import-member-maybe? commons) + [(` (Maybe (~ return-type))) + (` (??? (~ return-term)))] + [return-type + (let [g!temp (ast;symbol ["" "Ω"])] + (` (let [(~ g!temp) (~ return-term)] + (if (null? (:! (host (~' java.lang.Object)) + (~ g!temp))) + (error! "Can't produce null references from method calls.") + (~ g!temp)))))]) + + _ + [return-type return-term])) + +(do-template [ ] + [(def: ( member [return-type return-term]) + (-> ImportMemberDecl [AST AST] [AST AST]) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ commons) + [ ] + [return-type return-term]) + + _ + [return-type return-term]))] + + [decorate-return-try #import-member-try? (` (Either Text (~ return-type))) (` (try (~ return-term)))] + [decorate-return-io #import-member-io? (` (IO (~ return-type))) (` (io (~ return-term)))] + ) + +(def: (free-type-param? [name bounds]) + (-> TypeParam Bool) + (case bounds + #;Nil true + _ false)) + +(def: (type-param->type-arg [name _]) + (-> TypeParam AST) + (ast;symbol ["" name])) + +(def: (with-mode-output mode output-type body) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + body + + #AutoPrM + (case output-type + (#GenericClass ["byte" _]) + (` (b2l (~ body))) + + (#GenericClass ["short" _]) + (` (s2l (~ body))) + + (#GenericClass ["int" _]) + (` (i2l (~ body))) + + (#GenericClass ["float" _]) + (` (f2d (~ body))) + + _ + body))) + +(def: (auto-conv-class? class) + (-> Text Bool) + (case class + (^or "byte" "short" "int" "float") + true + + _ + false)) + +(def: (auto-conv [class var]) + (-> [Text AST] (List AST)) + (case class + "byte" (list var (` (l2b (~ var)))) + "short" (list var (` (l2s (~ var)))) + "int" (list var (` (l2i (~ var)))) + "float" (list var (` (d2f (~ var)))) + _ (list))) + +(def: (with-mode-inputs mode inputs body) + (-> Primitive-Mode (List [Text AST]) AST AST) + (case mode + #ManualPrM + body + + #AutoPrM + (` (let [(~@ (|> inputs + (List/map auto-conv) + List/join))] + (~ body))))) + +(def: (with-mode-field-get mode class output) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + output + + #AutoPrM + (case (simple-class$ (list) class) + "byte" (` (b2l (~ output))) + "short" (` (s2l (~ output))) + "int" (` (i2l (~ output))) + "float" (` (f2d (~ output))) + _ output))) + +(def: (with-mode-field-set mode class input) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + input + + #AutoPrM + (case (simple-class$ (list) class) + "byte" (` (l2b (~ input))) + "short" (` (l2s (~ input))) + "int" (` (l2i (~ input))) + "float" (` (d2f (~ input))) + _ input))) + +(def: (member-def-interop type-params kind class [arg-lambda-inputs arg-method-inputs arg-classes arg-types] member method-prefix) + (-> (List TypeParam) ClassKind ClassDecl [(List AST) (List AST) (List Text) (List AST)] ImportMemberDecl Text (Lux (List AST))) + (let [[full-name class-tvars] class + all-params (|> (member-type-vars class-tvars member) + (filter free-type-param?) + (map type-param->type-arg))] + (case member + (#EnumDecl enum-members) + (do Monad + [#let [enum-type (: AST + (case class-tvars + #;Nil + (` (host (~ (ast;symbol ["" full-name])))) + + _ + (let [=class-tvars (|> class-tvars + (filter free-type-param?) + (map type-param->type-arg))] + (` (All [(~@ =class-tvars)] (host (~ (ast;symbol ["" full-name])) [(~@ =class-tvars)])))))) + getter-interop (: (-> Text AST) + (lambda [name] + (let [getter-name (ast;symbol ["" (format method-prefix member-separator name)])] + (` (def: (~ getter-name) + (~ enum-type) + (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" name)))] []))))))]] + (wrap (map getter-interop enum-members))) + + (#ConstructorDecl [commons _]) + (do Monad + [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) + #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) + def-params (list (ast;tuple arg-lambda-inputs)) + jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" full-name ":" (text;join-with "," arg-classes))))] + [(~@ arg-method-inputs)])) + (with-mode-inputs (get@ #import-member-mode commons) + (list;zip2 arg-classes arg-lambda-inputs))) + [return-type jvm-interop] (|> [return-type jvm-interop] + (decorate-return-maybe member) + (decorate-return-try member) + (decorate-return-io member))]] + (wrap (list (` (def: ((~ def-name) (~@ def-params)) + (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type))) + (~ jvm-interop)))))) + + (#MethodDecl [commons method]) + (with-gensyms [g!obj] + (do @ + [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) + #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) + (^slots [#import-member-kind]) commons + (^slots [#import-method-name]) method + [jvm-op obj-ast class-ast] (: [Text (List AST) (List AST)] + (case import-member-kind + #StaticIMK + ["invokestatic" + (list) + (list)] + + #VirtualIMK + (case kind + #Class + ["invokevirtual" + (list g!obj) + (list (class-decl-type$ class))] + + #Interface + ["invokeinterface" + (list g!obj) + (list (class-decl-type$ class))] + ))) + def-params (#;Cons (ast;tuple arg-lambda-inputs) obj-ast) + def-param-types (#;Cons (` [(~@ arg-types)]) class-ast) + jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format jvm-op ":" full-name ":" import-method-name + ":" (text;join-with "," arg-classes))))] + [(~@ obj-ast) (~@ arg-method-inputs)])) + (with-mode-output (get@ #import-member-mode commons) + (get@ #import-method-return method)) + (with-mode-inputs (get@ #import-member-mode commons) + (list;zip2 arg-classes arg-lambda-inputs))) + [return-type jvm-interop] (|> [return-type jvm-interop] + (decorate-return-maybe member) + (decorate-return-try member) + (decorate-return-io member))]] + (wrap (list (` (def: ((~ def-name) (~@ def-params)) + (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type))) + (~ jvm-interop))))))) + + (#FieldAccessDecl fad) + (do Monad + [#let [(^open) fad + base-gtype (class->type import-field-mode type-params import-field-type) + g!class (class-decl-type$ class) + g!type (if import-field-maybe? + (` (Maybe (~ base-gtype))) + base-gtype) + tvar-asts (: (List AST) + (|> class-tvars + (filter free-type-param?) + (map type-param->type-arg))) + getter-name (ast;symbol ["" (format method-prefix member-separator import-field-name)]) + setter-name (ast;symbol ["" (format method-prefix member-separator import-field-name "!")])] + getter-interop (with-gensyms [g!obj] + (let [getter-call (if import-field-static? + getter-name + (` ((~ getter-name) (~ g!obj)))) + getter-type (if import-field-setter? + (` (IO (~ g!type))) + g!type) + getter-type (if import-field-static? + getter-type + (` (-> (~ g!class) (~ getter-type)))) + getter-type (` (All [(~@ tvar-asts)] (~ getter-type))) + getter-body (if import-field-static? + (with-mode-field-get import-field-mode import-field-type + (` (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" import-field-name)))] []))) + (with-mode-field-get import-field-mode import-field-type + (` (;_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" full-name ":" import-field-name)))] [(~ g!obj)])))) + getter-body (if import-field-maybe? + (` (??? (~ getter-body))) + getter-body) + getter-body (if import-field-setter? + (` (io (~ getter-body))) + getter-body)] + (wrap (` (def: (~ getter-call) + (~ getter-type) + (~ getter-body)))))) + setter-interop (if import-field-setter? + (with-gensyms [g!obj g!value] + (let [setter-call (if import-field-static? + (` ((~ setter-name) (~ g!value))) + (` ((~ setter-name) (~ g!value) (~ g!obj)))) + setter-type (if import-field-static? + (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit)))) + (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit))))) + setter-value (with-mode-field-set import-field-mode import-field-type g!value) + setter-value (if import-field-maybe? + (` (!!! (~ setter-value))) + setter-value) + setter-command (format (if import-field-static? "putstatic" "putfield") + ":" full-name ":" import-field-name)] + (wrap (: (List AST) + (list (` (def: (~ setter-call) + (~ setter-type) + (io (;_lux_proc ["jvm" (~ (ast;text setter-command))] + [(~ setter-value)]))))))))) + (wrap (list)))] + (wrap (list& getter-interop setter-interop))) + ))) + +(def: (member-import$ type-params long-name? kind class member) + (-> (List TypeParam) Bool ClassKind ClassDecl ImportMemberDecl (Lux (List AST))) + (let [[full-name _] class + method-prefix (if long-name? + full-name + (short-class-name full-name))] + (do Monad + [=args (member-def-arg-bindings type-params class member)] + (member-def-interop type-params kind class =args member method-prefix)))) + +(def: (interface? class) + (All [a] (-> (host java.lang.Class [a]) Bool)) + (_lux_proc ["jvm" "invokevirtual:java.lang.Class:isInterface:"] [class])) + +(def: (load-class class-name) + (-> Text (Either Text (host java.lang.Class [(Ex [a] a)]))) + (try (_lux_proc ["jvm" "invokestatic:java.lang.Class:forName:java.lang.String"] [class-name]))) + +(def: (class-kind [class-name _]) + (-> ClassDecl (Lux ClassKind)) + (case (load-class class-name) + (#;Right class) + (:: Monad wrap (if (interface? class) + #Interface + #Class)) + + (#;Left _) + (compiler;fail (format "Unknown class: " class-name)))) + +(syntax: #export (jvm-import [#let [imports (class-imports *compiler*)]] + [long-name? (s;this? (' #long))] + [class-decl (class-decl^ imports)] + [#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]] + [members (s;some (import-member-decl^ imports (product;right class-decl)))]) + {#;doc (doc "Allows importing JVM classes, and using them as types." + "Their methods, fields and enum options can also be imported." + "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes." + "Examples:" + (jvm-import java.lang.Object + (new []) + (equals [Object] boolean) + (wait [int] #io #try void)) + "Special options can also be given for the return values." + "#? means that the values will be returned inside a Maybe type. That way, null becomes #;None." + "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type." + "#io means the computation has side effects, and will be wrapped by the IO type." + "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." + (jvm-import java.lang.String + (new [(Array byte)]) + (#static valueOf [char] String) + (#static valueOf #as int-valueOf [int] String)) + + (jvm-import #long (java.util.List e) + (size [] int) + (get [int] e)) + + (jvm-import (java.util.ArrayList a) + ([T] toArray [(Array T)] (Array T))) + "#long makes it so the class-type that is generated is of the fully-qualified name." + "In this case, it avoids a clash between the java.util.List type, and Lux's own List type." + (jvm-import java.lang.Character$UnicodeScript + (#enum ARABIC CYRILLIC LATIN)) + "All enum options to be imported must be specified." + + (jvm-import #long (lux.concurrency.promise.JvmPromise A) + (resolve [A] boolean) + (poll [] A) + (wasResolved [] boolean) + (waitOn [lux.Function] void) + (#static [A] make [A] (JvmPromise A))) + "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." + "Lux types, such as Maybe can't be named (otherwise, they'd be confused for Java classes)." + + "Also, the names of the imported members will look like ClassName.MemberName." + "E.g.:" + (Object.new []) + (Object.equals [other-object] my-object) + (java.util.List.size [] my-list) + Character$UnicodeScript.LATIN + )} + (do Monad + [kind (class-kind class-decl) + =members (mapM @ (member-import$ (product;right class-decl) long-name? kind class-decl) members)] + (wrap (list& (class-import$ long-name? class-decl) (List/join =members))))) + +(syntax: #export (array [#let [imports (class-imports *compiler*)]] + [type (generic-type^ imports (list))] + size) + {#;doc (doc "Create an array of the given type, with the given size." + (array Object +10))} + (case type + (^template [ ] + (^ (#GenericClass (list))) + (wrap (list (` (;_lux_proc ["jvm" ] [(~ size)]))))) + (["boolean" "znewarray"] + ["byte" "bnewarray"] + ["short" "snewarray"] + ["int" "inewarray"] + ["long" "lnewarray"] + ["float" "fnewarray"] + ["double" "dnewarray"] + ["char" "cnewarray"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "anewarray"] [(~ (ast;text (generic-type$ type))) (~ size)])))))) + +(syntax: #export (array-length array) + {#;doc (doc "Gives the length of an array." + (array-length my-array))} + (wrap (list (` (;_lux_proc ["jvm" "arraylength"] [(~ array)]))))) + +(def: (type->class-name type) + (-> Type (Lux Text)) + (case type + (#;HostT name params) + (:: Monad wrap name) + + (#;AppT F A) + (case (type;apply-type F A) + #;None + (compiler;fail (format "Can't apply type: " (type;to-text F) " to " (type;to-text A))) + + (#;Some type') + (type->class-name type')) + + (#;NamedT _ type') + (type->class-name type') + + #;UnitT + (:: Monad wrap "java.lang.Object") + + (^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;LambdaT _) (#;UnivQ _) (#;ExQ _)) + (compiler;fail (format "Can't convert to JvmType: " (type;to-text type))) + )) + +(syntax: #export (array-load idx array) + {#;doc (doc "Loads an element from an array." + (array-load 10 my-array))} + (case array + [_ (#;SymbolS array-name)] + (do Monad + [array-type (compiler;find-type array-name) + array-jvm-type (type->class-name array-type)] + (case array-jvm-type + (^template [ ] + + (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx)]))))) + (["[Z" "zaload"] + ["[B" "baload"] + ["[S" "saload"] + ["[I" "iaload"] + ["[J" "jaload"] + ["[F" "faload"] + ["[D" "daload"] + ["[C" "caload"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "aaload"] [(~ array) (~ idx)])))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (;;array-load (~ g!array) (~ idx))))))))) + +(syntax: #export (array-store idx value array) + {#;doc (doc "Stores an element into an array." + (array-store 10 my-object my-array))} + (case array + [_ (#;SymbolS array-name)] + (do Monad + [array-type (compiler;find-type array-name) + array-jvm-type (type->class-name array-type)] + (case array-jvm-type + (^template [ ] + + (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx) (~ value)]))))) + (["[Z" "zastore"] + ["[B" "bastore"] + ["[S" "sastore"] + ["[I" "iastore"] + ["[J" "jastore"] + ["[F" "fastore"] + ["[D" "dastore"] + ["[C" "castore"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "aastore"] [(~ array) (~ idx) (~ value)])))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (;;array-store (~ g!array) (~ idx) (~ value))))))))) + +(def: simple-bindings^ + (Syntax (List [Text AST])) + (s;tuple (s;some (s;seq s;local-symbol s;any)))) + +(syntax: #export (with-open [bindings simple-bindings^] body) + {#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)." + "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body." + (with-open [my-res1 (res1-constructor ...) + my-res2 (res1-constructor ...)] + (do Monad + [foo (do-something my-res1) + bar (do-something-else my-res2)] + (do-one-last-thing foo bar))))} + (with-gensyms [g!output g!_] + (let [inits (List/join (List/map (lambda [[res-name res-ctor]] + (list (ast;symbol ["" res-name]) res-ctor)) + bindings)) + closes (List/map (lambda [res] + (` (try (;_lux_proc ["jvm" "invokevirtual:java.io.Closeable:close:"] + [(~ (ast;symbol ["" (product;left res)]))])))) + bindings)] + (wrap (list (` (do Monad + [(~@ inits) + (~ g!output) (~ body) + (~' #let) [(~ g!_) (exec (~@ (reverse closes)) [])]] + ((~' wrap) (~ g!output))))))))) + +(syntax: #export (class-for [#let [imports (class-imports *compiler*)]] + [type (generic-type^ imports (list))]) + {#;doc (doc "Loads the class as a java.lang.Class object." + (class-for java.lang.String))} + (wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (ast;text (simple-class$ (list) type)))]))))) + +(def: get-compiler + (Lux Compiler) + (lambda [compiler] + (#;Right [compiler compiler]))) + +(def: (fully-qualify-class-name+ imports name) + (-> ClassImports Text (Maybe Text)) + (cond (fully-qualified-class-name? name) + (#;Some name) + + (member? text;Eq java.lang-classes name) + (#;Some (format "java.lang." name)) + + ## else + (get-import name imports))) + +(def: #export (resolve-class class) + {#;doc (doc "Given a potentially unqualified class name, qualifies it if necessary." + (resolve-class "String") + => + "java.lang.String")} + (-> Text (Lux Text)) + (do Monad + [*compiler* get-compiler] + (case (fully-qualify-class-name+ (class-imports *compiler*) class) + (#;Some fqcn) + (wrap fqcn) + + #;None + (compiler;fail (Text/append "Unknown class: " class))))) diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.lux deleted file mode 100644 index 41d567165..000000000 --- a/stdlib/source/lux/host.lux +++ /dev/null @@ -1,2169 +0,0 @@ -(;module: - lux - (lux (control monad - [enum]) - [io #+ IO Monad io] - (codata function) - (data (coll [list #* "" Functor Fold "List/" Monad Monoid] - [array #+ Array]) - number - maybe - [product] - [text "Text/" Eq Monoid] - text/format - [bool "Bool/" Codec]) - [compiler #+ with-gensyms Functor Monad] - (macro [ast] - ["s" syntax #+ syntax: Syntax]) - [type] - )) - -(do-template [ ] - [(def: #export ( value) - {#;doc (doc "Type converter." - "From:" - - "To:" - )} - (-> (host ) (host )) - (_lux_proc ["jvm" ] [value]))] - - [b2l "b2l" java.lang.Byte java.lang.Long] - - [s2l "s2l" java.lang.Short java.lang.Long] - - [d2i "d2i" java.lang.Double java.lang.Integer] - [d2l "d2l" java.lang.Double java.lang.Long] - [d2f "d2f" java.lang.Double java.lang.Float] - - [f2i "f2i" java.lang.Float java.lang.Integer] - [f2l "f2l" java.lang.Float java.lang.Long] - [f2d "f2d" java.lang.Float java.lang.Double] - - [i2b "i2b" java.lang.Integer java.lang.Byte] - [i2s "i2s" java.lang.Integer java.lang.Short] - [i2l "i2l" java.lang.Integer java.lang.Long] - [i2f "i2f" java.lang.Integer java.lang.Float] - [i2d "i2d" java.lang.Integer java.lang.Double] - [i2c "i2c" java.lang.Integer java.lang.Character] - - [l2b "l2b" java.lang.Long java.lang.Byte] - [l2s "l2s" java.lang.Long java.lang.Short] - [l2i "l2i" java.lang.Long java.lang.Integer] - [l2f "l2f" java.lang.Long java.lang.Float] - [l2d "l2d" java.lang.Long java.lang.Double] - - [c2b "c2b" java.lang.Character java.lang.Byte] - [c2s "c2s" java.lang.Character java.lang.Short] - [c2i "c2i" java.lang.Character java.lang.Integer] - [c2l "c2l" java.lang.Character java.lang.Long] - ) - -## [Utils] -(def: array-type-name "#Array") -(def: constructor-method-name "") -(def: member-separator ".") - -## Types -(do-template [ ] - [(type: #export - (#;HostT #;Nil))] - - ["[Z" Boolean-Array] - ["[B" Byte-Array] - ["[S" Short-Array] - ["[I" Int-Array] - ["[J" Long-Array] - ["[F" Float-Array] - ["[D" Double-Array] - ["[C" Char-Array] - ) - -(type: Code Text) - -(type: BoundKind - #UpperBound - #LowerBound) - -(type: #rec GenericType - (#GenericTypeVar Text) - (#GenericClass [Text (List GenericType)]) - (#GenericArray GenericType) - (#GenericWildcard (Maybe [BoundKind GenericType]))) - -(type: TypeParam - [Text (List GenericType)]) - -(type: Primitive-Mode - #ManualPrM - #AutoPrM) - -(type: PrivacyModifier - #PublicPM - #PrivatePM - #ProtectedPM - #DefaultPM) - -(type: StateModifier - #VolatileSM - #FinalSM - #DefaultSM) - -(type: InheritanceModifier - #FinalIM - #AbstractIM - #DefaultIM) - -(type: ClassKind - #Class - #Interface) - -(type: ClassDecl - {#class-name Text - #class-params (List TypeParam)}) - -(type: StackFrame (host java.lang.StackTraceElement)) -(type: StackTrace (Array StackFrame)) - -(type: SuperClassDecl - {#super-class-name Text - #super-class-params (List GenericType)}) - -(type: AnnotationParam - [Text AST]) - -(type: Annotation - {#ann-name Text - #ann-params (List AnnotationParam)}) - -(type: MemberDecl - {#member-name Text - #member-privacy PrivacyModifier - #member-anns (List Annotation)}) - -(type: FieldDecl - (#ConstantField GenericType AST) - (#VariableField StateModifier GenericType)) - -(type: MethodDecl - {#method-tvars (List TypeParam) - #method-inputs (List GenericType) - #method-output GenericType - #method-exs (List GenericType)}) - -(type: ArgDecl - {#arg-name Text - #arg-type GenericType}) - -(type: ConstructorArg - [GenericType AST]) - -(type: MethodDef - (#ConstructorMethod [Bool - (List TypeParam) - (List ArgDecl) - (List ConstructorArg) - AST - (List GenericType)]) - (#VirtualMethod [Bool - Bool - (List TypeParam) - (List ArgDecl) - GenericType - AST - (List GenericType)]) - (#OverridenMethod [Bool - ClassDecl - (List TypeParam) - (List ArgDecl) - GenericType - AST - (List GenericType)]) - (#StaticMethod [Bool - (List TypeParam) - (List ArgDecl) - GenericType - AST - (List GenericType)]) - (#AbstractMethod [(List TypeParam) - (List ArgDecl) - GenericType - (List GenericType)]) - (#NativeMethod [(List TypeParam) - (List ArgDecl) - GenericType - (List GenericType)])) - -(type: PartialCall - {#pc-method AST - #pc-args AST}) - -(type: ImportMethodKind - #StaticIMK - #VirtualIMK) - -(type: ImportMethodCommons - {#import-member-mode Primitive-Mode - #import-member-alias Text - #import-member-kind ImportMethodKind - #import-member-tvars (List TypeParam) - #import-member-args (List [Bool GenericType]) - #import-member-maybe? Bool - #import-member-try? Bool - #import-member-io? Bool}) - -(type: ImportConstructorDecl - {}) - -(type: ImportMethodDecl - {#import-method-name Text - #import-method-return GenericType}) - -(type: ImportFieldDecl - {#import-field-mode Primitive-Mode - #import-field-name Text - #import-field-static? Bool - #import-field-maybe? Bool - #import-field-setter? Bool - #import-field-type GenericType}) - -(type: ImportMemberDecl - (#EnumDecl (List Text)) - (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) - (#MethodDecl [ImportMethodCommons ImportMethodDecl]) - (#FieldAccessDecl ImportFieldDecl)) - -(type: ClassImports - (List [Text Text])) - -## Utils -(def: (short-class-name name) - (-> Text Text) - (case (reverse (text;split-all-with "." name)) - (#;Cons short-name _) - short-name - - #;Nil - name)) - -(def: (manual-primitive-to-type class) - (-> Text (Maybe AST)) - (case class - (^template [ ] - - (#;Some (' ))) - (["boolean" (;^ java.lang.Boolean)] - ["byte" (;^ java.lang.Byte)] - ["short" (;^ java.lang.Short)] - ["int" (;^ java.lang.Integer)] - ["long" (;^ java.lang.Long)] - ["float" (;^ java.lang.Float)] - ["double" (;^ java.lang.Double)] - ["char" (;^ java.lang.Character)] - ["void" ;Unit]) - - _ - #;None)) - -(def: (auto-primitive-to-type class) - (-> Text (Maybe AST)) - (case class - (^template [ ] - - (#;Some (' ))) - (["boolean" ;Bool] - ["byte" ;Int] - ["short" ;Int] - ["int" ;Int] - ["long" ;Int] - ["float" ;Real] - ["double" ;Real] - ["char" ;Char] - ["void" ;Unit]) - - _ - #;None)) - -(def: (generic-class->type' mode type-params in-array? name+params - class->type') - (-> Primitive-Mode (List TypeParam) Bool [Text (List GenericType)] - (-> Primitive-Mode (List TypeParam) Bool GenericType AST) - AST) - (case [name+params mode in-array?] - (^=> [[prim #;Nil] #ManualPrM false] - [(manual-primitive-to-type prim) (#;Some output)]) - output - - (^=> [[prim #;Nil] #AutoPrM false] - [(auto-primitive-to-type prim) (#;Some output)]) - output - - [[name params] _ _] - (let [=params (map (class->type' mode type-params in-array?) params)] - (` (host (~ (ast;symbol ["" name])) [(~@ =params)]))))) - -(def: (class->type' mode type-params in-array? class) - (-> Primitive-Mode (List TypeParam) Bool GenericType AST) - (case class - (#GenericTypeVar name) - (case (find (lambda [[pname pbounds]] - (and (Text/= name pname) - (not (list;empty? pbounds)))) - type-params) - #;None - (ast;symbol ["" name]) - - (#;Some [pname pbounds]) - (class->type' mode type-params in-array? (default (undefined) (list;head pbounds)))) - - (#GenericClass name+params) - (generic-class->type' mode type-params in-array? name+params - class->type') - - (#GenericArray param) - (let [=param (class->type' mode type-params true param)] - (` (host (~ (ast;symbol ["" array-type-name])) [(~ =param)]))) - - (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) - (' (;Ex [*] *)) - - (#GenericWildcard (#;Some [#UpperBound upper-bound])) - (class->type' mode type-params in-array? upper-bound) - )) - -(def: (class->type mode type-params class) - (-> Primitive-Mode (List TypeParam) GenericType AST) - (class->type' mode type-params false class)) - -(def: (type-param-type$ [name bounds]) - (-> TypeParam AST) - (ast;symbol ["" name])) - -(def: (class-decl-type$ (^slots [#class-name #class-params])) - (-> ClassDecl AST) - (let [=params (map (: (-> TypeParam AST) - (lambda [[pname pbounds]] - (case pbounds - #;Nil - (ast;symbol ["" pname]) - - (#;Cons bound1 _) - (class->type #ManualPrM class-params bound1)))) - class-params)] - (` (host (~ (ast;symbol ["" class-name])) [(~@ =params)])))) - -(def: (stack-trace->text trace) - (-> StackTrace Text) - (let [size (_lux_proc ["jvm" "arraylength"] [trace]) - idxs (list;n.range +0 (n.dec size))] - (|> idxs - (map (: (-> Nat Text) - (lambda [idx] - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] - [(_lux_proc ["jvm" "aaload"] [trace idx])])))) - (text;join-with "\n") - ))) - -(def: (get-stack-trace t) - (-> (host java.lang.Throwable) StackTrace) - (_lux_proc ["jvm" "invokevirtual:java.lang.Throwable:getStackTrace:"] [t])) - -(def: #hidden (throwable->text t) - (All [a] (-> (host java.lang.Throwable) (Either Text a))) - (#;Left (format (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [t]) - "\n" - (|> t get-stack-trace stack-trace->text)))) - -(def: empty-imports - ClassImports - (list)) - -(def: (get-import name imports) - (-> Text ClassImports (Maybe Text)) - (:: Functor map product;right - (find (|>. product;left (Text/= name)) - imports))) - -(def: (add-import short+full imports) - (-> [Text Text] ClassImports ClassImports) - (#;Cons short+full imports)) - -(def: (class-imports compiler) - (-> Compiler ClassImports) - (case (compiler;run compiler - (: (Lux ClassImports) - (do Monad - [current-module compiler;current-module-name - defs (compiler;defs current-module)] - (wrap (fold (: (-> [Text Def] ClassImports ClassImports) - (lambda [[short-name [_ meta _]] imports] - (case (compiler;get-text-ann (ident-for #;;jvm-class) meta) - (#;Some full-class-name) - (add-import [short-name full-class-name] imports) - - _ - imports))) - empty-imports - defs))))) - (#;Left _) (list) - (#;Right imports) imports)) - -(def: java.lang-classes - (List Text) - (list ## Interfaces - "Appendable" - "AutoCloseable" - "CharSequence" - "Cloneable" - "Comparable" - "Iterable" - "Readable" - "Runnable" - - ## Classes - "Boolean" - "Byte" - "Character" - "Class" - "ClassLoader" - "ClassValue" - "Compiler" - "Double" - "Enum" - "Float" - "InheritableThreadLocal" - "Integer" - "Long" - "Math" - "Number" - "Object" - "Package" - "Process" - "ProcessBuilder" - "Runtime" - "RuntimePermission" - "SecurityManager" - "Short" - "StackTraceElement" - "StrictMath" - "String" - "StringBuffer" - "StringBuilder" - "System" - "Thread" - "ThreadGroup" - "ThreadLocal" - "Throwable" - "Void" - - ## Exceptions - "ArithmeticException" - "ArrayIndexOutOfBoundsException" - "ArrayStoreException" - "ClassCastException" - "ClassNotFoundException" - "CloneNotSupportedException" - "EnumConstantNotPresentException" - "Exception" - "IllegalAccessException" - "IllegalArgumentException" - "IllegalMonitorStateException" - "IllegalStateException" - "IllegalThreadStateException" - "IndexOutOfBoundsException" - "InstantiationException" - "InterruptedException" - "NegativeArraySizeException" - "NoSuchFieldException" - "NoSuchMethodException" - "NullPointerException" - "NumberFormatException" - "ReflectiveOperationException" - "RuntimeException" - "SecurityException" - "StringIndexOutOfBoundsException" - "TypeNotPresentException" - "UnsupportedOperationException" - - ## Annotations - "Deprecated" - "Override" - "SafeVarargs" - "SuppressWarnings")) - -(def: (fully-qualified-class-name? name) - (-> Text Bool) - (text;contains? "." name)) - -(def: (fully-qualify-class-name imports name) - (-> ClassImports Text Text) - (cond (fully-qualified-class-name? name) - name - - (member? text;Eq java.lang-classes name) - (format "java.lang." name) - - ## else - (default name (get-import name imports)))) - -(def: type-var-class Text "java.lang.Object") - -(def: (simple-class$ params class) - (-> (List TypeParam) GenericType Text) - (case class - (#GenericTypeVar name) - (case (find (lambda [[pname pbounds]] - (and (Text/= name pname) - (not (list;empty? pbounds)))) - params) - #;None - type-var-class - - (#;Some [pname pbounds]) - (simple-class$ params (default (undefined) (list;head pbounds)))) - - (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) - type-var-class - - (#GenericWildcard (#;Some [#UpperBound upper-bound])) - (simple-class$ params upper-bound) - - (#GenericClass name params) - name - - (#GenericArray param') - (case param' - (#GenericArray param) - (format "[" (simple-class$ params param)) - - (^template [ ] - (#GenericClass #;Nil) - ) - (["boolean" "[Z"] - ["byte" "[B"] - ["short" "[S"] - ["int" "[I"] - ["long" "[J"] - ["float" "[F"] - ["double" "[D"] - ["char" "[C"]) - - param - (format "[L" (simple-class$ params param) ";")) - )) - -(def: (make-get-const-parser class-name field-name) - (-> Text Text (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." field-name)] - _ (s;this! (ast;symbol ["" dotted-name]))] - (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" class-name ":" field-name)))] []))))) - -(def: (make-get-var-parser class-name field-name) - (-> Text Text (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." field-name)] - _ (s;this! (ast;symbol ["" dotted-name]))] - (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this]))))) - -(def: (make-put-var-parser class-name field-name) - (-> Text Text (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." field-name)] - [_ _ value] (: (Syntax [Unit Unit AST]) - (s;form ($_ s;seq (s;this! (' :=)) (s;this! (ast;symbol ["" dotted-name])) s;any)))] - (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)]))))) - -(def: (pre-walk-replace f input) - (-> (-> AST AST) AST AST) - (case (f input) - (^template [] - [meta ( parts)] - [meta ( (map (pre-walk-replace f) parts))]) - ([#;FormS] - [#;TupleS]) - - [meta (#;RecordS pairs)] - [meta (#;RecordS (map (: (-> [AST AST] [AST AST]) - (lambda [[key val]] - [(pre-walk-replace f key) (pre-walk-replace f val)])) - pairs))] - - ast' - ast')) - -(def: (parser->replacer p ast) - (-> (Syntax AST) (-> AST AST)) - (case (s;run (list ast) p) - (#;Right [#;Nil ast']) - ast' - - _ - ast - )) - -(def: (field->parser class-name [[field-name _ _] field]) - (-> Text [MemberDecl FieldDecl] (Syntax AST)) - (case field - (#ConstantField _) - (make-get-const-parser class-name field-name) - - (#VariableField _) - (s;either (make-get-var-parser class-name field-name) - (make-put-var-parser class-name field-name)))) - -(def: (make-constructor-parser params class-name arg-decls) - (-> (List TypeParam) Text (List ArgDecl) (Syntax AST)) - (do s;Monad - [[_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;this! (' .new!)) (s;tuple (s;exactly (list;size arg-decls) s;any))))) - #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] - (wrap (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))] - [(~@ args)]))))) - -(def: (make-static-method-parser params class-name method-name arg-decls) - (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." method-name "!")] - [_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) - #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] - (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] - [(~@ args)]))))) - -(do-template [ ] - [(def: ( params class-name method-name arg-decls) - (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." method-name "!")] - [_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) - #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] - (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] - [(~' _jvm_this) (~@ args)])))))] - - [make-special-method-parser "invokespecial"] - [make-virtual-method-parser "invokevirtual"] - ) - -(def: (method->parser params class-name [[method-name _ _] meth-def]) - (-> (List TypeParam) Text [MemberDecl MethodDef] (Syntax AST)) - (case meth-def - (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) - (make-constructor-parser params class-name args) - - (#StaticMethod strict? type-vars args return-type return-expr exs) - (make-static-method-parser params class-name method-name args) - - (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs)) - (make-special-method-parser params class-name method-name args) - - (#AbstractMethod type-vars args return-type exs) - (make-virtual-method-parser params class-name method-name args) - - (#NativeMethod type-vars args return-type exs) - (make-virtual-method-parser params class-name method-name args))) - -## Syntaxs -(def: (full-class-name^ imports) - (-> ClassImports (Syntax Text)) - (do s;Monad - [name s;local-symbol] - (wrap (fully-qualify-class-name imports name)))) - -(def: privacy-modifier^ - (Syntax PrivacyModifier) - (let [(^open) s;Monad] - ($_ s;alt - (s;this! (' #public)) - (s;this! (' #private)) - (s;this! (' #protected)) - (wrap [])))) - -(def: inheritance-modifier^ - (Syntax InheritanceModifier) - (let [(^open) s;Monad] - ($_ s;alt - (s;this! (' #final)) - (s;this! (' #abstract)) - (wrap [])))) - -(def: bound-kind^ - (Syntax BoundKind) - (s;alt (s;this! (' <)) - (s;this! (' >)))) - -(def: (generic-type^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax GenericType)) - ($_ s;either - (do s;Monad - [_ (s;this! (' ?))] - (wrap (#GenericWildcard #;None))) - (s;tuple (do s;Monad - [_ (s;this! (' ?)) - bound-kind bound-kind^ - bound (generic-type^ imports type-vars)] - (wrap (#GenericWildcard (#;Some [bound-kind bound]))))) - (do s;Monad - [name (full-class-name^ imports)] - (let% [ (do-template [ ] - [(Text/= name) - (wrap (#GenericClass (list)))] - - ["[Z" "Boolean-Array"] - ["[B" "Byte-Array"] - ["[S" "Short-Array"] - ["[I" "Int-Array"] - ["[J" "Long-Array"] - ["[F" "Float-Array"] - ["[D" "Double-Array"] - ["[C" "Char-Array"])] - (cond (member? text;Eq (map product;left type-vars) name) - (wrap (#GenericTypeVar name)) - - - - ## else - (wrap (#GenericClass name (list)))))) - (s;form (do s;Monad - [name (s;this! (' Array)) - component (generic-type^ imports type-vars)] - (case component - (^template [ ] - (#GenericClass #;Nil) - (wrap (#GenericClass (list)))) - (["[Z" "boolean"] - ["[B" "byte"] - ["[S" "short"] - ["[I" "int"] - ["[J" "long"] - ["[F" "float"] - ["[D" "double"] - ["[C" "char"]) - - _ - (wrap (#GenericArray component))))) - (s;form (do s;Monad - [name (full-class-name^ imports) - params (s;some (generic-type^ imports type-vars)) - _ (s;assert (format name " can't be a type-parameter!") - (not (member? text;Eq (map product;left type-vars) name)))] - (wrap (#GenericClass name params)))) - )) - -(def: (type-param^ imports) - (-> ClassImports (Syntax TypeParam)) - (s;either (do s;Monad - [param-name s;local-symbol] - (wrap [param-name (list)])) - (s;tuple (do s;Monad - [param-name s;local-symbol - _ (s;this! (' <)) - bounds (s;many (generic-type^ imports (list)))] - (wrap [param-name bounds]))))) - -(def: (type-params^ imports) - (-> ClassImports (Syntax (List TypeParam))) - (s;tuple (s;some (type-param^ imports)))) - -(def: (class-decl^ imports) - (-> ClassImports (Syntax ClassDecl)) - (s;either (do s;Monad - [name (full-class-name^ imports)] - (wrap [name (list)])) - (s;form (do s;Monad - [name (full-class-name^ imports) - params (s;some (type-param^ imports))] - (wrap [name params]))) - )) - -(def: (super-class-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax SuperClassDecl)) - (s;either (do s;Monad - [name (full-class-name^ imports)] - (wrap [name (list)])) - (s;form (do s;Monad - [name (full-class-name^ imports) - params (s;some (generic-type^ imports type-vars))] - (wrap [name params]))))) - -(def: annotation-params^ - (Syntax (List AnnotationParam)) - (s;record (s;some (s;seq s;local-tag s;any)))) - -(def: (annotation^ imports) - (-> ClassImports (Syntax Annotation)) - (s;either (do s;Monad - [ann-name (full-class-name^ imports)] - (wrap [ann-name (list)])) - (s;form (s;seq (full-class-name^ imports) - annotation-params^)))) - -(def: (annotations^' imports) - (-> ClassImports (Syntax (List Annotation))) - (do s;Monad - [_ (s;this! (' #ann))] - (s;tuple (s;some (annotation^ imports))))) - -(def: (annotations^ imports) - (-> ClassImports (Syntax (List Annotation))) - (do s;Monad - [anns?? (s;opt (annotations^' imports))] - (wrap (default (list) anns??)))) - -(def: (throws-decl'^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List GenericType))) - (do s;Monad - [_ (s;this! (' #throws))] - (s;tuple (s;some (generic-type^ imports type-vars))))) - -(def: (throws-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List GenericType))) - (do s;Monad - [exs? (s;opt (throws-decl'^ imports type-vars))] - (wrap (default (list) exs?)))) - -(def: (method-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl])) - (s;form (do s;Monad - [tvars (s;default (list) (type-params^ imports)) - name s;local-symbol - anns (annotations^ imports) - inputs (s;tuple (s;some (generic-type^ imports type-vars))) - output (generic-type^ imports type-vars) - exs (throws-decl^ imports type-vars)] - (wrap [[name #PublicPM anns] {#method-tvars tvars - #method-inputs inputs - #method-output output - #method-exs exs}])))) - -(def: state-modifier^ - (Syntax StateModifier) - ($_ s;alt - (s;this! (' #volatile)) - (s;this! (' #final)) - (:: s;Monad wrap []))) - -(def: (field-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl])) - (s;either (s;form (do s;Monad - [_ (s;this! (' #const)) - name s;local-symbol - anns (annotations^ imports) - type (generic-type^ imports type-vars) - body s;any] - (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) - (s;form (do s;Monad - [pm privacy-modifier^ - sm state-modifier^ - name s;local-symbol - anns (annotations^ imports) - type (generic-type^ imports type-vars)] - (wrap [[name pm anns] (#VariableField [sm type])]))))) - -(def: (arg-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax ArgDecl)) - (s;tuple (s;seq s;local-symbol - (generic-type^ imports type-vars)))) - -(def: (arg-decls^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List ArgDecl))) - (s;some (arg-decl^ imports type-vars))) - -(def: (constructor-arg^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax ConstructorArg)) - (s;tuple (s;seq (generic-type^ imports type-vars) s;any))) - -(def: (constructor-args^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List ConstructorArg))) - (s;tuple (s;some (constructor-arg^ imports type-vars)))) - -(def: (constructor-method^ imports class-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - strict-fp? (s;this? (' #strict)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars (List/append class-vars method-vars)] - [_ arg-decls] (s;form (s;seq (s;this! (' new)) - (arg-decls^ imports total-vars))) - constructor-args (constructor-args^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports) - body s;any] - (wrap [{#member-name constructor-method-name - #member-privacy pm - #member-anns annotations} - (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)])))) - -(def: (virtual-method-def^ imports class-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - strict-fp? (s;this? (' #strict)) - final? (s;this? (' #final)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars (List/append class-vars method-vars)] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports) - body s;any] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)])))) - -(def: (overriden-method-def^ imports) - (-> ClassImports (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [strict-fp? (s;this? (' #strict)) - owner-class (class-decl^ imports) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars (List/append (product;right owner-class) method-vars)] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports) - body s;any] - (wrap [{#member-name name - #member-privacy #PublicPM - #member-anns annotations} - (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)])))) - -(def: (static-method-def^ imports) - (-> ClassImports (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - strict-fp? (s;this? (' #strict)) - _ (s;this! (' #static)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars method-vars] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports) - body s;any] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)])))) - -(def: (abstract-method-def^ imports) - (-> ClassImports (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - _ (s;this! (' #abstract)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars method-vars] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports)] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#AbstractMethod method-vars arg-decls return-type exs)])))) - -(def: (native-method-def^ imports) - (-> ClassImports (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - _ (s;this! (' #native)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars method-vars] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports)] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#NativeMethod method-vars arg-decls return-type exs)])))) - -(def: (method-def^ imports class-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) - ($_ s;either - (constructor-method^ imports class-vars) - (virtual-method-def^ imports class-vars) - (overriden-method-def^ imports) - (static-method-def^ imports) - (abstract-method-def^ imports) - (native-method-def^ imports))) - -(def: partial-call^ - (Syntax PartialCall) - (s;form (s;seq s;any s;any))) - -(def: class-kind^ - (Syntax ClassKind) - (s;either (do s;Monad - [_ (s;this! (' #class))] - (wrap #Class)) - (do s;Monad - [_ (s;this! (' #interface))] - (wrap #Interface)) - )) - -(def: import-member-alias^ - (Syntax (Maybe Text)) - (s;opt (do s;Monad - [_ (s;this! (' #as))] - s;local-symbol))) - -(def: (import-member-args^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType]))) - (s;tuple (s;some (s;seq (s;this? (' #?)) (generic-type^ imports type-vars))))) - -(def: import-member-return-flags^ - (Syntax [Bool Bool Bool]) - ($_ s;seq (s;this? (' #io)) (s;this? (' #try)) (s;this? (' #?)))) - -(def: primitive-mode^ - (Syntax Primitive-Mode) - (s;alt (s;this! (' #manual)) - (s;this! (' #auto)))) - -(def: (import-member-decl^ imports owner-vars) - (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl)) - ($_ s;either - (s;form (do s;Monad - [_ (s;this! (' #enum)) - enum-members (s;some s;local-symbol)] - (wrap (#EnumDecl enum-members)))) - (s;form (do s;Monad - [tvars (s;default (list) (type-params^ imports)) - _ (s;this! (' new)) - ?alias import-member-alias^ - #let [total-vars (List/append owner-vars tvars)] - ?prim-mode (s;opt primitive-mode^) - args (import-member-args^ imports total-vars) - [io? try? maybe?] import-member-return-flags^] - (wrap (#ConstructorDecl [{#import-member-mode (default #AutoPrM ?prim-mode) - #import-member-alias (default "new" ?alias) - #import-member-kind #VirtualIMK - #import-member-tvars tvars - #import-member-args args - #import-member-maybe? maybe? - #import-member-try? try? - #import-member-io? io?} - {}])) - )) - (s;form (do s;Monad - [kind (: (Syntax ImportMethodKind) - (s;alt (s;this! (' #static)) - (wrap []))) - tvars (s;default (list) (type-params^ imports)) - name s;local-symbol - ?alias import-member-alias^ - #let [total-vars (List/append owner-vars tvars)] - ?prim-mode (s;opt primitive-mode^) - args (import-member-args^ imports total-vars) - [io? try? maybe?] import-member-return-flags^ - return (generic-type^ imports total-vars)] - (wrap (#MethodDecl [{#import-member-mode (default #AutoPrM ?prim-mode) - #import-member-alias (default name ?alias) - #import-member-kind kind - #import-member-tvars tvars - #import-member-args args - #import-member-maybe? maybe? - #import-member-try? try? - #import-member-io? io?} - {#import-method-name name - #import-method-return return - }])))) - (s;form (do s;Monad - [static? (s;this? (' #static)) - name s;local-symbol - ?prim-mode (s;opt primitive-mode^) - gtype (generic-type^ imports owner-vars) - maybe? (s;this? (' #?)) - setter? (s;this? (' #!))] - (wrap (#FieldAccessDecl {#import-field-mode (default #AutoPrM ?prim-mode) - #import-field-name name - #import-field-static? static? - #import-field-maybe? maybe? - #import-field-setter? setter? - #import-field-type gtype})))) - )) - -## Generators -(def: with-parens - (-> Code Code) - (text;enclose ["(" ")"])) - -(def: with-brackets - (-> Code Code) - (text;enclose ["[" "]"])) - -(def: spaced - (-> (List Code) Code) - (text;join-with " ")) - -(def: (privacy-modifier$ pm) - (-> PrivacyModifier Code) - (case pm - #PublicPM "public" - #PrivatePM "private" - #ProtectedPM "protected" - #DefaultPM "default")) - -(def: (inheritance-modifier$ im) - (-> InheritanceModifier Code) - (case im - #FinalIM "final" - #AbstractIM "abstract" - #DefaultIM "default")) - -(def: (annotation-param$ [name value]) - (-> AnnotationParam Code) - (format name "=" (ast;to-text value))) - -(def: (annotation$ [name params]) - (-> Annotation Code) - (format "(" name " " "{" (text;join-with "\t" (map annotation-param$ params)) "}" ")")) - -(def: (bound-kind$ kind) - (-> BoundKind Code) - (case kind - #UpperBound "<" - #LowerBound ">")) - -(def: (generic-type$ gtype) - (-> GenericType Code) - (case gtype - (#GenericTypeVar name) - name - - (#GenericClass name params) - (format "(" name " " (spaced (map generic-type$ params)) ")") - - (#GenericArray param) - (format "(" array-type-name " " (generic-type$ param) ")") - - (#GenericWildcard #;None) - "?" - - (#GenericWildcard (#;Some [bound-kind bound])) - (format (bound-kind$ bound-kind) (generic-type$ bound)))) - -(def: (type-param$ [name bounds]) - (-> TypeParam Code) - (format "(" name " " (spaced (map generic-type$ bounds)) ")")) - -(def: (class-decl$ (^open)) - (-> ClassDecl Code) - (format "(" class-name " " (spaced (map type-param$ class-params)) ")")) - -(def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) - (-> SuperClassDecl Code) - (format "(" super-class-name " " (spaced (map generic-type$ super-class-params)) ")")) - -(def: (method-decl$ [[name pm anns] method-decl]) - (-> [MemberDecl MethodDecl] Code) - (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] - (with-parens - (spaced (list name - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ method-tvars))) - (with-brackets (spaced (map generic-type$ method-exs))) - (with-brackets (spaced (map generic-type$ method-inputs))) - (generic-type$ method-output)) - )))) - -(def: (state-modifier$ sm) - (-> StateModifier Code) - (case sm - #VolatileSM "volatile" - #FinalSM "final" - #DefaultSM "default")) - -(def: (field-decl$ [[name pm anns] field]) - (-> [MemberDecl FieldDecl] Code) - (case field - (#ConstantField class value) - (with-parens - (spaced (list "constant" name - (with-brackets (spaced (map annotation$ anns))) - (generic-type$ class) - (ast;to-text value)) - )) - - (#VariableField sm class) - (with-parens - (spaced (list "variable" name - (privacy-modifier$ pm) - (state-modifier$ sm) - (with-brackets (spaced (map annotation$ anns))) - (generic-type$ class)) - )) - )) - -(def: (arg-decl$ [name type]) - (-> ArgDecl Code) - (with-parens - (spaced (list name (generic-type$ type))))) - -(def: (constructor-arg$ [class term]) - (-> ConstructorArg Code) - (with-brackets - (spaced (list (generic-type$ class) (ast;to-text term))))) - -(def: (method-def$ replacer super-class [[name pm anns] method-def]) - (-> (-> AST AST) SuperClassDecl [MemberDecl MethodDef] Code) - (case method-def - (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs) - (with-parens - (spaced (list "init" - (privacy-modifier$ pm) - (Bool/encode strict-fp?) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (with-brackets (spaced (map constructor-arg$ constructor-args))) - (ast;to-text (pre-walk-replace replacer body)) - ))) - - (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs) - (with-parens - (spaced (list "virtual" - name - (privacy-modifier$ pm) - (Bool/encode final?) - (Bool/encode strict-fp?) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type) - (ast;to-text (pre-walk-replace replacer body))))) - - (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) - (let [super-replacer (parser->replacer (s;form (do s;Monad - [_ (s;this! (' .super!)) - args (s;tuple (s;exactly (list;size arg-decls) s;any)) - #let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right) - arg-decls))]] - (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))] - [(~' _jvm_this) (~@ args)]))))))] - (with-parens - (spaced (list "override" - (class-decl$ class-decl) - name - (Bool/encode strict-fp?) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type) - (|> body - (pre-walk-replace replacer) - (pre-walk-replace super-replacer) - (ast;to-text)) - )))) - - (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) - (with-parens - (spaced (list "static" - name - (privacy-modifier$ pm) - (Bool/encode strict-fp?) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type) - (ast;to-text (pre-walk-replace replacer body))))) - - (#AbstractMethod type-vars arg-decls return-type exs) - (with-parens - (spaced (list "abstract" - name - (privacy-modifier$ pm) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type)))) - - (#NativeMethod type-vars arg-decls return-type exs) - (with-parens - (spaced (list "native" - name - (privacy-modifier$ pm) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type)))) - )) - -(def: (complete-call$ obj [method args]) - (-> AST PartialCall AST) - (` ((~ method) (~ args) (~ obj)))) - -## [Syntax] -(def: object-super-class - SuperClassDecl - {#super-class-name "java.lang.Object" - #super-class-params (list)}) - -(syntax: #export (class: [#let [imports (class-imports *compiler*)]] - [im inheritance-modifier^] - [class-decl (class-decl^ imports)] - [#let [full-class-name (product;left class-decl) - imports (add-import [(short-class-name full-class-name) full-class-name] - (class-imports *compiler*))]] - [#let [class-vars (product;right class-decl)]] - [super (s;default object-super-class - (super-class-decl^ imports class-vars))] - [interfaces (s;default (list) - (s;tuple (s;some (super-class-decl^ imports class-vars))))] - [annotations (annotations^ imports)] - [fields (s;some (field-decl^ imports class-vars))] - [methods (s;some (method-def^ imports class-vars))]) - {#;doc (doc "Allows defining JVM classes in Lux code." - "For example:" - (class: #final (JvmPromise A) [] - ## Fields - (#private resolved boolean) - (#private datum A) - (#private waitingList (java.util.List lux.Function)) - ## Methods - (#public [] new [] [] - (exec (:= .resolved false) - (:= .waitingList (ArrayList.new [])) - [])) - (#public [] resolve [{value A}] boolean - (let [container (.new! [])] - (synchronized _jvm_this - (if .resolved - false - (exec (:= .datum value) - (:= .resolved true) - (let [sleepers .waitingList - sleepers-count (java.util.List.size [] sleepers)] - (map (lambda [idx] - (let [sleeper (java.util.List.get [(l2i idx)] sleepers)] - (Executor.execute [(@runnable (lux.Function.apply [(:! Object value)] sleeper))] - executor))) - (i.range 0 (i.dec (i2l sleepers-count))))) - (:= .waitingList (null)) - true))))) - (#public [] poll [] A - .datum) - (#public [] wasResolved [] boolean - (synchronized _jvm_this - .resolved)) - (#public [] waitOn [{callback lux.Function}] void - (synchronized _jvm_this - (exec (if .resolved - (lux.Function.apply [(:! Object .datum)] callback) - (:! Object (java.util.List.add [callback] .waitingList))) - []))) - (#public #static [A] make [{value A}] (lux.concurrency.promise.JvmPromise A) - (let [container (.new! [])] - (exec (.resolve! (:! (host lux.concurrency.promise.JvmPromise [Unit]) container) [(:! Unit value)]) - container)))) - - "The vector corresponds to parent interfaces." - "An optional super-class can be specified before the vector. If not specified, java.lang.Object will be assumed." - "Fields and methods defined in the class can be used with special syntax." - "For example:" - ".resolved, for accessing the \"resolved\" field." - "(:= .resolved true) for modifying it." - "(.new! []) for calling the class's constructor." - "(.resolve! container [value]) for calling the \"resolve\" method." - )} - (do Monad - [current-module compiler;current-module-name - #let [fully-qualified-class-name (format (text;replace "/" "." current-module) "." full-class-name) - field-parsers (map (field->parser fully-qualified-class-name) fields) - method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods) - replacer (parser->replacer (fold s;either - (s;fail "") - (List/append field-parsers method-parsers))) - def-code (format "class:" - (spaced (list (class-decl$ class-decl) - (super-class-decl$ super) - (with-brackets (spaced (map super-class-decl$ interfaces))) - (inheritance-modifier$ im) - (with-brackets (spaced (map annotation$ annotations))) - (with-brackets (spaced (map field-decl$ fields))) - (with-brackets (spaced (map (method-def$ replacer super) methods))))))]] - (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) - -(syntax: #export (interface: [#let [imports (class-imports *compiler*)]] - [class-decl (class-decl^ imports)] - [#let [full-class-name (product;left class-decl) - imports (add-import [(short-class-name full-class-name) full-class-name] - (class-imports *compiler*))]] - [#let [class-vars (product;right class-decl)]] - [supers (s;default (list) - (s;tuple (s;some (super-class-decl^ imports class-vars))))] - [annotations (annotations^ imports)] - [members (s;some (method-decl^ imports class-vars))]) - {#;doc (doc "Allows defining JVM interfaces." - (interface: TestInterface - ([] foo [boolean String] void #throws [Exception])))} - (let [def-code (format "interface:" - (spaced (list (class-decl$ class-decl) - (with-brackets (spaced (map super-class-decl$ supers))) - (with-brackets (spaced (map annotation$ annotations))) - (spaced (map method-decl$ members)))))] - (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))) - )) - -(syntax: #export (object [#let [imports (class-imports *compiler*)]] - [#let [class-vars (list)]] - [super (s;default object-super-class - (super-class-decl^ imports class-vars))] - [interfaces (s;default (list) - (s;tuple (s;some (super-class-decl^ imports class-vars))))] - [constructor-args (constructor-args^ imports class-vars)] - [methods (s;some (overriden-method-def^ imports))]) - {#;doc (doc "Allows defining anonymous classes." - "The 1st vector corresponds to parent interfaces." - "The 2nd vector corresponds to arguments to the super class constructor." - "An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed." - (object [java.lang.Runnable] - [] - (java.lang.Runnable (run) void - (exec (do-something some-input) - []))) - )} - (let [def-code (format "anon-class:" - (spaced (list (super-class-decl$ super) - (with-brackets (spaced (map super-class-decl$ interfaces))) - (with-brackets (spaced (map constructor-arg$ constructor-args))) - (with-brackets (spaced (map (method-def$ id super) methods))))))] - (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) - -(syntax: #export (null) - {#;doc (doc "Null object reference." - (null))} - (wrap (list (` (;_lux_proc ["jvm" "null"] []))))) - -(def: #export (null? obj) - {#;doc (doc "Test for null object reference." - (null? (null)) - "=>" - true - (null? "YOLO") - "=>" - false)} - (-> (host java.lang.Object) Bool) - (;_lux_proc ["jvm" "null?"] [obj])) - -(syntax: #export (??? expr) - {#;doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." - (??? (: java.lang.String (null))) - "=>" - #;None - (??? "YOLO") - "=>" - (#;Some "YOLO"))} - (with-gensyms [g!temp] - (wrap (list (` (let [(~ g!temp) (~ expr)] - (if (;_lux_proc ["jvm" "null?"] [(~ g!temp)]) - #;None - (#;Some (~ g!temp))))))))) - -(syntax: #export (!!! expr) - {#;doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." - "A #;None would get translated into a (null)." - (!!! (??? (: java.lang.Thread (null)))) - "=>" - (null) - (!!! (??? "YOLO")) - "=>" - "YOLO")} - (with-gensyms [g!value] - (wrap (list (` (;_lux_case (~ expr) - (#;Some (~ g!value)) - (~ g!value) - - #;None - (;_lux_proc ["jvm" "null"] []))))))) - -(syntax: #export (try expr) - {#;doc (doc "Covers the expression in a try-catch block." - "If it succeeds, you get (#;Right result)." - "If it fails, you get (#;Left error+stack-traces-as-text)." - (try (risky-computation input)))} - (wrap (list (`' (_lux_proc ["jvm" "try"] - [(#;Right (~ expr)) - ;;throwable->text]))))) - -(syntax: #export (instance? [#let [imports (class-imports *compiler*)]] - [class (generic-type^ imports (list))] - [obj (s;opt s;any)]) - {#;doc (doc "Checks whether an object is an instance of a particular class." - "Caveat emptor: Can't check for polymorphism, so avoid using parameterized classes." - (instance? String "YOLO"))} - (case obj - (#;Some obj) - (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)])))) - - #;None - (do @ - [g!obj (compiler;gensym "obj")] - (wrap (list (` (: (-> (host (~' java.lang.Object)) Bool) - (lambda [(~ g!obj)] - (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ g!obj)]))))))) - )) - -(syntax: #export (synchronized lock body) - {#;doc (doc "Evaluates body, while holding a lock on a given object." - (synchronized object-to-be-locked - (exec (do-something ...) - (do-something-else ...) - (finish-the-computation ...))))} - (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)]))))) - -(syntax: #export (do-to obj [methods (s;some partial-call^)]) - {#;doc (doc "Call a variety of methods on an object; then return the object." - (do-to vreq - (HttpServerRequest.setExpectMultipart [true]) - (ReadStream.handler [(object [(Handler Buffer)] - [] - ((Handler A) (handle [buffer A]) void - (io;run (do Monad - [_ (write (Buffer.getBytes [] buffer) body)] - (wrap [])))) - )]) - (ReadStream.endHandler [[(object [(Handler Void)] - [] - ((Handler A) (handle [_ A]) void - (exec (do Monad - [#let [_ (io;run (close body))] - response (handler (request$ vreq body))] - (respond! response vreq)) - [])) - )]])))} - (with-gensyms [g!obj] - (wrap (list (` (let [(~ g!obj) (~ obj)] - (exec (~@ (map (complete-call$ g!obj) methods)) - (~ g!obj)))))))) - -(def: (class-import$ long-name? [full-name params]) - (-> Bool ClassDecl AST) - (let [def-name (if long-name? - full-name - (short-class-name full-name))] - (case params - #;Nil - (` (def: (~ (ast;symbol ["" def-name])) - {#;type? true - #;;jvm-class (~ (ast;text full-name))} - Type - (host (~ (ast;symbol ["" full-name]))))) - - (#;Cons _) - (let [params' (map (lambda [[p _]] (ast;symbol ["" p])) params)] - (` (def: (~ (ast;symbol ["" def-name])) - {#;type? true - #;;jvm-class (~ (ast;text full-name))} - Type - (All [(~@ params')] - (host (~ (ast;symbol ["" full-name])) - [(~@ params')])))))))) - -(def: (member-type-vars class-tvars member) - (-> (List TypeParam) ImportMemberDecl (List TypeParam)) - (case member - (#ConstructorDecl [commons _]) - (List/append class-tvars (get@ #import-member-tvars commons)) - - (#MethodDecl [commons _]) - (case (get@ #import-member-kind commons) - #StaticIMK - (get@ #import-member-tvars commons) - - _ - (List/append class-tvars (get@ #import-member-tvars commons))) - - _ - class-tvars)) - -(def: (member-def-arg-bindings type-params class member) - (-> (List TypeParam) ClassDecl ImportMemberDecl (Lux [(List AST) (List AST) (List Text) (List AST)])) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (let [(^slots [#import-member-tvars #import-member-args]) commons] - (do Monad - [arg-inputs (mapM @ - (: (-> [Bool GenericType] (Lux [AST AST])) - (lambda [[maybe? _]] - (with-gensyms [arg-name] - (wrap [arg-name (if maybe? - (` (!!! (~ arg-name))) - arg-name)])))) - import-member-args) - #let [arg-classes (: (List Text) - (map (. (simple-class$ (List/append type-params import-member-tvars)) product;right) - import-member-args)) - arg-types (map (: (-> [Bool GenericType] AST) - (lambda [[maybe? arg]] - (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] - (if maybe? - (` (Maybe (~ arg-type))) - arg-type)))) - import-member-args) - arg-lambda-inputs (map product;left arg-inputs) - arg-method-inputs (map product;right arg-inputs)]] - (wrap [arg-lambda-inputs arg-method-inputs arg-classes arg-types]))) - - _ - (:: Monad wrap [(list) (list) (list) (list)]))) - -(def: (member-def-return mode type-params class member) - (-> Primitive-Mode (List TypeParam) ClassDecl ImportMemberDecl (Lux AST)) - (case member - (#ConstructorDecl _) - (:: Monad wrap (class-decl-type$ class)) - - (#MethodDecl [_ method]) - (:: Monad wrap (class->type mode type-params (get@ #import-method-return method))) - - _ - (compiler;fail "Only methods have return values."))) - -(def: (decorate-return-maybe member [return-type return-term]) - (-> ImportMemberDecl [AST AST] [AST AST]) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ #import-member-maybe? commons) - [(` (Maybe (~ return-type))) - (` (??? (~ return-term)))] - [return-type - (let [g!temp (ast;symbol ["" "Ω"])] - (` (let [(~ g!temp) (~ return-term)] - (if (null? (:! (host (~' java.lang.Object)) - (~ g!temp))) - (error! "Can't produce null references from method calls.") - (~ g!temp)))))]) - - _ - [return-type return-term])) - -(do-template [ ] - [(def: ( member [return-type return-term]) - (-> ImportMemberDecl [AST AST] [AST AST]) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ commons) - [ ] - [return-type return-term]) - - _ - [return-type return-term]))] - - [decorate-return-try #import-member-try? (` (Either Text (~ return-type))) (` (try (~ return-term)))] - [decorate-return-io #import-member-io? (` (IO (~ return-type))) (` (io (~ return-term)))] - ) - -(def: (free-type-param? [name bounds]) - (-> TypeParam Bool) - (case bounds - #;Nil true - _ false)) - -(def: (type-param->type-arg [name _]) - (-> TypeParam AST) - (ast;symbol ["" name])) - -(def: (with-mode-output mode output-type body) - (-> Primitive-Mode GenericType AST AST) - (case mode - #ManualPrM - body - - #AutoPrM - (case output-type - (#GenericClass ["byte" _]) - (` (b2l (~ body))) - - (#GenericClass ["short" _]) - (` (s2l (~ body))) - - (#GenericClass ["int" _]) - (` (i2l (~ body))) - - (#GenericClass ["float" _]) - (` (f2d (~ body))) - - _ - body))) - -(def: (auto-conv-class? class) - (-> Text Bool) - (case class - (^or "byte" "short" "int" "float") - true - - _ - false)) - -(def: (auto-conv [class var]) - (-> [Text AST] (List AST)) - (case class - "byte" (list var (` (l2b (~ var)))) - "short" (list var (` (l2s (~ var)))) - "int" (list var (` (l2i (~ var)))) - "float" (list var (` (d2f (~ var)))) - _ (list))) - -(def: (with-mode-inputs mode inputs body) - (-> Primitive-Mode (List [Text AST]) AST AST) - (case mode - #ManualPrM - body - - #AutoPrM - (` (let [(~@ (|> inputs - (List/map auto-conv) - List/join))] - (~ body))))) - -(def: (with-mode-field-get mode class output) - (-> Primitive-Mode GenericType AST AST) - (case mode - #ManualPrM - output - - #AutoPrM - (case (simple-class$ (list) class) - "byte" (` (b2l (~ output))) - "short" (` (s2l (~ output))) - "int" (` (i2l (~ output))) - "float" (` (f2d (~ output))) - _ output))) - -(def: (with-mode-field-set mode class input) - (-> Primitive-Mode GenericType AST AST) - (case mode - #ManualPrM - input - - #AutoPrM - (case (simple-class$ (list) class) - "byte" (` (l2b (~ input))) - "short" (` (l2s (~ input))) - "int" (` (l2i (~ input))) - "float" (` (d2f (~ input))) - _ input))) - -(def: (member-def-interop type-params kind class [arg-lambda-inputs arg-method-inputs arg-classes arg-types] member method-prefix) - (-> (List TypeParam) ClassKind ClassDecl [(List AST) (List AST) (List Text) (List AST)] ImportMemberDecl Text (Lux (List AST))) - (let [[full-name class-tvars] class - all-params (|> (member-type-vars class-tvars member) - (filter free-type-param?) - (map type-param->type-arg))] - (case member - (#EnumDecl enum-members) - (do Monad - [#let [enum-type (: AST - (case class-tvars - #;Nil - (` (host (~ (ast;symbol ["" full-name])))) - - _ - (let [=class-tvars (|> class-tvars - (filter free-type-param?) - (map type-param->type-arg))] - (` (All [(~@ =class-tvars)] (host (~ (ast;symbol ["" full-name])) [(~@ =class-tvars)])))))) - getter-interop (: (-> Text AST) - (lambda [name] - (let [getter-name (ast;symbol ["" (format method-prefix member-separator name)])] - (` (def: (~ getter-name) - (~ enum-type) - (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" name)))] []))))))]] - (wrap (map getter-interop enum-members))) - - (#ConstructorDecl [commons _]) - (do Monad - [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) - #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) - def-params (list (ast;tuple arg-lambda-inputs)) - jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" full-name ":" (text;join-with "," arg-classes))))] - [(~@ arg-method-inputs)])) - (with-mode-inputs (get@ #import-member-mode commons) - (list;zip2 arg-classes arg-lambda-inputs))) - [return-type jvm-interop] (|> [return-type jvm-interop] - (decorate-return-maybe member) - (decorate-return-try member) - (decorate-return-io member))]] - (wrap (list (` (def: ((~ def-name) (~@ def-params)) - (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type))) - (~ jvm-interop)))))) - - (#MethodDecl [commons method]) - (with-gensyms [g!obj] - (do @ - [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) - #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) - (^slots [#import-member-kind]) commons - (^slots [#import-method-name]) method - [jvm-op obj-ast class-ast] (: [Text (List AST) (List AST)] - (case import-member-kind - #StaticIMK - ["invokestatic" - (list) - (list)] - - #VirtualIMK - (case kind - #Class - ["invokevirtual" - (list g!obj) - (list (class-decl-type$ class))] - - #Interface - ["invokeinterface" - (list g!obj) - (list (class-decl-type$ class))] - ))) - def-params (#;Cons (ast;tuple arg-lambda-inputs) obj-ast) - def-param-types (#;Cons (` [(~@ arg-types)]) class-ast) - jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format jvm-op ":" full-name ":" import-method-name - ":" (text;join-with "," arg-classes))))] - [(~@ obj-ast) (~@ arg-method-inputs)])) - (with-mode-output (get@ #import-member-mode commons) - (get@ #import-method-return method)) - (with-mode-inputs (get@ #import-member-mode commons) - (list;zip2 arg-classes arg-lambda-inputs))) - [return-type jvm-interop] (|> [return-type jvm-interop] - (decorate-return-maybe member) - (decorate-return-try member) - (decorate-return-io member))]] - (wrap (list (` (def: ((~ def-name) (~@ def-params)) - (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type))) - (~ jvm-interop))))))) - - (#FieldAccessDecl fad) - (do Monad - [#let [(^open) fad - base-gtype (class->type import-field-mode type-params import-field-type) - g!class (class-decl-type$ class) - g!type (if import-field-maybe? - (` (Maybe (~ base-gtype))) - base-gtype) - tvar-asts (: (List AST) - (|> class-tvars - (filter free-type-param?) - (map type-param->type-arg))) - getter-name (ast;symbol ["" (format method-prefix member-separator import-field-name)]) - setter-name (ast;symbol ["" (format method-prefix member-separator import-field-name "!")])] - getter-interop (with-gensyms [g!obj] - (let [getter-call (if import-field-static? - getter-name - (` ((~ getter-name) (~ g!obj)))) - getter-type (if import-field-setter? - (` (IO (~ g!type))) - g!type) - getter-type (if import-field-static? - getter-type - (` (-> (~ g!class) (~ getter-type)))) - getter-type (` (All [(~@ tvar-asts)] (~ getter-type))) - getter-body (if import-field-static? - (with-mode-field-get import-field-mode import-field-type - (` (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" import-field-name)))] []))) - (with-mode-field-get import-field-mode import-field-type - (` (;_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" full-name ":" import-field-name)))] [(~ g!obj)])))) - getter-body (if import-field-maybe? - (` (??? (~ getter-body))) - getter-body) - getter-body (if import-field-setter? - (` (io (~ getter-body))) - getter-body)] - (wrap (` (def: (~ getter-call) - (~ getter-type) - (~ getter-body)))))) - setter-interop (if import-field-setter? - (with-gensyms [g!obj g!value] - (let [setter-call (if import-field-static? - (` ((~ setter-name) (~ g!value))) - (` ((~ setter-name) (~ g!value) (~ g!obj)))) - setter-type (if import-field-static? - (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit)))) - (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit))))) - setter-value (with-mode-field-set import-field-mode import-field-type g!value) - setter-value (if import-field-maybe? - (` (!!! (~ setter-value))) - setter-value) - setter-command (format (if import-field-static? "putstatic" "putfield") - ":" full-name ":" import-field-name)] - (wrap (: (List AST) - (list (` (def: (~ setter-call) - (~ setter-type) - (io (;_lux_proc ["jvm" (~ (ast;text setter-command))] - [(~ setter-value)]))))))))) - (wrap (list)))] - (wrap (list& getter-interop setter-interop))) - ))) - -(def: (member-import$ type-params long-name? kind class member) - (-> (List TypeParam) Bool ClassKind ClassDecl ImportMemberDecl (Lux (List AST))) - (let [[full-name _] class - method-prefix (if long-name? - full-name - (short-class-name full-name))] - (do Monad - [=args (member-def-arg-bindings type-params class member)] - (member-def-interop type-params kind class =args member method-prefix)))) - -(def: (interface? class) - (All [a] (-> (host java.lang.Class [a]) Bool)) - (_lux_proc ["jvm" "invokevirtual:java.lang.Class:isInterface:"] [class])) - -(def: (load-class class-name) - (-> Text (Either Text (host java.lang.Class [(Ex [a] a)]))) - (try (_lux_proc ["jvm" "invokestatic:java.lang.Class:forName:java.lang.String"] [class-name]))) - -(def: (class-kind [class-name _]) - (-> ClassDecl (Lux ClassKind)) - (case (load-class class-name) - (#;Right class) - (:: Monad wrap (if (interface? class) - #Interface - #Class)) - - (#;Left _) - (compiler;fail (format "Unknown class: " class-name)))) - -(syntax: #export (jvm-import [#let [imports (class-imports *compiler*)]] - [long-name? (s;this? (' #long))] - [class-decl (class-decl^ imports)] - [#let [full-class-name (product;left class-decl) - imports (add-import [(short-class-name full-class-name) full-class-name] - (class-imports *compiler*))]] - [members (s;some (import-member-decl^ imports (product;right class-decl)))]) - {#;doc (doc "Allows importing JVM classes, and using them as types." - "Their methods, fields and enum options can also be imported." - "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes." - "Examples:" - (jvm-import java.lang.Object - (new []) - (equals [Object] boolean) - (wait [int] #io #try void)) - "Special options can also be given for the return values." - "#? means that the values will be returned inside a Maybe type. That way, null becomes #;None." - "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type." - "#io means the computation has side effects, and will be wrapped by the IO type." - "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." - (jvm-import java.lang.String - (new [(Array byte)]) - (#static valueOf [char] String) - (#static valueOf #as int-valueOf [int] String)) - - (jvm-import #long (java.util.List e) - (size [] int) - (get [int] e)) - - (jvm-import (java.util.ArrayList a) - ([T] toArray [(Array T)] (Array T))) - "#long makes it so the class-type that is generated is of the fully-qualified name." - "In this case, it avoids a clash between the java.util.List type, and Lux's own List type." - (jvm-import java.lang.Character$UnicodeScript - (#enum ARABIC CYRILLIC LATIN)) - "All enum options to be imported must be specified." - - (jvm-import #long (lux.concurrency.promise.JvmPromise A) - (resolve [A] boolean) - (poll [] A) - (wasResolved [] boolean) - (waitOn [lux.Function] void) - (#static [A] make [A] (JvmPromise A))) - "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." - "Lux types, such as Maybe can't be named (otherwise, they'd be confused for Java classes)." - - "Also, the names of the imported members will look like ClassName.MemberName." - "E.g.:" - (Object.new []) - (Object.equals [other-object] my-object) - (java.util.List.size [] my-list) - Character$UnicodeScript.LATIN - )} - (do Monad - [kind (class-kind class-decl) - =members (mapM @ (member-import$ (product;right class-decl) long-name? kind class-decl) members)] - (wrap (list& (class-import$ long-name? class-decl) (List/join =members))))) - -(syntax: #export (array [#let [imports (class-imports *compiler*)]] - [type (generic-type^ imports (list))] - size) - {#;doc (doc "Create an array of the given type, with the given size." - (array Object +10))} - (case type - (^template [ ] - (^ (#GenericClass (list))) - (wrap (list (` (;_lux_proc ["jvm" ] [(~ size)]))))) - (["boolean" "znewarray"] - ["byte" "bnewarray"] - ["short" "snewarray"] - ["int" "inewarray"] - ["long" "lnewarray"] - ["float" "fnewarray"] - ["double" "dnewarray"] - ["char" "cnewarray"]) - - _ - (wrap (list (` (;_lux_proc ["jvm" "anewarray"] [(~ (ast;text (generic-type$ type))) (~ size)])))))) - -(syntax: #export (array-length array) - {#;doc (doc "Gives the length of an array." - (array-length my-array))} - (wrap (list (` (;_lux_proc ["jvm" "arraylength"] [(~ array)]))))) - -(def: (type->class-name type) - (-> Type (Lux Text)) - (case type - (#;HostT name params) - (:: Monad wrap name) - - (#;AppT F A) - (case (type;apply-type F A) - #;None - (compiler;fail (format "Can't apply type: " (type;to-text F) " to " (type;to-text A))) - - (#;Some type') - (type->class-name type')) - - (#;NamedT _ type') - (type->class-name type') - - #;UnitT - (:: Monad wrap "java.lang.Object") - - (^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;LambdaT _) (#;UnivQ _) (#;ExQ _)) - (compiler;fail (format "Can't convert to JvmType: " (type;to-text type))) - )) - -(syntax: #export (array-load idx array) - {#;doc (doc "Loads an element from an array." - (array-load 10 my-array))} - (case array - [_ (#;SymbolS array-name)] - (do Monad - [array-type (compiler;find-type array-name) - array-jvm-type (type->class-name array-type)] - (case array-jvm-type - (^template [ ] - - (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx)]))))) - (["[Z" "zaload"] - ["[B" "baload"] - ["[S" "saload"] - ["[I" "iaload"] - ["[J" "jaload"] - ["[F" "faload"] - ["[D" "daload"] - ["[C" "caload"]) - - _ - (wrap (list (` (;_lux_proc ["jvm" "aaload"] [(~ array) (~ idx)])))))) - - _ - (with-gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (;;array-load (~ g!array) (~ idx))))))))) - -(syntax: #export (array-store idx value array) - {#;doc (doc "Stores an element into an array." - (array-store 10 my-object my-array))} - (case array - [_ (#;SymbolS array-name)] - (do Monad - [array-type (compiler;find-type array-name) - array-jvm-type (type->class-name array-type)] - (case array-jvm-type - (^template [ ] - - (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx) (~ value)]))))) - (["[Z" "zastore"] - ["[B" "bastore"] - ["[S" "sastore"] - ["[I" "iastore"] - ["[J" "jastore"] - ["[F" "fastore"] - ["[D" "dastore"] - ["[C" "castore"]) - - _ - (wrap (list (` (;_lux_proc ["jvm" "aastore"] [(~ array) (~ idx) (~ value)])))))) - - _ - (with-gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (;;array-store (~ g!array) (~ idx) (~ value))))))))) - -(def: simple-bindings^ - (Syntax (List [Text AST])) - (s;tuple (s;some (s;seq s;local-symbol s;any)))) - -(syntax: #export (with-open [bindings simple-bindings^] body) - {#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)." - "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body." - (with-open [my-res1 (res1-constructor ...) - my-res2 (res1-constructor ...)] - (do Monad - [foo (do-something my-res1) - bar (do-something-else my-res2)] - (do-one-last-thing foo bar))))} - (with-gensyms [g!output g!_] - (let [inits (List/join (List/map (lambda [[res-name res-ctor]] - (list (ast;symbol ["" res-name]) res-ctor)) - bindings)) - closes (List/map (lambda [res] - (` (try (;_lux_proc ["jvm" "invokevirtual:java.io.Closeable:close:"] - [(~ (ast;symbol ["" (product;left res)]))])))) - bindings)] - (wrap (list (` (do Monad - [(~@ inits) - (~ g!output) (~ body) - (~' #let) [(~ g!_) (exec (~@ (reverse closes)) [])]] - ((~' wrap) (~ g!output))))))))) - -(syntax: #export (class-for [#let [imports (class-imports *compiler*)]] - [type (generic-type^ imports (list))]) - {#;doc (doc "Loads the class as a java.lang.Class object." - (class-for java.lang.String))} - (wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (ast;text (simple-class$ (list) type)))]))))) - -(def: get-compiler - (Lux Compiler) - (lambda [compiler] - (#;Right [compiler compiler]))) - -(def: (fully-qualify-class-name+ imports name) - (-> ClassImports Text (Maybe Text)) - (cond (fully-qualified-class-name? name) - (#;Some name) - - (member? text;Eq java.lang-classes name) - (#;Some (format "java.lang." name)) - - ## else - (get-import name imports))) - -(def: #export (resolve-class class) - {#;doc (doc "Given a potentially unqualified class name, qualifies it if necessary." - (resolve-class "String") - => - "java.lang.String")} - (-> Text (Lux Text)) - (do Monad - [*compiler* get-compiler] - (case (fully-qualify-class-name+ (class-imports *compiler*) class) - (#;Some fqcn) - (wrap fqcn) - - #;None - (compiler;fail (Text/append "Unknown class: " class))))) diff --git a/stdlib/test/test/lux/host.js.lux b/stdlib/test/test/lux/host.js.lux new file mode 100644 index 000000000..4c2b55485 --- /dev/null +++ b/stdlib/test/test/lux/host.js.lux @@ -0,0 +1,32 @@ +(;module: + lux + (lux [io] + (control monad) + (data text/format) + ["&" host] + ["R" random] + pipe) + lux/test) + +(test: "JavaScript operations" + ($_ seq + (assert "Null equals itself." + (is (&;null) (&;null))) + + (assert "Undefined equals itself." + (is (&;undef) (&;undef))) + + (assert "Can reference JavaScript objects." + (is (&;ref "Math") (&;ref "Math"))) + + (assert "Can create objects and access their fields." + (|> (&;object "foo" "BAR") + (&;get "foo" Text) + (is "BAR"))) + + (assert "Can call JavaScript functions" + (and (is 124.0 + (&;call! (&;ref "Math.ceil" &;Function) [123.45] Real)) + (is 124.0 + (&;call! (&;ref "Math") "ceil" [123.45] Real)))) + )) diff --git a/stdlib/test/test/lux/host.jvm.lux b/stdlib/test/test/lux/host.jvm.lux new file mode 100644 index 000000000..54e6cf4b9 --- /dev/null +++ b/stdlib/test/test/lux/host.jvm.lux @@ -0,0 +1,121 @@ +(;module: + lux + (lux [io] + (control monad) + (data text/format + [number] + [product] + [text "Text/" Eq]) + (codata function) + ["&" host #+ jvm-import class: interface: object] + ["R" random] + pipe) + lux/test) + +(jvm-import java.lang.Exception + (new [String])) + +(jvm-import java.lang.Object) + +(jvm-import (java.lang.Class a) + (getName [] String)) + +(jvm-import java.lang.System + (#static out java.io.PrintStream) + (#static currentTimeMillis [] #io long) + (#static getenv [String] #io #? String)) + +(class: #final (TestClass A) [Runnable] + ## Fields + (#private foo boolean) + (#private bar A) + (#private baz java.lang.Object) + ## Methods + (#public [] (new [value A]) [] + (exec (:= .foo true) + (:= .bar value) + (:= .baz "") + [])) + (#public (virtual) java.lang.Object + "") + (#public #static (static) java.lang.Object + "") + (Runnable [] (run) void + []) + ) + +(def: test-runnable + (object [Runnable] + [] + (Runnable [] (run) void + []))) + +(interface: TestInterface + ([] foo [boolean String] void #throws [Exception])) + +(test: "Conversions" + [sample R;int] + (let% [ (do-template [ ] + [(assert + (or (|> sample (i.= sample)) + (let [capped-sample (|> sample )] + (|> capped-sample (i.= capped-sample)))))] + + [&;l2b &;b2l "Can succesfully convert to/from byte."] + [&;l2s &;s2l "Can succesfully convert to/from short."] + [&;l2i &;i2l "Can succesfully convert to/from int."] + [&;l2f &;f2l "Can succesfully convert to/from float."] + [&;l2d &;d2l "Can succesfully convert to/from double."] + [(<| &;i2c &;l2i) (<| &;i2l &;c2i) "Can succesfully convert to/from char."] + )] + ($_ seq + + ))) + +(test: "Miscellaneous" + ($_ seq + (assert "Can check if an object is of a certain class." + (and (&;instance? String "") + (not (&;instance? Long "")) + (&;instance? Object "") + (not (&;instance? Object (&;null))))) + + (assert "Can run code in a \"synchronized\" block." + (&;synchronized "" true)) + + ## (assert "Can safely try risky code." + ## (and (case (&;try []) + ## (#;Right _) true + ## (#;Left _) false) + ## (case (&;try (_lux_proc ["jvm" "throw"] [(Exception.new "Uh, oh...")])) + ## (#;Right _) false + ## (#;Left _) true))) + + (assert "Can access Class instances." + (Text/= "java.lang.Class" (Class.getName [] (&;class-for java.lang.Class)))) + + (assert "Can check if a value is null." + (and (&;null? (&;null)) + (not (&;null? "")))) + + (assert "Can safely convert nullable references into Maybe values." + (and (|> (: (Maybe Object) (&;??? (&;null))) + (case> #;None true + _ false)) + (|> (: (Maybe Object) (&;??? "")) + (case> (#;Some _) true + _ false)))) + )) + +(test: "Arrays" + [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +1)))) + idx (|> R;nat (:: @ map (n.% size))) + value R;int] + ($_ seq + (assert "Can create arrays of some length." + (n.= size (&;array-length (&;array Long size)))) + + (assert "Can set and get array values." + (let [arr (&;array Long size)] + (exec (&;array-store idx value arr) + (i.= value (&;array-load idx arr))))))) diff --git a/stdlib/test/test/lux/host.lux b/stdlib/test/test/lux/host.lux deleted file mode 100644 index 54e6cf4b9..000000000 --- a/stdlib/test/test/lux/host.lux +++ /dev/null @@ -1,121 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (data text/format - [number] - [product] - [text "Text/" Eq]) - (codata function) - ["&" host #+ jvm-import class: interface: object] - ["R" random] - pipe) - lux/test) - -(jvm-import java.lang.Exception - (new [String])) - -(jvm-import java.lang.Object) - -(jvm-import (java.lang.Class a) - (getName [] String)) - -(jvm-import java.lang.System - (#static out java.io.PrintStream) - (#static currentTimeMillis [] #io long) - (#static getenv [String] #io #? String)) - -(class: #final (TestClass A) [Runnable] - ## Fields - (#private foo boolean) - (#private bar A) - (#private baz java.lang.Object) - ## Methods - (#public [] (new [value A]) [] - (exec (:= .foo true) - (:= .bar value) - (:= .baz "") - [])) - (#public (virtual) java.lang.Object - "") - (#public #static (static) java.lang.Object - "") - (Runnable [] (run) void - []) - ) - -(def: test-runnable - (object [Runnable] - [] - (Runnable [] (run) void - []))) - -(interface: TestInterface - ([] foo [boolean String] void #throws [Exception])) - -(test: "Conversions" - [sample R;int] - (let% [ (do-template [ ] - [(assert - (or (|> sample (i.= sample)) - (let [capped-sample (|> sample )] - (|> capped-sample (i.= capped-sample)))))] - - [&;l2b &;b2l "Can succesfully convert to/from byte."] - [&;l2s &;s2l "Can succesfully convert to/from short."] - [&;l2i &;i2l "Can succesfully convert to/from int."] - [&;l2f &;f2l "Can succesfully convert to/from float."] - [&;l2d &;d2l "Can succesfully convert to/from double."] - [(<| &;i2c &;l2i) (<| &;i2l &;c2i) "Can succesfully convert to/from char."] - )] - ($_ seq - - ))) - -(test: "Miscellaneous" - ($_ seq - (assert "Can check if an object is of a certain class." - (and (&;instance? String "") - (not (&;instance? Long "")) - (&;instance? Object "") - (not (&;instance? Object (&;null))))) - - (assert "Can run code in a \"synchronized\" block." - (&;synchronized "" true)) - - ## (assert "Can safely try risky code." - ## (and (case (&;try []) - ## (#;Right _) true - ## (#;Left _) false) - ## (case (&;try (_lux_proc ["jvm" "throw"] [(Exception.new "Uh, oh...")])) - ## (#;Right _) false - ## (#;Left _) true))) - - (assert "Can access Class instances." - (Text/= "java.lang.Class" (Class.getName [] (&;class-for java.lang.Class)))) - - (assert "Can check if a value is null." - (and (&;null? (&;null)) - (not (&;null? "")))) - - (assert "Can safely convert nullable references into Maybe values." - (and (|> (: (Maybe Object) (&;??? (&;null))) - (case> #;None true - _ false)) - (|> (: (Maybe Object) (&;??? "")) - (case> (#;Some _) true - _ false)))) - )) - -(test: "Arrays" - [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +1)))) - idx (|> R;nat (:: @ map (n.% size))) - value R;int] - ($_ seq - (assert "Can create arrays of some length." - (n.= size (&;array-length (&;array Long size)))) - - (assert "Can set and get array values." - (let [arr (&;array Long size)] - (exec (&;array-store idx value arr) - (i.= value (&;array-load idx arr))))))) -- cgit v1.3.1