diff options
| -rw-r--r-- | luxc/src/lux/analyser/proc/common.clj | 129 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/jvm/proc/common.clj | 40 | ||||
| -rw-r--r-- | stdlib/source/lux/compiler/default/syntax.lux | 102 |
3 files changed, 168 insertions, 103 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 90db8a2cd..7ce4974f7 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-is [analyse exo-type ?values] +(defn- analyse-lux-is [analyse exo-type ?values] (&type/with-var (fn [$var] (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] @@ -17,7 +17,7 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["lux" "is"]) (&/|list =left =right) (&/|list))))))))) -(defn ^:private analyse-lux-try [analyse exo-type ?values] +(defn- analyse-lux-try [analyse exo-type ?values] (&type/with-var (fn [$var] (|do [:let [(&/$Cons op (&/$Nil)) ?values] @@ -30,7 +30,7 @@ (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list))))))))) (do-template [<name> <proc> <input-type> <output-type>] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] =x (&&/analyse-1 analyse <input-type> x) =y (&&/analyse-1 analyse <input-type> y) @@ -39,13 +39,13 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list))))))) - ^:private analyse-text-eq ["text" "="] &type/Text &type/Bit - ^:private analyse-text-lt ["text" "<"] &type/Text &type/Bit - ^:private analyse-text-concat ["text" "concat"] &type/Text &type/Text + analyse-text-eq ["text" "="] &type/Text &type/Bit + analyse-text-lt ["text" "<"] &type/Text &type/Bit + analyse-text-concat ["text" "concat"] &type/Text &type/Text ) (do-template [<name> <proc-name> <output-type>] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?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) @@ -57,10 +57,10 @@ (&/|list =text =part =start) (&/|list))))))) - ^:private analyse-text-index "index" (&/$Apply &type/Nat &type/Maybe) + analyse-text-index "index" (&/$Apply &type/Nat &type/Maybe) ) -(defn ^:private analyse-text-clip [analyse exo-type ?values] +(defn- 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) @@ -73,7 +73,7 @@ (&/|list))))))) (do-template [<name> <proc>] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Cons text (&/$Nil)) ?values] =text (&&/analyse-1 analyse &type/Text text) _ (&type/check exo-type &type/Nat) @@ -83,10 +83,10 @@ (&/|list =text) (&/|list))))))) - ^:private analyse-text-size "size" + analyse-text-size "size" ) -(defn ^:private analyse-text-char [analyse exo-type ?values] +(defn- analyse-text-char [analyse exo-type ?values] (|do [:let [(&/$Cons text (&/$Cons idx (&/$Nil))) ?values] =text (&&/analyse-1 analyse &type/Text text) =idx (&&/analyse-1 analyse &type/Nat idx) @@ -100,7 +100,7 @@ (do-template [<name> <op>] (let [inputT (&/$Apply &type/Any &type/I64) outputT &type/I64] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Cons mask (&/$Cons input (&/$Nil))) ?values] =mask (&&/analyse-1 analyse inputT mask) =input (&&/analyse-1 analyse inputT input) @@ -109,15 +109,15 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["i64" <op>]) (&/|list =input =mask) (&/|list)))))))) - ^:private analyse-i64-and "and" - ^:private analyse-i64-or "or" - ^:private analyse-i64-xor "xor" + analyse-i64-and "and" + analyse-i64-or "or" + analyse-i64-xor "xor" ) (do-template [<name> <op>] (let [inputT (&/$Apply &type/Any &type/I64) outputT &type/I64] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Cons shift (&/$Cons input (&/$Nil))) ?values] =shift (&&/analyse-1 analyse &type/Nat shift) =input (&&/analyse-1 analyse inputT input) @@ -126,15 +126,15 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["i64" <op>]) (&/|list =input =shift) (&/|list)))))))) - ^:private analyse-i64-left-shift "left-shift" - ^:private analyse-i64-arithmetic-right-shift "arithmetic-right-shift" - ^:private analyse-i64-logical-right-shift "logical-right-shift" + analyse-i64-left-shift "left-shift" + analyse-i64-arithmetic-right-shift "arithmetic-right-shift" + analyse-i64-logical-right-shift "logical-right-shift" ) (do-template [<name> <proc> <input-type> <output-type>] (let [inputT <input-type> outputT <output-type>] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Cons subjectC (&/$Cons paramC (&/$Nil))) ?values] subjectA (&&/analyse-1 analyse <input-type> subjectC) paramA (&&/analyse-1 analyse <input-type> paramC) @@ -143,15 +143,15 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T <proc>) (&/|list subjectA paramA) (&/|list)))))))) - ^:private analyse-i64-eq ["i64" "="] (&/$Apply &type/Any &type/I64) &type/Bit - ^:private analyse-i64-add ["i64" "+"] (&/$Apply &type/Any &type/I64) &type/I64 - ^:private analyse-i64-sub ["i64" "-"] (&/$Apply &type/Any &type/I64) &type/I64 + analyse-i64-eq ["i64" "="] (&/$Apply &type/Any &type/I64) &type/Bit + analyse-i64-add ["i64" "+"] (&/$Apply &type/Any &type/I64) &type/I64 + analyse-i64-sub ["i64" "-"] (&/$Apply &type/Any &type/I64) &type/I64 ) (do-template [<name> <proc> <input-type> <output-type>] (let [inputT <input-type> outputT <output-type>] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] =x (&&/analyse-1 analyse <input-type> x) =y (&&/analyse-1 analyse <input-type> y) @@ -160,22 +160,22 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list)))))))) - ^: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-lt ["int" "<"] &type/Int &type/Bit - - ^:private analyse-frac-add ["frac" "+"] &type/Frac &type/Frac - ^:private analyse-frac-sub ["frac" "-"] &type/Frac &type/Frac - ^:private analyse-frac-mul ["frac" "*"] &type/Frac &type/Frac - ^:private analyse-frac-div ["frac" "/"] &type/Frac &type/Frac - ^:private analyse-frac-rem ["frac" "%"] &type/Frac &type/Frac - ^:private analyse-frac-eq ["frac" "="] &type/Frac &type/Bit - ^:private analyse-frac-lt ["frac" "<"] &type/Frac &type/Bit + analyse-int-mul ["int" "*"] &type/Int &type/Int + analyse-int-div ["int" "/"] &type/Int &type/Int + analyse-int-rem ["int" "%"] &type/Int &type/Int + analyse-int-lt ["int" "<"] &type/Int &type/Bit + + analyse-frac-add ["frac" "+"] &type/Frac &type/Frac + analyse-frac-sub ["frac" "-"] &type/Frac &type/Frac + analyse-frac-mul ["frac" "*"] &type/Frac &type/Frac + analyse-frac-div ["frac" "/"] &type/Frac &type/Frac + analyse-frac-rem ["frac" "%"] &type/Frac &type/Frac + analyse-frac-eq ["frac" "="] &type/Frac &type/Bit + analyse-frac-lt ["frac" "<"] &type/Frac &type/Bit ) (do-template [<encode> <encode-op> <decode> <decode-op> <type>] - (do (defn <encode> [analyse exo-type ?values] + (do (defn- <encode> [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Nil)) ?values] =x (&&/analyse-1 analyse <type> x) _ (&type/check exo-type &type/Text) @@ -184,7 +184,7 @@ (&&/$proc (&/T <encode-op>) (&/|list =x) (&/|list))))))) (let [decode-type (&/$Apply <type> &type/Maybe)] - (defn <decode> [analyse exo-type ?values] + (defn- <decode> [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Nil)) ?values] =x (&&/analyse-1 analyse &type/Text x) _ (&type/check exo-type decode-type) @@ -192,24 +192,24 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list))))))))) - ^:private analyse-frac-encode ["frac" "encode"] ^:private analyse-frac-decode ["frac" "decode"] &type/Frac + analyse-frac-encode ["frac" "encode"] analyse-frac-decode ["frac" "decode"] &type/Frac ) (do-template [<name> <type> <op>] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Nil) ?values] _ (&type/check exo-type <type>) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T <op>) (&/|list) (&/|list))))))) - ^:private analyse-frac-smallest &type/Frac ["frac" "smallest"] - ^:private analyse-frac-min &type/Frac ["frac" "min"] - ^:private analyse-frac-max &type/Frac ["frac" "max"] + analyse-frac-smallest &type/Frac ["frac" "smallest"] + analyse-frac-min &type/Frac ["frac" "min"] + analyse-frac-max &type/Frac ["frac" "max"] ) (do-template [<name> <from-type> <to-type> <op>] - (defn <name> [analyse exo-type ?values] + (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Nil)) ?values] =x (&&/analyse-1 analyse <from-type> x) _ (&type/check exo-type <to-type>) @@ -217,22 +217,43 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T <op>) (&/|list =x) (&/|list))))))) - ^:private analyse-int-char &type/Int &type/Text ["int" "char"] - ^:private analyse-int-frac &type/Int &type/Frac ["int" "frac"] - ^:private analyse-frac-int &type/Frac &type/Int ["frac" "int"] + analyse-int-char &type/Int &type/Text ["int" "char"] + analyse-int-frac &type/Int &type/Frac ["int" "frac"] + analyse-frac-int &type/Frac &type/Int ["frac" "int"] - ^:private analyse-io-log &type/Text &type/Any ["io" "log"] - ^:private analyse-io-error &type/Text &type/Nothing ["io" "error"] - ^:private analyse-io-exit &type/Int &type/Nothing ["io" "exit"] + analyse-io-log &type/Text &type/Any ["io" "log"] + analyse-io-error &type/Text &type/Nothing ["io" "error"] + analyse-io-exit &type/Int &type/Nothing ["io" "exit"] ) -(defn ^:private analyse-io-current-time [analyse exo-type ?values] +(defn- analyse-io-current-time [analyse exo-type ?values] (|do [:let [(&/$Nil) ?values] _ (&type/check exo-type &type/Int) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["io" "current-time"]) (&/|list) (&/|list))))))) +(defn- analyse-syntax-char-case! [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Cons [_ (&/$Tuple ?pairs)] (&/$Cons ?else (&/$Nil)))) ?values] + _cursor &/cursor + =input (&&/analyse-1 analyse &type/Nat ?input) + _ (assert! (even? (&/|length ?pairs)) "The number of matches must be even!") + =pairs (&/map% (fn [?pair] + (|let [[?pattern ?match] ?pair] + (|case ?pattern + [_ (&/$Text ^String ?pattern-char)] + (|do [=match (&&/analyse-1 analyse exo-type ?match)] + (return (&/T [(int (.charAt ?pattern-char 0)) + =match])))))) + (&/|as-pairs ?pairs)) + =else (&&/analyse-1 analyse exo-type ?else)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "syntax char case!"]) + (&/|list =input + (&&/|meta exo-type _cursor (&&/$tuple (&/|map &/|second =pairs))) + =else) + (&/|map &/|first =pairs))))))) + (defn analyse-proc [analyse exo-type proc ?values] (try (case proc "lux is" (analyse-lux-is analyse exo-type ?values) @@ -281,6 +302,10 @@ "lux frac min" (analyse-frac-min analyse exo-type ?values) "lux frac max" (analyse-frac-max analyse exo-type ?values) "lux frac int" (analyse-frac-int analyse exo-type ?values) + + ;; Special extensions for performance reasons + ;; Will be replaced by custom extensions in the future. + "lux syntax char case!" (analyse-syntax-char-case! analyse exo-type ?values) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " proc))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index b5d0ea475..dafcb64ef 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -371,12 +371,50 @@ &&/wrap-long)]] (return nil))) +(defn ^:private compile-syntax-char-case! [compile ?values ?patterns] + (|do [:let [(&/$Cons ?input (&/$Cons [_ (&a/$tuple ?matches)] (&/$Cons ?else (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + :let [?patterns+?matches* (->> (&/zip2 ?patterns ?matches) + &/->seq + (sort-by &/|first <) + &/->list) + ?patterns* (&/|map &/|first ?patterns+?matches*) + ?matches* (&/|map &/|second ?patterns+?matches*) + end-label (new Label) + else-label (new Label) + pattern-labels (&/|map (fn [_] (new Label)) ?patterns*)] + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitLookupSwitchInsn else-label + (int-array (&/->seq ?patterns*)) + (into-array (&/->seq pattern-labels))))] + _ (&/map% (fn [?label+?match] + (|let [[?label ?match] ?label+?match] + (|do [:let [_ (doto *writer* + (.visitLabel ?label))] + _ (compile ?match) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO end-label))]] + (return nil)))) + (&/zip2 pattern-labels ?matches*)) + :let [_ (doto *writer* + (.visitLabel else-label))] + _ (compile ?else) + :let [_ (doto *writer* + (.visitLabel end-label))]] + (return nil))) + (defn compile-proc [compile category proc ?values special-args] (case category "lux" (case proc "is" (compile-lux-is compile ?values special-args) - "try" (compile-lux-try compile ?values special-args)) + "try" (compile-lux-try compile ?values special-args) + ;; Special extensions for performance reasons + ;; Will be replaced by custom extensions in the future. + "syntax char case!" (compile-syntax-char-case! compile ?values special-args)) "io" (case proc diff --git a/stdlib/source/lux/compiler/default/syntax.lux b/stdlib/source/lux/compiler/default/syntax.lux index d724a150b..1584321e5 100644 --- a/stdlib/source/lux/compiler/default/syntax.lux +++ b/stdlib/source/lux/compiler/default/syntax.lux @@ -410,7 +410,10 @@ (#error.Error error) (#error.Error error))) - (with-expansions [<parse> (as-is (parse current-module aliases source-code//size))] + (with-expansions [<parse> (as-is (parse current-module aliases source-code//size)) + <horizontal-move> (as-is (recur [(update@ #.column inc where) + (!inc offset/0) + source-code]))] (def: #export (parse current-module aliases source-code//size) (-> Text Aliases Nat (-> Source (Error [Source Code]))) ## The "exec []" is only there to avoid function fusion. @@ -418,51 +421,50 @@ (exec [] (function (recur [where offset/0 source-code]) (<| (!with-char+ source-code//size source-code offset/0 char/0 <end>) - (`` (case char/0 - ## White-space - (^template [<char> <direction>] - (^ (char <char>)) - (recur [(update@ <direction> inc where) - (!inc offset/0) - source-code])) - ([(~~ (static ..space)) #.column] - [(~~ (static text.carriage-return)) #.column]) - - (^ (char (~~ (static text.new-line)))) + (`` ("lux syntax char case!" char/0 + [## White-space + (~~ (static ..space)) + <horizontal-move> + + (~~ (static text.carriage-return)) + <horizontal-move> + + (~~ (static text.new-line)) (recur [(!new-line where) (!inc offset/0) source-code]) ## Form - (^ (char (~~ (static ..open-form)))) + (~~ (static ..open-form)) (parse-form <parse> <consume-1>) ## Tuple - (^ (char (~~ (static ..open-tuple)))) + (~~ (static ..open-tuple)) (parse-tuple <parse> <consume-1>) ## Record - (^ (char (~~ (static ..open-record)))) + (~~ (static ..open-record)) (parse-record <parse> <consume-1>) ## Text - (^ (char (~~ (static ..text-delimiter)))) + (~~ (static ..text-delimiter)) (read-text <consume-1>) ## Special code - (^ (char (~~ (static ..sigil)))) + (~~ (static ..sigil)) (let [offset/1 (!inc offset/0)] (<| (!with-char+ source-code//size source-code offset/1 char/1 <end>) - (case char/1 - (^template [<char> <bit>] - (^ (char <char>)) - (#error.Success [[(update@ #.column (|>> !inc/2) where) - (!inc offset/1) - source-code] - [where (#.Bit <bit>)]])) - (["0" #0] - ["1" #1]) + ("lux syntax char case!" char/1 + [(~~ (do-template [<char> <bit>] + [<char> + (#error.Success [[(update@ #.column (|>> !inc/2) where) + (!inc offset/1) + source-code] + [where (#.Bit <bit>)]])] + + ["0" #0] + ["1" #1])) ## Single-line comment - (^ (char (~~ (static ..sigil)))) + (~~ (static ..sigil)) (case ("lux text index" source-code (static text.new-line) offset/1) (#.Some end) (recur [(!new-line where) (!inc end) source-code]) @@ -470,36 +472,36 @@ _ <end>) - (^ (char (~~ (static ..name-separator)))) - (!parse-short-name current-module <consume-2> where #.Identifier) + (~~ (static ..name-separator)) + (!parse-short-name current-module <consume-2> where #.Identifier)] - _ - (cond (!name-char?|head char/1) ## Tag - (!parse-full-name offset/1 <consume-2> where #.Tag) + ## else + (cond (!name-char?|head char/1) ## Tag + (!parse-full-name offset/1 <consume-2> where #.Tag) - ## else - <failure>)))) + ## else + <failure>)))) - (^ (char (~~ (static ..name-separator)))) + (~~ (static ..name-separator)) (let [offset/1 (!inc offset/0)] (<| (!with-char+ source-code//size source-code offset/1 char/1 <end>) (if (!digit? char/1) (parse-rev offset/0 [where (!inc offset/1) source-code]) (!parse-short-name current-module <consume-1> where #.Identifier)))) - (^template [<sign>] - (^ (char <sign>)) - (!parse-int source-code//size offset/0 where source-code <end>)) - ([(~~ (static ..positive-sign))] - [(~~ (static ..negative-sign))]) + (~~ (static ..positive-sign)) + (!parse-int source-code//size offset/0 where source-code <end>) - _ - (cond (!digit? char/0) ## Natural number - (parse-nat offset/0 <consume-1>) - - ## Identifier - (!name-char?|head char/0) - (!parse-full-name offset/0 <consume-1> where #.Identifier) - - ## else - <failure>))))))))) + (~~ (static ..negative-sign)) + (!parse-int source-code//size offset/0 where source-code <end>)] + + ## else + (cond (!digit? char/0) ## Natural number + (parse-nat offset/0 <consume-1>) + + ## Identifier + (!name-char?|head char/0) + (!parse-full-name offset/0 <consume-1> where #.Identifier) + + ## else + <failure>))))))))) |