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/lux.lux') 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/lux.lux') 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/lux.lux') 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/lux.lux') 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/lux.lux') 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 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/lux.lux') 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/lux.lux') 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