diff options
| author | Eduardo Julian | 2015-07-19 22:24:48 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2015-07-19 22:24:48 -0400 |
| commit | 50366bad3ecf961fdfdbb1e4d8436794d97ae763 (patch) | |
| tree | 3c911205244647bb923b2b1868cc8b1d36a083a4 | |
| parent | eb424eeb33d8fc9bb7ad2acda0c58fcb037717d3 (diff) | |
- Some bug fixes.
- More additions to the standard library.
36 files changed, 1683 insertions, 825 deletions
diff --git a/.gitignore b/.gitignore index fdc7212fc..9c8887842 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,5 @@ pom.xml.asc LICENSE README.md doc/intro.md +/jbe + diff --git a/input/lux.lux b/input/lux.lux index 2bad33439..0c8b73c34 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -10,15 +10,6 @@ (_jvm_interface "Function" [] (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## (<init> [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object <init> [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) - ## Basic types (_lux_def Bool (#DataT "java.lang.Boolean")) (_lux_export Bool) @@ -35,6 +26,9 @@ (_lux_def Text (#DataT "java.lang.String")) (_lux_export Text) +(_lux_def Unit (#TupleT #Nil)) +(_lux_export Unit) + (_lux_def Void (#VariantT #Nil)) (_lux_export Void) @@ -105,6 +99,7 @@ (#Cons [(#BoundT "v") #Nil])]))])] #Nil])]))])])) +(_lux_export Bindings) ## (deftype (Env k v) ## (& #name Text @@ -121,6 +116,7 @@ (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) (#BoundT "v")])] #Nil])])])]))])])) +(_lux_export Env) ## (deftype Cursor ## (, Text Int Int)) @@ -855,7 +851,7 @@ (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) [_ (#Meta [_ (#TupleS elems)])] - (splice (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] unquoted @@ -937,7 +933,7 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def'' Maybe:Monad +(def'' Maybe/Monad ($' Monad Maybe) {#lux;return (lambda return [x] @@ -949,7 +945,7 @@ #None #None (#Some a) (f a)))}) -(def'' Lux:Monad +(def'' Lux/Monad ($' Monad Lux) {#lux;return (lambda [x] @@ -1126,8 +1122,8 @@ (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe:Monad get-ident bindings) - (map% Maybe:Monad tuple->list data)]) + [(map% Maybe/Monad get-ident bindings) + (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] (let [apply (_lux_: (-> RepEnv ($' List Syntax)) (lambda [env] (map (apply-template env) templates)))] @@ -1146,12 +1142,12 @@ (-> <type> <type> Bool) (<cmp> x y))] - [int:= _jvm_leq Int] - [int:> _jvm_lgt Int] - [int:< _jvm_llt Int] - [real:= _jvm_deq Real] - [real:> _jvm_dgt Real] - [real:< _jvm_dlt Real] + [i= _jvm_leq Int] + [i> _jvm_lgt Int] + [i< _jvm_llt Int] + [r= _jvm_deq Real] + [r> _jvm_dgt Real] + [r< _jvm_dlt Real] ) (do-template [<name> <cmp> <eq> <type>] @@ -1161,10 +1157,10 @@ true (<eq> x y)))] - [ int:>= int:> int:= Int] - [ int:<= int:< int:= Int] - [real:>= real:> real:= Real] - [real:<= real:< real:= Real] + [i>= i> i= Int] + [i<= i< i= Int] + [r>= r> r= Real] + [r<= r< r= Real] ) (do-template [<name> <cmp> <type>] @@ -1172,25 +1168,25 @@ (-> <type> <type> <type>) (<cmp> x y))] - [int:+ _jvm_ladd Int] - [int:- _jvm_lsub Int] - [int:* _jvm_lmul Int] - [int:/ _jvm_ldiv Int] - [int:% _jvm_lrem Int] - [real:+ _jvm_dadd Real] - [real:- _jvm_dsub Real] - [real:* _jvm_dmul Real] - [real:/ _jvm_ddiv Real] - [real:% _jvm_drem Real] + [i+ _jvm_ladd Int] + [i- _jvm_lsub Int] + [i* _jvm_lmul Int] + [i/ _jvm_ldiv Int] + [i% _jvm_lrem Int] + [r+ _jvm_dadd Real] + [r- _jvm_dsub Real] + [r* _jvm_dmul Real] + [r/ _jvm_ddiv Real] + [r% _jvm_drem Real] ) (def'' (multiple? div n) (-> Int Int Bool) - (int:= 0 (int:% n div))) + (i= 0 (i% n div))) (def'' (length list) (-> List Int) - (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) (def'' #export (not x) (-> Bool Bool) @@ -1244,7 +1240,7 @@ ["" tokens]))] (_lux_case tokens' (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe:Monad get-ident args) + (_lux_case (map% Maybe/Monad get-ident args) (#Some idents) (_lux_case idents #Nil @@ -1309,7 +1305,7 @@ (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) - (do Maybe:Monad + (do Maybe/Monad [$module (get module modules) gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] (get name bindings))] @@ -1329,7 +1325,7 @@ (def'' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux:Monad + (do Lux/Monad [current-module get-module-name] (let [[module name] ident] (lambda [state] @@ -1348,7 +1344,7 @@ (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (;return (_lux_: Ident [module-name name]))) @@ -1356,18 +1352,18 @@ (return ident))) (defmacro #export (| tokens) - (do Lux:Monad - [pairs (map% Lux:Monad + (do Lux/Monad + [pairs (map% Lux/Monad (_lux_: (-> Syntax ($' Lux Syntax)) (lambda [token] (_lux_case token (#Meta [_ (#TagS ident)]) - (do Lux:Monad + (do Lux/Monad [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux:Monad + (do Lux/Monad [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) @@ -1379,13 +1375,13 @@ (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) (fail "& expects an even number of arguments.") - (do Lux:Monad - [pairs (map% Lux:Monad + (do Lux/Monad + [pairs (map% Lux/Monad (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) (lambda [pair] (_lux_case pair [(#Meta [_ (#TagS ident)]) value] - (do Lux:Monad + (do Lux/Monad [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) @@ -1415,30 +1411,30 @@ (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) - (do Lux:Monad + (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] (_lux_case ?macro (#Some macro) - (do Lux:Monad + (do Lux/Monad [expansion (macro args) - expansion' (map% Lux:Monad macro-expand expansion)] + expansion' (map% Lux/Monad macro-expand expansion)] (;return (list:join expansion'))) #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))] + (do Lux/Monad + [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] (;return (list (form$ (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) - (do Lux:Monad + (do Lux/Monad [harg+ (macro-expand harg) - targs+ (map% Lux:Monad macro-expand targs)] + targs+ (map% Lux/Monad macro-expand targs)] (;return (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] + (do Lux/Monad + [members' (map% Lux/Monad macro-expand members)] (;return (list (tuple$ (list:join members'))))) _ @@ -1464,7 +1460,7 @@ (defmacro #export (type tokens) (_lux_case tokens (#Cons [type #Nil]) - (do Lux:Monad + (do Lux/Monad [type+ (macro-expand type)] (_lux_case type+ (#Cons [type' #Nil]) @@ -1494,12 +1490,12 @@ (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens + (_lux_case (:! (List Syntax) tokens) (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] + [true (:! (List Syntax) tokens')] _ - [false tokens])) + [false (:! (List Syntax) tokens)])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) (_lux_case tokens' (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) @@ -1597,20 +1593,20 @@ (defmacro #export (case tokens) (_lux_case tokens (#Cons [value branches]) - (do Lux:Monad - [expansions (map% Lux:Monad + (do Lux/Monad + [expansions (map% Lux/Monad (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux:Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux:Monad expander (as-pairs expansion))] - (;return (list:join expansions))) - - _ - (;return (list branch)))))) + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (do Lux/Monad + [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux/Monad expander (as-pairs expansion))] + (;return (list:join expansions))) + + _ + (;return (list branch)))))) (as-pairs branches))] (;return (list (`' (_lux_case (~ value) (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) @@ -1621,7 +1617,7 @@ (defmacro #export (\ tokens) (case tokens (#Cons [body (#Cons [pattern #Nil])]) - (do Lux:Monad + (do Lux/Monad [pattern+ (macro-expand pattern)] (case pattern+ (#Cons [pattern' #Nil]) @@ -1641,8 +1637,8 @@ (fail "\\or can't have 0 patterns") _ - (do Lux:Monad - [patterns' (map% Lux:Monad macro-expand patterns)] + (do Lux/Monad + [patterns' (map% Lux/Monad macro-expand patterns)] (;return (list:join (map (lambda [pattern] (list pattern body)) (list:join patterns')))))) @@ -1650,13 +1646,13 @@ (fail "Wrong syntax for \\or"))) (do-template [<name> <offset>] - [(def #export <name> (int:+ <offset>))] + [(def #export <name> (i+ <offset>))] [inc 1] [dec -1]) (defmacro #export (` tokens) - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (case tokens (\ (list template)) @@ -1678,7 +1674,7 @@ (def (macro-expand-1 token) (-> Syntax (Lux Syntax)) - (do Lux:Monad + (do Lux/Monad [token+ (macro-expand token)] (case token+ (\ (list token')) @@ -1688,14 +1684,14 @@ (fail "Macro expanded to more than 1 element.")))) (defmacro #export (sig tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand tokens) - members (map% Lux:Monad + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) - (do Lux:Monad + (do Lux/Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1745,14 +1741,14 @@ (fail "Wrong syntax for defsig")))) (defmacro #export (struct tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand tokens) - members (map% Lux:Monad + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) - (do Lux:Monad + (do Lux/Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [(tag$ name') value]))) @@ -1825,7 +1821,7 @@ (def (extract-defs defs) (-> (List Syntax) (Lux (List Text))) - (map% Lux:Monad + (map% Lux/Monad (: (-> Syntax (Lux Text)) (lambda [def] (case def @@ -1854,12 +1850,12 @@ (return (: (, Referrals (List Syntax)) [#All tokens'])) (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) - (do Lux:Monad + (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "except"])]) defs))])) - (do Lux:Monad + (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Except defs') tokens']))) @@ -1871,7 +1867,7 @@ (def (decorate-imports super-name tokens) (-> Text (List Syntax) (Lux (List Syntax))) - (map% Lux:Monad + (map% Lux/Monad (: (-> Syntax (Lux Syntax)) (lambda [token] (case token @@ -1887,8 +1883,8 @@ (def (parse-imports imports) (-> (List Syntax) (Lux (List Import))) - (do Lux:Monad - [referrals' (map% Lux:Monad + (do Lux/Monad + [referrals' (map% Lux/Monad (: (-> Syntax (Lux (List Import))) (lambda [token] (case token @@ -1896,7 +1892,7 @@ (;return (list [m-name #None #All])) (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) - (do Lux:Monad + (do Lux/Monad [alias+extra' (parse-alias extra) #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) alias+extra')] @@ -1976,14 +1972,14 @@ (def (split-module-contexts module) (-> Text (List Text)) (#Cons [module (let [idx (last-index-of "/" module)] - (if (int:< idx 0) + (if (i< idx 0) #Nil (split-module-contexts (substring2 0 idx module))))])) (def (split-module module) (-> Text (List Text)) (let [idx (index-of "/" module)] - (if (int:< idx 0) + (if (i< idx 0) (#Cons [module #Nil]) (#Cons [(substring2 0 idx module) (split-module (substring1 (inc idx) module))])))) @@ -1996,7 +1992,7 @@ #None (#Cons [x xs']) - (if (int:= idx 0) + (if (i= idx 0) (#Some x) (@ (dec idx) xs') ))) @@ -2021,7 +2017,7 @@ (def (clean-module module) (-> Text (Lux Text)) - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (case (split-module module) (\ (list& "." parts)) @@ -2030,7 +2026,7 @@ parts (let [[ups parts'] (split-with (text:= "..") parts) num-ups (length ups)] - (if (int:= num-ups 0) + (if (i= num-ups 0) (return module) (case (@ num-ups (split-module-contexts module-name)) #None @@ -2062,23 +2058,23 @@ output)) (defmacro #export (import tokens) - (do Lux:Monad + (do Lux/Monad [imports (parse-imports tokens) - imports (map% Lux:Monad + imports (map% Lux/Monad (: (-> Import (Lux Import)) (lambda [import] (case import [m-name m-alias m-referrals] - (do Lux:Monad + (do Lux/Monad [m-name (clean-module m-name)] (;return (: Import [m-name m-alias m-referrals])))))) imports) - unknowns' (map% Lux:Monad + unknowns' (map% Lux/Monad (: (-> Import (Lux (List Text))) (lambda [import] (case import [m-name _ _] - (do Lux:Monad + (do Lux/Monad [? (module-exists? m-name)] (;return (if ? (list) @@ -2087,24 +2083,24 @@ #let [unknowns (list:join unknowns')]] (case unknowns #Nil - (do Lux:Monad - [output' (map% Lux:Monad + (do Lux/Monad + [output' (map% Lux/Monad (: (-> Import (Lux (List Syntax))) (lambda [import] (case import [m-name m-alias m-referrals] - (do Lux:Monad + (do Lux/Monad [defs (case m-referrals #All (exported-defs m-name) (#Only +defs) - (do Lux:Monad + (do Lux/Monad [*defs (exported-defs m-name)] (;return (filter (is-member? +defs) *defs))) (#Except -defs) - (do Lux:Monad + (do Lux/Monad [*defs (exported-defs m-name)] (;return (filter (. not (is-member? -defs)) *defs))) @@ -2270,7 +2266,7 @@ (defmacro #export (? tokens) (case tokens (\ (list maybe else)) - (do Lux:Monad + (do Lux/Monad [g!value (gensym "")] (return (list (` (case (~ maybe) (#;Some (~ g!value)) @@ -2292,7 +2288,7 @@ body)) (#AppT [F A]) - (do Maybe:Monad + (do Maybe/Monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -2408,7 +2404,7 @@ ## {#source source #modules modules ## #envs envs #types types #host host ## #seed seed #seen-sources seen-sources #eval? eval?} state] -## (do Maybe:Monad +## (do Maybe/Monad ## [module (get v-prefix modules) ## #let [{#defs defs #module-aliases _ #imports _} module] ## def (get v-name defs) @@ -2421,7 +2417,7 @@ (def (find-var-type name) (-> Ident (Lux Type)) - (do Lux:Monad + (do Lux/Monad [name' (normalize name)] (lambda [state] (case (find-in-env name state) @@ -2444,7 +2440,7 @@ (\ (list struct body)) (case struct (#Meta [_ (#SymbolS name)]) - (do Lux:Monad + (do Lux/Monad [struct-type (find-var-type name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) @@ -2491,7 +2487,7 @@ (f x y)))) (defmacro #export (cond tokens) - (if (int:= 0 (int:% (length tokens) 2)) + (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") (case (reverse tokens) (\ (list& else branches')) @@ -2510,13 +2506,13 @@ (\ (list (#Meta [_ (#TagS slot')]) record)) (case record (#Meta [_ (#SymbolS name)]) - (do Lux:Monad + (do Lux/Monad [type (find-var-type name) g!blank (gensym "") g!output (gensym "")] (case (resolve-struct-type type) (#Some (#RecordT slots)) - (do Lux:Monad + (do Lux/Monad [slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) @@ -2534,7 +2530,7 @@ (fail "get@ can only use records."))) _ - (do Lux:Monad + (do Lux/Monad [_record (gensym "")] (return (list (` (let [(~ _record) (~ record)] (get@ (~ (tag$ slot')) (~ _record)))))))) @@ -2545,7 +2541,7 @@ (defmacro #export (open tokens) (case tokens (\ (list (#Meta [_ (#SymbolS struct-name)]))) - (do Lux:Monad + (do Lux/Monad [struct-type (find-var-type struct-name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) @@ -2579,8 +2575,8 @@ (defmacro #export (:: tokens) (case tokens (\ (list& start parts)) - (do Lux:Monad - [output (foldL% Lux:Monad + (do Lux/Monad + [output (foldL% Lux/Monad (: (-> Syntax Syntax (Lux Syntax)) (lambda [so-far part] (case part @@ -2604,16 +2600,16 @@ (\ (list (#Meta [_ (#TagS slot')]) value record)) (case record (#Meta [_ (#SymbolS name)]) - (do Lux:Monad + (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) (#Some (#RecordT slots)) - (do Lux:Monad - [pattern' (map% Lux:Monad + (do Lux/Monad + [pattern' (map% Lux/Monad (: (-> (, Text Type) (Lux (, Text Syntax))) (lambda [slot] (let [[r-slot-name r-type] slot] - (do Lux:Monad + (do Lux/Monad [g!slot (gensym "")] (return [r-slot-name g!slot]))))) slots) @@ -2639,7 +2635,7 @@ (fail "set@ can only use records."))) _ - (do Lux:Monad + (do Lux/Monad [_record (gensym "")] (return (list (` (let [(~ _record) (~ record)] (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) @@ -2652,16 +2648,16 @@ (\ (list (#Meta [_ (#TagS slot')]) fun record)) (case record (#Meta [_ (#SymbolS name)]) - (do Lux:Monad + (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) (#Some (#RecordT slots)) - (do Lux:Monad - [pattern' (map% Lux:Monad + (do Lux/Monad + [pattern' (map% Lux/Monad (: (-> (, Text Type) (Lux (, Text Syntax))) (lambda [slot] (let [[r-slot-name r-type] slot] - (do Lux:Monad + (do Lux/Monad [g!slot (gensym "")] (return [r-slot-name g!slot]))))) slots) @@ -2687,7 +2683,7 @@ (fail "update@ can only use records."))) _ - (do Lux:Monad + (do Lux/Monad [_record (gensym "")] (return (list (` (let [(~ _record) (~ record)] (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) @@ -2695,6 +2691,33 @@ _ (fail "Wrong syntax for update@"))) +(defmacro #export (\template tokens) + (case tokens + (\ (list (#Meta [_ (#TupleS data)]) + (#Meta [_ (#TupleS bindings)]) + (#Meta [_ (#TupleS templates)]))) + (case (: (Maybe (List Syntax)) + (do Maybe/Monad + [bindings' (map% Maybe/Monad get-ident bindings) + data' (map% Maybe/Monad tuple->list data)] + (let [apply (: (-> RepEnv (List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + ;return)))) + (#Some output) + (return output) + + #None + (fail "Wrong syntax for \\template")) + + _ + (fail "Wrong syntax for \\template"))) + +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) + ## (defmacro #export (loop tokens) ## (case tokens ## (\ (list bindings body)) @@ -2702,14 +2725,14 @@ ## vars (map first pairs) ## inits (map second pairs)] ## (if (every? symbol? inits) -## (do Lux:Monad -## [inits' (map% Maybe:Monad get-ident inits) -## init-types (map% Maybe:Monad find-var-type inits')] +## (do Lux/Monad +## [inits' (map% Maybe/Monad get-ident inits) +## init-types (map% Maybe/Monad find-var-type inits')] ## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] ## (~ body)) ## (~@ inits)))))) -## (do Lux:Monad -## [aliases (map% Maybe:Monad (lambda [_] (gensym "")) inits)] +## (do Lux/Monad +## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] ## (return (list (` (let [(~@ (interleave aliases inits))] ## (loop [(~@ (interleave vars aliases))] ## (~ body))))))))) diff --git a/input/lux/codata/stream.lux b/input/lux/codata/stream.lux index 1bfd19292..1d6dd1b50 100644 --- a/input/lux/codata/stream.lux +++ b/input/lux/codata/stream.lux @@ -7,57 +7,127 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (control (lazy #as L #refer #all)))) + (lux (control (lazy #as L #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all) + (comonad #as CM #refer #all)) + (meta lux + macro + syntax) + (data (list #as l #refer (#only list list& List/Monad))))) -## Types +## [Types] (deftype #export (Stream a) (Lazy (, a (Stream a)))) -## Functions +## [Utils] +(def (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (cycle' init full init full) + (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + +## [Functions] (def #export (iterate f x) (All [a] (-> (-> a a) a (Stream a))) (... [x (iterate f (f x))])) -## (def #export (take n xs) -## (All [a] -## (-> Int (Stream a) (List a))) -## (if (int:> n 0) -## (let [[x xs'] (! xs)] -## (list& x (take (dec n) xs'))) -## (list))) - -## (def #export (drop n xs) -## (All [a] -## (-> Int (Stream a) (Stream a))) -## (if (int:> n 0) -## (drop (dec n) (get@ 1 (! xs))) -## xs)) - -## Pattern-matching -## (defmacro #export (\stream tokens) -## (case tokens -## (\ (list& body patterns')) -## (do Lux:Monad -## [patterns (map% Lux:Monad M;macro-expand-1 patterns') -## g!s (M;gensym "s") -## #let [patterns+ (do List:Monad -## [pattern (reverse patterns)] -## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]] -## (wrap (list g!s -## (` (;let [(~@ patterns+)] -## (~ body)))))) - -## _ -## "Wrong syntax for \stream")) - -## (defsyntax #export (\stream body [patterns' (+$ id$)]) -## (do Lux:Monad -## [patterns (map% Lux:Monad M;macro-expand-1 patterns') -## g!s (M;gensym "s") -## #let [patterns+ (do List:Monad -## [pattern (reverse patterns)] -## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]] -## (wrap (list g!s -## (` (;let [(~@ patterns+)] -## (~ body))))))) +(def #export (repeat x) + (All [a] + (-> a (Stream a))) + (... [x (repeat x)])) + +(def #export (cycle xs) + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + +(do-template [<name> <return> <part>] + [(def #export (<name> s) + (All [a] (-> (Stream a) <return>)) + (let [[h t] (! s)] + <part>))] + + [head a h] + [tail (Stream a) t]) + +(def #export (@ idx s) + (All [a] (-> Int (Stream a) a)) + (let [[h t] (! s)] + (if (i> idx 0) + (@ (dec idx) t) + h))) + +(do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>] + [(def #export (<taker> det xs) + (All [a] + (-> <det-type> (Stream a) (List a))) + (let [[x xs'] (! xs)] + (if <det-test> + (list& x (<taker> <det-step> xs')) + (list)))) + + (def #export (<dropper> det xs) + (All [a] + (-> <det-type> (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if <det-test> + (<dropper> <det-step> xs') + xs))) + + (def #export (<splitter> det xs) + (All [a] + (-> <det-type> (Stream a) (, (List a) (Stream a)))) + (let [[x xs'] (! xs)] + (if <det-test> + (let [[tail next] (<splitter> <det-step> xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-with (-> a Bool) (det x) det] + [take drop split Int (i> det 0) (dec det)] + ) + +(def #export (unfold step init) + (All [a b] + (-> (-> a (, a b)) a (Stream b))) + (let [[next x] (step init)] + (... [x (unfold step next)]))) + +(def #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if (p x) + (... [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(defstruct #export Stream/Functor (Functor Stream) + (def (F;map f fa) + (let [[h t] (! fa)] + (... [(f h) (F;map f t)])))) + +(defstruct #export Stream/CoMonad (CoMonad Stream) + (def CM;_functor Stream/Functor) + (def CM;unwrap head) + (def (CM;split wa) + (:: Stream/Functor (F;map repeat wa)))) + +## [Pattern-matching] +(defsyntax #export (\stream body [patterns' (+^ id^)]) + (do Lux/Monad + [patterns (map% Lux/Monad macro-expand-1 patterns') + g!s (gensym "s") + #let [patterns+ (: (List Syntax) + (do List/Monad + [pattern (l;reverse patterns)] + (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] + (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/input/lux/control/functor.lux b/input/lux/control/functor.lux index 3362dd21a..6a9dcfff8 100644 --- a/input/lux/control/functor.lux +++ b/input/lux/control/functor.lux @@ -6,30 +6,10 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import lux - (lux/data state)) +(;import lux) ## Signatures (defsig #export (Functor f) (: (All [a b] (-> (-> a b) (f a) (f b))) map)) - -## Structures -(defstruct #export Maybe:Functor (Functor Maybe) - (def (map f ma) - (case ma - #;None #;None - (#;Some a) (#;Some (f a))))) - -(defstruct #export List:Functor (Functor List) - (def (map f ma) - (case ma - #;Nil #;Nil - (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) - -(defstruct #export State:Functor (Functor State) - (def (map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux index 83f094592..fca63179e 100644 --- a/input/lux/control/lazy.lux +++ b/input/lux/control/lazy.lux @@ -34,12 +34,12 @@ (thunk id)) ## Structs -(defstruct #export Lazy:Functor (Functor Lazy) +(defstruct #export Lazy/Functor (Functor Lazy) (def (F;map f ma) (... (f (! ma))))) -(defstruct #export Lazy:Monad (Monad Lazy) - (def M;_functor Lazy:Functor) +(defstruct #export Lazy/Monad (Monad Lazy) + (def M;_functor Lazy/Functor) (def (M;wrap a) (... a)) diff --git a/input/lux/control/monad.lux b/input/lux/control/monad.lux index 2ca541574..b5552f987 100644 --- a/input/lux/control/monad.lux +++ b/input/lux/control/monad.lux @@ -7,13 +7,38 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/data list - state) (.. (functor #as F) (monoid #as M)) lux/meta/macro) -## Signatures +## [Utils] +(def (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (#;Cons [x1 (#;Cons [x2 xs'])]) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +## [Signatures] (defsig #export (Monad m) (: (F;Functor m) _functor) @@ -24,10 +49,11 @@ (-> (m (m a)) (m a))) join)) -## Syntax +## [Syntax] (defmacro #export (do tokens state) (case tokens - (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) (lambda [body' binding] (let [[var value] binding] @@ -43,49 +69,15 @@ )))) body (reverse (as-pairs bindings)))] - (#;Right [state (list (` (;case (~ monad) - {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} - (~ body'))))])) + (#;Right [state (#;Cons [(` (;case (~ monad) + {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + (~ body'))) + #;Nil])])) _ (#;Left "Wrong syntax for do"))) -## Structures -(defstruct #export Maybe:Monad (Monad Maybe) - (def _functor F;Maybe:Functor) - - (def (wrap x) - (#;Some x)) - - (def (join mma) - (case mma - #;None #;None - (#;Some xs) xs))) - -(defstruct #export List:Monad (Monad List) - (def _functor F;List:Functor) - - (def (wrap x) - (#;Cons [x #;Nil])) - - (def (join xss) - (using M;List:Monoid - (foldL M;++ M;unit xss)))) - -(defstruct #export State:Monad (All [s] - (Monad (State s))) - (def _functor F;State:Functor) - - (def (wrap x) - (lambda [state] - [state x])) - - (def (join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) - -## Functions +## [Functions] (def #export (bind m f ma) (All [m a b] (-> (Monad m) (-> a (m b)) (m a) (m b))) diff --git a/input/lux/control/monoid.lux b/input/lux/control/monoid.lux index cfb282c52..d32baabc5 100644 --- a/input/lux/control/monoid.lux +++ b/input/lux/control/monoid.lux @@ -6,9 +6,7 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import lux - (lux/data ord - (bounded #as B))) +(;import lux) ## Signatures (defsig #export (Monoid a) @@ -24,34 +22,3 @@ (struct (def unit unit) (def ++ ++))) - -## Structures -(defstruct #export Maybe:Monoid (Monoid Maybe) - (def unit #;None) - (def (++ xs ys) - (case xs - #;None ys - (#;Some x) (#;Some x)))) - -(defstruct #export List:Monoid (All [a] - (Monoid (List a))) - (def unit #;Nil) - (def (++ xs ys) - (case xs - #;Nil ys - (#;Cons [x xs']) (#;Cons [x (++ xs' ys)])))) - -(do-template [<name> <type> <unit> <++>] - [(defstruct #export <name> (Monoid <type>) - (def unit <unit>) - (def ++ <++>))] - - [ IntAdd:Monoid Int 0 int:+] - [ IntMul:Monoid Int 1 int:*] - [RealAdd:Monoid Real 0.0 real:+] - [RealMul:Monoid Real 1.0 real:*] - [ IntMax:Monoid Int (:: B;Int:Bounded B;bottom) (max Int:Ord)] - [ IntMin:Monoid Int (:: B;Int:Bounded B;top) (min Int:Ord)] - [RealMax:Monoid Real (:: B;Real:Bounded B;bottom) (max Real:Ord)] - [RealMin:Monoid Real (:: B;Real:Bounded B;top) (min Real:Ord)] - ) diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux index 14f4d2e86..458fbc0df 100644 --- a/input/lux/data/bounded.lux +++ b/input/lux/data/bounded.lux @@ -22,5 +22,5 @@ (def top <top>) (def bottom <bottom>))] - [Int:Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] - [Real:Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) + [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] + [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) diff --git a/input/lux/data/dict.lux b/input/lux/data/dict.lux index 8bd6635fd..63a66d49b 100644 --- a/input/lux/data/dict.lux +++ b/input/lux/data/dict.lux @@ -69,7 +69,7 @@ (#;Cons [[k' v'] (pl-remove eq k kvs')])))) ## Structs -(defstruct #export PList:Dict (Dict PList) +(defstruct #export PList/Dict (Dict PList) (def (get k plist) (let [(#PList [eq kvs]) plist] (pl-get eq k kvs))) diff --git a/input/lux/data/either.lux b/input/lux/data/either.lux new file mode 100644 index 000000000..7166688b5 --- /dev/null +++ b/input/lux/data/either.lux @@ -0,0 +1,46 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (list #refer (#except partition)))) + +## [Types] +## (deftype (Either l r) +## (| (#;Left l) +## (#;Right r))) + +## [Functions] +(def #export (either f g e) + (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) + (case e + (#;Left x) (f x) + (#;Right x) (g x))) + +(do-template [<name> <side> <tag>] + [(def #export (<name> es) + (All [a b] (-> (List (Either a b)) (List <side>))) + (case es + #;Nil #;Nil + (#;Cons [(<tag> x) es']) (#;Cons [x (<name> es')]) + (#;Cons [_ es']) (<name> es')))] + + [lefts a #;Left] + [rights b #;Right] + ) + +(def #export (partition es) + (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) + (foldL (: (All [a b] + (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) + (lambda [tails e] + (let [[ltail rtail] tails] + (case e + (#;Left x) [(#;Cons [x ltail]) rtail] + (#;Right x) [ltail (#;Cons [x rtail])])))) + [(list) (list)] + (reverse es))) diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux index 948f8e2ab..191e6a885 100644 --- a/input/lux/data/eq.lux +++ b/input/lux/data/eq.lux @@ -14,7 +14,7 @@ =)) ## Structures -(defstruct #export Bool:Eq (Eq Bool) +(defstruct #export Bool/Eq (Eq Bool) (def (= x y) (case (: (, Bool Bool) [x y]) (\or [true true] [false false]) @@ -22,14 +22,3 @@ _ false))) - -(defstruct #export Int:Eq (Eq Int) - (def = int:=)) - -(defstruct #export Real:Eq (Eq Real) - (def = real:=)) - -(defstruct #export Text:Eq (Eq Text) - (def (= x y) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] - x [y]))) diff --git a/input/lux/data/error.lux b/input/lux/data/error.lux new file mode 100644 index 000000000..cb5c309a6 --- /dev/null +++ b/input/lux/data/error.lux @@ -0,0 +1,34 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Error a) + (| (#Fail Text) + (#Ok a))) + +## [Structures] +(defstruct #export Error/Functor (Functor Error) + (def (F;map f ma) + (case ma + (#Fail msg) (#Fail msg) + (#Ok datum) (#Ok (f datum))))) + +(defstruct #export Error/Monad (Monad Error) + (def M;_functor Error/Functor) + + (def (M;wrap a) + (#Ok a)) + + (def (M;join mma) + (case mma + (#Fail msg) (#Fail msg) + (#Ok ma) ma))) diff --git a/input/lux/data/id.lux b/input/lux/data/id.lux new file mode 100644 index 000000000..0e3bdbee6 --- /dev/null +++ b/input/lux/data/id.lux @@ -0,0 +1,28 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Id a) + (| (#Id a))) + +## [Structures] +(defstruct #export Id/Functor (Functor Id) + (def (F;map f fa) + (let [(#Id a) fa] + (#Id (f a))))) + +(defstruct #export Id/Monad (Monad Id) + (def M;_functor Id/Functor) + (def (M;wrap a) (#Id a)) + (def (M;join mma) + (let [(#Id ma) mma] + ma))) diff --git a/input/lux/data/io.lux b/input/lux/data/io.lux index ab74daefd..c08023df5 100644 --- a/input/lux/data/io.lux +++ b/input/lux/data/io.lux @@ -27,12 +27,12 @@ (#;Left "Wrong syntax for io"))) ## Structures -(defstruct #export IO:Functor (F;Functor IO) +(defstruct #export IO/Functor (F;Functor IO) (def (F;map f ma) (io (f (ma []))))) -(defstruct #export IO:Monad (M;Monad IO) - (def M;_functor IO:Functor) +(defstruct #export IO/Monad (M;Monad IO) + (def M;_functor IO/Functor) (def (M;wrap x) (io x)) diff --git a/input/lux/data/list.lux b/input/lux/data/list.lux index edbdb6160..450dee275 100644 --- a/input/lux/data/list.lux +++ b/input/lux/data/list.lux @@ -6,7 +6,10 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import (lux #refer (#except reverse as-pairs)) +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)) lux/meta/macro) ## Types @@ -54,6 +57,10 @@ (#;Cons [x (filter p xs')]) (filter p xs')))) +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) + [(filter p xs) (filter (complement p) xs)]) + (def #export (as-pairs xs) (All [a] (-> (List a) (List (, a a)))) (case xs @@ -67,7 +74,7 @@ [(def #export (<name> n xs) (All [a] (-> Int (List a) (List a))) - (if (int:> n 0) + (if (i> n 0) (case xs #;Nil #;Nil @@ -97,16 +104,16 @@ [drop-while (drop-while p xs') xs] ) -(def #export (split-at n xs) +(def #export (split n xs) (All [a] (-> Int (List a) (, (List a) (List a)))) - (if (int:> n 0) + (if (i> n 0) (case xs #;Nil [#;Nil #;Nil] (#;Cons [x xs']) - (let [[tail rest] (split-at (dec n) xs')] + (let [[tail rest] (split (dec n) xs')] [(#;Cons [x tail]) rest])) [#;Nil xs])) @@ -131,7 +138,7 @@ (def #export (repeat n x) (All [a] (-> Int a (List a))) - (if (int:> n 0) + (if (i> n 0) (#;Cons [x (repeat (dec n) x)]) #;Nil)) @@ -175,7 +182,7 @@ (def #export (size list) (-> List Int) - (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) (do-template [<name> <init> <op>] [(def #export (<name> p xs) @@ -194,7 +201,7 @@ #;None (#;Cons [x xs']) - (if (int:= 0 i) + (if (i= 0 i) (#;Some x) (@ (dec i) xs')))) @@ -216,3 +223,28 @@ _ (#;Left "Wrong syntax for list&"))) + +## Structures +(defstruct #export List/Monoid (All [a] + (Monoid (List a))) + (def m;unit #;Nil) + (def (m;++ xs ys) + (case xs + #;Nil ys + (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + +(defstruct #export List/Functor (Functor List) + (def (F;map f ma) + (case ma + #;Nil #;Nil + (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + +(defstruct #export List/Monad (Monad List) + (def M;_functor List/Functor) + + (def (M;wrap a) + (#;Cons [a #;Nil])) + + (def (M;join mma) + (using List/Monoid + (foldL m;++ m;unit mma)))) diff --git a/input/lux/data/maybe.lux b/input/lux/data/maybe.lux new file mode 100644 index 000000000..faec53c2e --- /dev/null +++ b/input/lux/data/maybe.lux @@ -0,0 +1,42 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +## (deftype (Maybe a) +## (| #;None +## (#;Some a))) + +## [Structures] +(defstruct #export Maybe/Monoid (Monoid Maybe) + (def m;unit #;None) + (def (m;++ xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(defstruct #export Maybe/Functor (Functor Maybe) + (def (F;map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(defstruct #export Maybe/Monad (Monad Maybe) + (def M;_functor Maybe/Functor) + + (def (M;wrap x) + (#;Some x)) + + (def (M;join mma) + (case mma + #;None #;None + (#;Some xs) xs))) diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux index 7941daa4e..8203d2ecd 100644 --- a/input/lux/data/number.lux +++ b/input/lux/data/number.lux @@ -6,38 +6,52 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import lux) +(;import lux + (lux/control (monoid #as m)) + (lux/data (eq #as E) + (ord #as O) + (bounded #as B))) ## Signatures (defsig #export (Number n) - (: (-> n n n) - +) + (do-template [<name>] + [(: (-> n n n) + <name>)] + [+] [-] [*] [/] [%]) + ## (: (-> n n n) + ## +) - (: (-> n n n) - -) + ## (: (-> n n n) + ## -) - (: (-> n n n) - *) + ## (: (-> n n n) + ## *) - (: (-> n n n) - /) + ## (: (-> n n n) + ## /) - (: (-> n n n) - %) + ## (: (-> n n n) + ## %) (: (-> Int n) from-int) - (: (-> n n) - negate) + (do-template [<name>] + [(: (-> n n) + <name>)] + [negate] [signum] [abs]) + ## (: (-> n n) + ## negate) - (: (-> n n) - sign) + ## (: (-> n n) + ## signum) - (: (-> n n) - abs)) + ## (: (-> n n) + ## abs) + ) -## Structures +## [Structures] +## Number (do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] [(defstruct #export <name> (Number <type>) (def + <+>) @@ -53,12 +67,42 @@ (if (<<> x <0>) (<*> <-1> x) x)) - (def (sign x) + (def (signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else <1>)) )] - [Int:Number Int int:+ int:- int:* int:/ int:% int:= int:< id 0 1 -1] - [Real:Number Real real:+ real:- real:* real:/ real:% real:= real:< _jvm_l2d 0.0 1.0 -1.0]) + [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] + [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def E;= i=)) + +(defstruct #export Real/Eq (E;Eq Real) + (def E;= r=)) + +## Ord +(def #export Int/Ord (O;Ord Int) + (O;ord$ Int/Eq i< i>)) + +(def #export Real/Ord (O;Ord Real) + (O;ord$ Real/Eq r< r>)) + +## Monoid +(do-template [<name> <type> <unit> <++>] + [(defstruct #export <name> (m;Monoid <type>) + (def m;unit <unit>) + (def m;++ <++>))] + + [ IntAdd/Monoid Int 0 i+] + [ IntMul/Monoid Int 1 i*] + [RealAdd/Monoid Real 0.0 r+] + [RealMul/Monoid Real 1.0 r*] + [ IntMax/Monoid Int (:: B;Int/Bounded B;bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: B;Int/Bounded B;top) (O;min Int/Ord)] + [RealMax/Monoid Real (:: B;Real/Bounded B;bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: B;Real/Bounded B;top) (O;min Real/Ord)] + ) diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux index 573106830..60a6cc0a8 100644 --- a/input/lux/data/ord.lux +++ b/input/lux/data/ord.lux @@ -27,15 +27,15 @@ (All [a] (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) (struct - (def _eq eq) - (def < <) - (def (<= x y) - (or (< x y) - (:: eq (E;= x y)))) - (def > >) - (def (>= x y) - (or (> x y) - (:: eq (E;= x y)))))) + (def _eq eq) + (def < <) + (def (<= x y) + (or (< x y) + (:: eq (E;= x y)))) + (def > >) + (def (>= x y) + (or (> x y) + (:: eq (E;= x y)))))) ## Functions (do-template [<name> <op>] @@ -47,10 +47,3 @@ [max ;;>] [min ;;<]) - -## Structures -(def #export Int:Ord (Ord Int) - (ord$ E;Int:Eq int:< int:>)) - -(def #export Real:Ord (Ord Real) - (ord$ E;Real:Eq real:< real:>)) diff --git a/input/lux/data/reader.lux b/input/lux/data/reader.lux new file mode 100644 index 000000000..c3bbc2830 --- /dev/null +++ b/input/lux/data/reader.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import (lux #refer (#except Reader)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Reader r a) + (-> r a)) + +## [Structures] +(defstruct #export Reader/Functor (All [r] + (Functor (Reader r))) + (def (F;map f fa) + (lambda [env] + (f (fa env))))) + +(defstruct #export Reader/Monad (All [r] + (Monad (Reader r))) + (def M;_functor Reader/Functor) + + (def (M;wrap x) + (lambda [env] x)) + + (def (M;join mma) + (lambda [env] + (mma env env)))) diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux index 3748d481a..e081b9239 100644 --- a/input/lux/data/show.lux +++ b/input/lux/data/show.lux @@ -19,9 +19,9 @@ (def (show x) <body>))] - [Bool:Show Bool (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Int:Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Real:Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Char:Show Char (let [char (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Bool/Show Bool (_jvm_invokevirtual java.lang.Object toString [] x [])] + [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Char/Show Char (let [char (_jvm_invokevirtual java.lang.Object toString [] x [])] ($ text:++ "#\"" char "\""))] - [Text:Show Text x]) + [Text/Show Text x]) diff --git a/input/lux/data/state.lux b/input/lux/data/state.lux index 386c7be1d..bc9858a29 100644 --- a/input/lux/data/state.lux +++ b/input/lux/data/state.lux @@ -6,8 +6,30 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import lux) +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) -## Types +## [Types] (deftype #export (State s a) (-> s (, s a))) + +## [Structures] +(defstruct #export State/Functor (Functor State) + (def (F;map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(defstruct #export State/Monad (All [s] + (Monad (State s))) + (def M;_functor State/Functor) + + (def (M;wrap x) + (lambda [state] + [state x])) + + (def (M;join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux index 1a8587f46..5f2203376 100644 --- a/input/lux/data/text.lux +++ b/input/lux/data/text.lux @@ -18,8 +18,8 @@ (def #export (@ idx x) (-> Int Text (Maybe Char)) - (if (and (int:< idx (size x)) - (int:>= idx 0)) + (if (and (i< idx (size x)) + (i>= idx 0)) (#;Some (_jvm_invokevirtual java.lang.String charAt [int] x [(_jvm_l2i idx)])) #;None)) @@ -46,9 +46,9 @@ (def #export (sub' from to x) (-> Int Int Text (Maybe Text)) - (if (and (int:< from to) - (int:>= from 0) - (int:<= to (size x))) + (if (and (i< from to) + (i>= from 0) + (i<= to (size x))) (_jvm_invokevirtual java.lang.String substring [int int] x [(_jvm_l2i from) (_jvm_l2i to)]) #;None)) @@ -59,8 +59,8 @@ (def #export (split at x) (-> Int Text (Maybe (, Text Text))) - (if (and (int:< at (size x)) - (int:>= at 0)) + (if (and (i< at (size x)) + (i>= at 0)) (let [pre (_jvm_invokevirtual java.lang.String substring [int int] x [(_jvm_l2i 0) (_jvm_l2i at)]) post (_jvm_invokevirtual java.lang.String substring [int] @@ -76,8 +76,7 @@ (do-template [<common> <general> <method>] [(def #export (<general> pattern from x) (-> Text Int Text (Maybe Int)) - (if (and (int:< from (size x)) - (int:>= from 0)) + (if (and (i< from (size x)) (i>= from 0)) (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String int] x [pattern (_jvm_l2i from)])) -1 #;None @@ -108,32 +107,33 @@ (-> Text Text Bool) (case (last-index-of postfix x) (#;Some n) - (int:= (int:+ n (size postfix)) - (size x)) + (i= (i+ n (size postfix)) + (size x)) _ false)) -(defstruct #export Text:Eq (E;Eq Text) +## [Structures] +(defstruct #export Text/Eq (E;Eq Text) (def (E;= x y) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y]))) -(defstruct #export Text:Ord (O;Ord Text) - (def O;_eq Text:Eq) +(defstruct #export Text/Ord (O;Ord Text) + (def O;_eq Text/Eq) (def (O;< x y) - (int:< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) + (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) (def (O;<= x y) - (int:<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) + (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) (def (O;> x y) - (int:> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) + (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) (def (O;>= x y) - (int:>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0))) + (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0))) diff --git a/input/lux/data/writer.lux b/input/lux/data/writer.lux new file mode 100644 index 000000000..f71492e35 --- /dev/null +++ b/input/lux/data/writer.lux @@ -0,0 +1,34 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Writer l a) + (, l a)) + +## [Structures] +(defstruct #export Writer/Functor (All [l] + (Functor (Writer l))) + (def (F;map f fa) + (let [[log datum] fa] + [log (f datum)]))) + +(defstruct #export (Writer/Monad mon) (All [l] + (-> (Monoid l) (Monad (Writer l)))) + (def M;_functor Writer/Functor) + + (def (M;wrap x) + [(:: mon m;unit) x]) + + (def (M;join mma) + (let [[log1 [log2 a]] mma] + [(:: mon (m;++ log1 log2)) a]))) diff --git a/input/lux/host/java.lux b/input/lux/host/java.lux new file mode 100644 index 000000000..52391201d --- /dev/null +++ b/input/lux/host/java.lux @@ -0,0 +1,311 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (data list + (text #as text)) + (control (functor #as F) + (monad #as M #refer (#only do))) + (meta lux + macro + syntax))) + +## (open List/Functor) + +## [Utils/Parsers] +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (M;wrap [ex-class ex expr])))) + +(def method-decl^ + (Parser (, (List Text) Text (List Text) Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ local-symbol^)) + output local-symbol^ + _ end^] + (M;wrap [modifiers name inputs output])))) + +(def field-decl^ + (Parser (, (List Text) Text Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + class local-symbol^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (M;wrap [arg-name arg-class])))) + +(def method-def^ + (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + body id^ + _ end^] + (M;wrap [modifiers name inputs output body])))) + +(def method-call^ + (Parser (, Text (List Text) (List Syntax))) + (form^ (do Parser/Monad + [method local-symbol^ + arity-classes (tuple^ (*^ local-symbol^)) + arity-args (tuple^ (*^ id^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Utils/Lux] +## (def (find-class-field field class) +## (-> Text Text (Lux Type)) +## ...) + +## (def (find-virtual-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + +## (def (find-static-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches)) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally)))))))))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (text;++ (text;replace "/" "." current-module) + name)]] + (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + members))] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (~@ members')))))))) + +(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [fields (*^ field-decl^)] + [methods (*^ method-def^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (text;++ (text;replace "/" "." current-module) + name) + fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + fields)) + methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs)))] + (~ (text$ output)) + [(~@ (:: List/Functor (F;map text$ modifiers)))] + (~ body)))))) + methods))]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ fields')] + [(~@ methods')])))))) + +(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) + (emit (list (` (_jvm_new (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ args)]))))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "")] + (emit (list (` (;let [(~ g!lock) (~ lock) + _ (_jvm_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (list (` (_jvm_null? (~ obj)))))) + +(defsyntax #export (program [args symbol^] body) + (emit (list (` (_jvm_program (~ (symbol$ args)) + (~ body)))))) + +## (defsyntax #export (.? [field local-symbol^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) + +## _ +## (fail "Can only get field from object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.? (~ field) (~ g!obj))))))))) + +## (defsyntax #export (.= [field local-symbol^] value obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) + +## _ +## (fail "Can only set field of object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.= (~ field) (~ value) (~ g!obj))))))))) + +## (defsyntax #export (.! [call method-call^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-virtual-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] +## (~ obj) [(~@ m-args)]))))) + +## _ +## (fail "Can only call method on object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.! (~@ *tokens*))))))))) + +## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) +## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + +## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) +## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + +## (defsyntax #export (..! [call method-call^] [class local-symbol^]) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-static-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) +## [(~@ (:: List/Functor (F;map text$ m-ins)))] +## [(~@ m-args)])))) +## )) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public <init> [] void +## (_jvm_invokespecial java.lang.Object <init> [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## (<init> [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object <init> [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) diff --git a/input/lux/math.lux b/input/lux/math.lux new file mode 100644 index 000000000..2e29c5da7 --- /dev/null +++ b/input/lux/math.lux @@ -0,0 +1,60 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Constants] +(do-template [<name> <value>] + [(def #export <name> + Real + (_jvm_getstatic java.lang.Math <value>))] + + [e E] + [pi PI] + ) + +## [Functions] +(do-template [<name> <method>] + [(def #export (<name> n) + (-> Real Real) + (_jvm_invokestatic java.lang.Math <method> [double] [n]))] + + [cos cos] + [sin sin] + [tan tan] + + [acos acos] + [asin asin] + [atan atan] + + [cosh cosh] + [sinh sinh] + [tanh tanh] + + [ceil ceil] + [floor floor] + [round round] + + [exp exp] + [log log] + + [cbrt cbrt] + [sqrt sqrt] + + [->degrees toDegrees] + [->radians toRadians] + ) + +(do-template [<name> <method>] + [(def #export (<name> x y) + (-> Real Real Real) + (_jvm_invokestatic java.lang.Math <method> [double double] [x y]))] + + [atan2 atan2] + [pow pow] + ) diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux index bd4fab8b6..1fc739403 100644 --- a/input/lux/meta/lux.lux +++ b/input/lux/meta/lux.lux @@ -8,18 +8,25 @@ (;import lux (.. macro) - (lux/control (monoid #as m #refer (#only List:Monoid)) + (lux/control (monoid #as m) (functor #as F) (monad #as M #refer (#only do))) (lux/data list + maybe (show #as S))) -## Types +## [Types] ## (deftype (Lux a) ## (-> Compiler (Either Text (, Compiler a)))) -## Structures -(defstruct #export Lux:Functor (F;Functor Lux) +## [Utils] +(def (ident->text ident) + (-> Ident Text) + (let [[pre post] ident] + ($ text:++ pre ";" post))) + +## [Structures] +(defstruct #export Lux/Functor (F;Functor Lux) (def (F;map f fa) (lambda [state] (case (fa state) @@ -29,8 +36,8 @@ (#;Right [state' a]) (#;Right [state' (f a)]))))) -(defstruct #export Lux:Monad (M;Monad Lux) - (def M;_functor Lux:Functor) +(defstruct #export Lux/Monad (M;Monad Lux) + (def M;_functor Lux/Functor) (def (M;wrap x) (lambda [state] (#;Right [state x]))) @@ -68,7 +75,7 @@ (def (find-macro' modules current-module module name) (-> (List (, Text (Module Compiler))) Text Text Text (Maybe Macro)) - (do M;Maybe:Monad + (do Maybe/Monad [$module (get module modules) gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] (case (: (, Bool (DefData' Macro)) gdef) @@ -85,7 +92,7 @@ (def #export (find-macro ident) (-> Ident (Lux (Maybe Macro))) - (do Lux:Monad + (do Lux/Monad [current-module get-module-name] (let [[module name] ident] (: (Lux (Maybe Macro)) @@ -96,50 +103,56 @@ (-> Ident (Lux Ident)) (case ident ["" name] - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (M;wrap (: Ident [module-name name]))) _ - (:: Lux:Monad (M;wrap ident)))) + (:: Lux/Monad (M;wrap ident)))) (def #export (macro-expand syntax) (-> Syntax (Lux (List Syntax))) (case syntax (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) - (do Lux:Monad + (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] (case ?macro (#;Some macro) - (do Lux:Monad + (do Lux/Monad [expansion (macro args) - expansion' (M;map% Lux:Monad macro-expand expansion)] - (M;wrap (:: M;List:Monad (M;join expansion')))) + expansion' (M;map% Lux/Monad macro-expand expansion)] + (M;wrap (:: List/Monad (M;join expansion')))) #;None - (do Lux:Monad - [parts' (M;map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))] - (M;wrap (list (form$ (:: M;List:Monad (M;join parts')))))))) + (do Lux/Monad + [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) - (do Lux:Monad + (do Lux/Monad [harg+ (macro-expand harg) - targs+ (M;map% Lux:Monad macro-expand targs)] - (M;wrap (list (form$ (list:++ harg+ (:: M;List:Monad (M;join (: (List (List Syntax)) targs+)))))))) + targs+ (M;map% Lux/Monad macro-expand targs)] + (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) (#;Meta [_ (#;TupleS members)]) - (do Lux:Monad - [members' (M;map% Lux:Monad macro-expand members)] - (M;wrap (list (tuple$ (:: M;List:Monad (M;join members')))))) + (do Lux/Monad + [members' (M;map% Lux/Monad macro-expand members)] + (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) _ - (:: Lux:Monad (M;wrap (list syntax))))) + (:: Lux/Monad (M;wrap (list syntax))))) (def #export (gensym prefix state) (-> Text (Lux Syntax)) (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: S;Int:Show (S;show (get@ #;seed state)))])])) + (symbol$ ["__gensym__" (:: S;Int/Show (S;show (get@ #;seed state)))])])) + +(def #export (emit datum) + (All [a] + (-> a (Lux a))) + (lambda [state] + (#;Right [state datum]))) (def #export (fail msg) (All [a] @@ -149,7 +162,7 @@ (def #export (macro-expand-1 token) (-> Syntax (Lux Syntax)) - (do Lux:Monad + (do Lux/Monad [token+ (macro-expand token)] (case token+ (\ (list token')) @@ -171,7 +184,7 @@ (-> Text (Lux (List Text))) (case (get module (get@ #;modules state)) (#;Some =module) - (using M;List:Monad + (using List/Monad (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) (List Text)) (lambda [gdef] @@ -183,3 +196,91 @@ #;None (#;Left ($ text:++ "Unknown module: " module)))) + +(def (show-envs envs) + (-> (List (Env Text (, LuxVar Type))) Text) + (|> envs + (F;map (lambda [env] + (case env + {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} + ($ text:++ name ": " (|> locals + (F;map (: (All [a] (-> (, Text a) Text)) + (lambda [b] (let [[label _] b] label)))) + (:: List/Functor) + (interpose " ") + (foldL text:++ "")))))) + (:: List/Functor) + (interpose "\n") + (foldL text:++ ""))) + +(def (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def (find-in-env name state) + (-> Ident Compiler (Maybe Type)) + (let [vname' (ident->text name)] + (case state + {#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;seen-sources seen-sources #;eval? eval?} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#;Some type) + #;None))))) + locals + closure)))) + envs)))) + +(def (find-in-defs name state) + (-> Ident Compiler (Maybe Type)) + (let [[v-prefix v-name] name + {#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;seen-sources seen-sources #;eval? eval?} state] + (case (get v-prefix modules) + #;None + #;None + + (#;Some {#;defs defs #;module-aliases _ #;imports _}) + (case (get v-name defs) + #;None + #;None + + (#;Some [_ def-data]) + (case def-data + #;TypeD (#;Some Type) + (#;ValueD type) (#;Some type) + (#;MacroD m) (#;Some Macro) + (#;AliasD name') (find-in-defs name' state)))))) + +(def #export (find-var-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (: (Lux Type) + (lambda [state] + (case (find-in-env name state) + (#;Some struct-type) + (#;Right [state struct-type]) + + _ + (case (find-in-defs name' state) + (#;Some struct-type) + (#;Right [state struct-type]) + + _ + (let [{#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;seen-sources seen-sources #;eval? eval?} state] + (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + )) diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux index cf08ff0eb..3c9a9ce2e 100644 --- a/input/lux/meta/syntax.lux +++ b/input/lux/meta/syntax.lux @@ -8,7 +8,7 @@ (;import lux (.. (macro #as m #refer #all) - lux) + (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) (monad #as M #refer (#only do))) (data list))) @@ -19,12 +19,18 @@ (let [[x y] xy] x)) +(def (join-pairs pairs) + (All [a] (-> (List (, a a)) (List a))) + (case pairs + #;Nil #;Nil + (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + ## Types (deftype #export (Parser a) (-> (List Syntax) (Maybe (, (List Syntax) a)))) ## Structures -(defstruct #export Parser:Functor (F;Functor Parser) +(defstruct #export Parser/Functor (F;Functor Parser) (def (F;map f ma) (lambda [tokens] (case (ma tokens) @@ -34,8 +40,8 @@ (#;Some [tokens' a]) (#;Some [tokens' (f a)]))))) -(defstruct #export Parser:Monad (M;Monad Parser) - (def M;_functor Parser:Functor) +(defstruct #export Parser/Monad (M;Monad Parser) + (def M;_functor Parser/Functor) (def (M;wrap x tokens) (#;Some [tokens x])) @@ -75,6 +81,20 @@ [ tag^ Ident #;TagS] ) +(do-template [<name> <tag>] + [(def #export (<name> tokens) + (Parser Text) + (case tokens + (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [local-symbol^ #;SymbolS] + [ local-tag^ #;TagS] + ) + (def (bool:= x y) (-> Bool Bool Bool) (if x @@ -101,8 +121,8 @@ #;None))] [ bool?^ Bool #;BoolS bool:=] - [ int?^ Int #;IntS int:=] - [ real?^ Real #;RealS real:=] + [ int?^ Int #;IntS i=] + [ real?^ Real #;RealS r=] ## [ char?^ Char #;CharS char:=] [ text?^ Text #;TextS text:=] [symbol?^ Ident #;SymbolS ident:=] @@ -143,7 +163,7 @@ (-> (Parser a) (Parser (List a)))) (case (p tokens) #;None (#;Some [tokens (list)]) - (#;Some [tokens' x]) (run-parser (do Parser:Monad + (#;Some [tokens' x]) (run-parser (do Parser/Monad [xs (*^ p)] (M;wrap (list& x xs))) tokens'))) @@ -151,7 +171,7 @@ (def #export (+^ p) (All [a] (-> (Parser a) (Parser (List a)))) - (do Parser:Monad + (do Parser/Monad [x p xs (*^ p)] (M;wrap (list& x xs)))) @@ -159,7 +179,7 @@ (def #export (&^ p1 p2) (All [a b] (-> (Parser a) (Parser b) (Parser (, a b)))) - (do Parser:Monad + (do Parser/Monad [x1 p1 x2 p2] (M;wrap [x1 x2]))) @@ -169,7 +189,7 @@ (-> (Parser a) (Parser b) (Parser (Either b)))) (case (p1 tokens) (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) - #;None (run-parser (do Parser:Monad + #;None (run-parser (do Parser/Monad [x2 p2] (M;wrap (#;Right x2))) tokens))) @@ -192,46 +212,53 @@ ## Syntax (defmacro #export (defsyntax tokens) - (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) - body)) - (do Lux:Monad - [names+parsers (M;map% Lux:Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [arg] - (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) - (M;wrap [(symbol$ var-name) parser]) - - _ - (fail "Syntax pattern expects 2-tuples.")))) - args) - g!tokens (gensym "tokens") - #let [names (:: F;List:Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) - parsing (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (let [[exported? tokens] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens]))] + (case tokens + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + body)) + (do Lux/Monad + [names+parsers (M;map% Lux/Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [arg] + (case arg + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) + (M;wrap [(symbol$ var-name) parser]) + + (\ (#;Meta [_ (#;SymbolS var-name)])) + (M;wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) + g!tokens (gensym "tokens") + g!_ (gensym "_") + #let [names (:: List/Functor (F;map first names+parsers)) + error-msg (text$ (text:++ "Wrong syntax for " name)) + body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) (lambda [body name+parser] (let [[name parser] name+parser] (` (_lux_case ((~ parser) (~ g!tokens)) (#;Some [(~ g!tokens) (~ name)]) (~ body) - _ - #;None))))) - (: Syntax (` (#;Some [(~@ names)]))) + (~ g!_) + (l;fail (~ error-msg))))))) + body (reverse names+parsers)) - body' (: Syntax - (` (_lux_case (~ parsing) - (#;Some [#;Nil [(~@ names)]]) - (~ body) - - _ - (l;fail (~ (text$ (text:++ "Wrong syntax for " name))))))) - macro-def (: Syntax - (` (m/defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] - (M;wrap (list macro-def))) - - _ - (fail "Wrong syntax for defsyntax"))) + macro-def (: Syntax + (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] + (M;wrap (list& macro-def + (if exported? + (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list))))) + + _ + (l;fail "Wrong syntax for defsyntax")))) diff --git a/input/program.lux b/input/program.lux index 6495854c1..19ee964e2 100644 --- a/input/program.lux +++ b/input/program.lux @@ -1,25 +1,35 @@ (;import lux - (lux (control monoid + (lux (codata (stream #as S)) + (control monoid functor monad lazy comonad) - (data eq - bounded - ord + (data bounded + ## cont + dict + (either #as e) + eq + error + id io list - state + maybe number + ord + (reader #as r) + show + state (text #as t) - dict - show) - (codata (stream #refer (#except iterate))) + writer) + (host java) (meta lux macro - syntax))) + syntax) + math + )) -(_jvm_program args +(program args (case args #;Nil (println "Hello, world!") diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8c8be29d2..782ae4685 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -26,214 +26,128 @@ ["lux;Nil" _]]]]]]]]] (&/T catch+ ?finally-body))) -(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] - (defn ^:private aba1 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] - ;; Standard special forms - [["lux;BoolS" ?value]] - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - - [["lux;IntS" ?value]] - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - - [["lux;RealS" ?value]] - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - - [["lux;CharS" ?value]] - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - - [["lux;TextS" ?value]] - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - - [["lux;TupleS" ?elems]] - (&&lux/analyse-tuple analyse exo-type ?elems) - - [["lux;RecordS" ?elems]] - (&&lux/analyse-record analyse exo-type ?elems) - - [["lux;TagS" ?ident]] - (&&lux/analyse-variant analyse exo-type ?ident unit) - - [["lux;SymbolS" [_ "_jvm_null"]]] - (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) - - [_] - (fail "") - ))) - -(defn ^:private aba2 [analyse eval! compile-module exo-type token] +(defn ^:private aba7 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - [["lux;SymbolS" ?ident]] - (&&lux/analyse-symbol analyse exo-type ?ident) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] - ["lux;Cons" [?value ?branches]]]]]] - (&&lux/analyse-case analyse exo-type ?value ?branches) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] - (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Cons" [?value + ;; Arrays + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-def analyse ?name ?value) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-declare-macro analyse ?name) + (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-import analyse compile-module ?path) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + ["lux;Cons" [?elem + ["lux;Nil" _]]]]]]]]]]] + (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-check analyse eval! exo-type ?type ?value) + (&&host/analyse-jvm-aaload analyse ?array ?idx) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) + ;; Classes & interfaces + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] + ?methods]]]]]]]]]]]] + (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-export analyse ?ident) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] + ?methods]]]]]]]] + (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ;; Programs + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] + ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-alias analyse ?alias ?module) + (&&host/analyse-jvm-program analyse ?args ?body) [_] (fail ""))) -(defn ^:private aba3 [analyse eval! compile-module exo-type token] +(defn ^:private aba6 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Host special forms - ;; Integer arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-iadd analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-isub analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-imul analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-idiv analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-irem analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ieq analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ilt analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-igt analyse ?x ?y) - - ;; Long arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ladd analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lsub analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lmul analyse ?x ?y) + ;; Primitive conversions + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2f analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ldiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2i analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lrem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2l analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-leq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2d analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-llt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2i analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2l analyse ?value) - [_] - (fail ""))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2b analyse ?value) -(defn ^:private aba4 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] - ;; Float arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fadd analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2c analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fsub analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2d analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fmul analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2f analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fdiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2l analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-frem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2s analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-feq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2d analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-flt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2f analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2i analyse ?value) - ;; Double arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dadd analyse ?x ?y) + ;; Bitwise operators + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-iand analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dsub analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ior analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dmul analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-land analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ddiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lor analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-drem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lxor analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-deq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lshl analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dlt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lshr analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lushr analyse ?x ?y) [_] - (fail ""))) + (aba7 analyse eval! compile-module exo-type token))) (defn ^:private aba5 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] @@ -242,6 +156,12 @@ ["lux;Cons" [?object ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-null? analyse ?object) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [?object + ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-instanceof analyse ?class ?object) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] @@ -336,130 +256,226 @@ (&&host/analyse-jvm-monitorexit analyse ?monitor) [_] - (fail ""))) + (aba6 analyse eval! compile-module exo-type token))) -(defn ^:private aba6 [analyse eval! compile-module exo-type token] +(defn ^:private aba4 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Primitive conversions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2f analyse ?value) + ;; Float arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fadd analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2i analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fsub analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2l analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fmul analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2d analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fdiv analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2i analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-frem analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2l analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-feq analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2b analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-flt analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2c analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fgt analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2d analyse ?value) + ;; Double arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dadd analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2f analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dsub analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2l analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dmul analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2s analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ddiv analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2d analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-drem analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2f analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-deq analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2i analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dlt analyse ?x ?y) - ;; Bitwise operators - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-iand analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dgt analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ior analyse ?x ?y) + [_] + (aba5 analyse eval! compile-module exo-type token))) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-land analyse ?x ?y) +(defn ^:private aba3 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; Host special forms + ;; Characters + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ceq analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lor analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-clt analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lxor analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-cgt analyse ?x ?y) + + ;; Integer arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-iadd analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lshl analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-isub analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lshr analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-imul analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lushr analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-idiv analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-irem analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ieq analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ilt analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-igt analyse ?x ?y) + + ;; Long arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ladd analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lsub analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lmul analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ldiv analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lrem analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-leq analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-llt analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lgt analyse ?x ?y) [_] - (fail ""))) + (aba4 analyse eval! compile-module exo-type token))) -(defn ^:private aba7 [analyse eval! compile-module exo-type token] +(defn ^:private aba2 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Arrays - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-new-array analyse ?class ?length) + [["lux;SymbolS" ?ident]] + (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Cons" [?elem + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] + ["lux;Cons" [?value ?branches]]]]]] + (&&lux/analyse-case analyse exo-type ?value ?branches) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] + ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) + (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] + ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-aaload analyse ?array ?idx) + (&&lux/analyse-def analyse ?name ?value) - ;; Classes & interfaces - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ?methods]]]]]]]]]]]] - (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-declare-macro analyse ?name) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] - ?methods]]]]]]]] - (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-import analyse compile-module ?path) - ;; Programs - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] - ["lux;Cons" [?body + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] + ["lux;Cons" [?type + ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-program analyse ?args ?body) + (&&lux/analyse-check analyse eval! exo-type ?type ?value) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] + ["lux;Cons" [?type + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-export analyse ?ident) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-alias analyse ?alias ?module) [_] - (fail ""))) + (aba3 analyse eval! compile-module exo-type token))) + +(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] + (defn ^:private aba1 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; Standard special forms + [["lux;BoolS" ?value]] + (|do [_ (&type/check exo-type &type/Bool)] + (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) + + [["lux;IntS" ?value]] + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&/T (&/V "int" ?value) exo-type)))) + + [["lux;RealS" ?value]] + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&/T (&/V "real" ?value) exo-type)))) + + [["lux;CharS" ?value]] + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + + [["lux;TextS" ?value]] + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + + [["lux;TupleS" ?elems]] + (&&lux/analyse-tuple analyse exo-type ?elems) + + [["lux;RecordS" ?elems]] + (&&lux/analyse-record analyse exo-type ?elems) + + [["lux;TagS" ?ident]] + (&&lux/analyse-variant analyse exo-type ?ident unit) + + [["lux;SymbolS" [_ "_jvm_null"]]] + (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) + + [_] + (aba2 analyse eval! compile-module exo-type token) + ))) (defn ^:private add-loc [meta ^String msg] (if (.startsWith msg "@") @@ -477,55 +493,7 @@ (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba2 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba3 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba4 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba5 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba6 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba7 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) + (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) [["lux;Left" msg]] (fail* (add-loc meta msg)) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6dfa234bd..267bd1269 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -63,28 +63,31 @@ (return (&/T (&/V "TextTestAC" ?value) =kont))) [["lux;TupleS" ?members]] - (matchv ::M/objects [value-type] - [["lux;TupleT" ?member-types]] - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Analyser error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V "TupleTestAC" =tests) =kont)))) - - [_] - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type value-type)))) + (|do [value-type* (resolve-type value-type)] + (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) + (matchv ::M/objects [value-type*] + [["lux;TupleT" ?member-types]] + (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V "TupleTestAC" =tests) =kont))))) + + [_] + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) [["lux;RecordS" ?slots]] (|do [value-type* (resolve-type value-type)] (matchv ::M/objects [value-type*] [["lux;RecordT" ?slot-types]] (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) - (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) + (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] (matchv ::M/objects [sn] @@ -93,17 +96,17 @@ (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] (return (&/T (&/|put =tag =test =tests) =kont))) - (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag)))) + (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) [_] - (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) + (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) (|do [=kont kont] (return (&/T (&/|table) =kont))) (&/|reverse ?slots))] (return (&/T (&/V "RecordTestAC" =tests) =kont)))) [_] - (fail "[Analyser Error] Record requires record-type."))) + (fail "[Pattern-matching Error] Record requires record-type."))) [["lux;TagS" ?ident]] (|do [=tag (&&/resolved-ident ?ident) @@ -182,7 +185,7 @@ (merge-total v (&/T t ?body))) ?values ?tests)] (return (&/V "TupleTotal" (&/T total? structs)))) - (fail "[Pattern-matching error] Inconsistent tuple-size.")) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) [["DefaultTotal" total?] ["RecordTestAC" ?tests]] (|do [structs (&/map% (fn [t] @@ -203,14 +206,14 @@ (if (.equals ^Object lslot rslot) (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] (return (&/T lslot sub-struct*))) - (fail "[Pattern-matching error] Record slots mismatch.")))) + (fail "[Pattern-matching Error] Record slots mismatch.")))) ?values (->> ?tests &/->seq (sort compare-kv) &/->list))] (return (&/V "RecordTotal" (&/T total? structs)))) - (fail "[Pattern-matching error] Inconsistent record-size.")) + (fail "[Pattern-matching Error] Inconsistent record-size.")) [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) @@ -245,15 +248,16 @@ [["TupleTotal" [?total ?structs]]] (if ?total (return true) - (matchv ::M/objects [value-type] - [["lux;TupleT" ?members]] - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (|do [value-type* (resolve-type value-type)] + (matchv ::M/objects [value-type*] + [["lux;TupleT" ?members]] + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) - [_] - (fail ""))) + [_] + (fail "[Pattern-maching Error] Tuple is not total.")))) [["RecordTotal" [?total ?structs]]] (if ?total @@ -270,7 +274,7 @@ (return (&/fold #(and %1 %2) true totals))) [_] - (fail "")))) + (fail "[Pattern-maching Error] Record is not total.")))) [["VariantTotal" [?total ?structs]]] (if ?total @@ -287,7 +291,7 @@ (return (&/fold #(and %1 %2) true totals))) [_] - (fail "")))) + (fail "[Pattern-maching Error] Variant is not total.")))) [["DefaultTotal" ?total]] (return ?total) @@ -304,4 +308,4 @@ ? (check-totality value-type struct)] (if ? (return patterns) - (fail "[Pattern-maching error] Pattern-matching is non-total.")))) + (fail "[Pattern-maching Error] Pattern-matching is non-total.")))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 3db4bd16d..918bcb8f1 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -54,6 +54,10 @@ analyse-jvm-ilt "jvm-ilt" "java.lang.Integer" "java.lang.Boolean" analyse-jvm-igt "jvm-igt" "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-ceq "jvm-ceq" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-clt "jvm-clt" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-cgt "jvm-cgt" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-ladd "jvm-ladd" "java.lang.Long" "java.lang.Long" analyse-jvm-lsub "jvm-lsub" "java.lang.Long" "java.lang.Long" analyse-jvm-lmul "jvm-lmul" "java.lang.Long" "java.lang.Long" @@ -93,21 +97,37 @@ (defn analyse-jvm-putstatic [analyse ?class ?field ?value] (|do [=type (&host/lookup-static-field ?class ?field) - =value (&&/analyse-1 analyse ?value)] + =value (&&/analyse-1 analyse =type ?value)] (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) =type))))) (defn analyse-jvm-putfield [analyse ?class ?field ?object ?value] (|do [=type (&host/lookup-static-field ?class ?field) =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse ?value)] + =value (&&/analyse-1 analyse =type ?value)] (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) =type))))) (defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] (|do [=classes (&/map% &host/extract-jvm-param ?classes) =return (&host/lookup-static-method ?class ?method =classes) - =args (&/flat-map% analyse ?args)] + :let [_ (matchv ::M/objects [=return] + [["lux;DataT" _return-class]] + (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] + =args (&/map2% (fn [_class _arg] + (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) + =classes + ?args)] (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) =return))))) +(defn analyse-jvm-instanceof [analyse ?class ?object] + (|do [=object (analyse-1+ analyse ?object) + :let [[_obj _type] =object]] + (matchv ::M/objects [_type] + [["lux;DataT" _]] + (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class ?object)) (&/V "lux;DataT" "java.lang.Boolean")))) + + [_] + (fail "[Analyser Error] Can only use instanceof with object types.")))) + (do-template [<name> <tag>] (defn <name> [analyse ?class ?method ?classes ?object ?args] (|do [=classes (&/map% &host/extract-jvm-param ?classes) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index d02599f10..75881c80a 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -248,11 +248,11 @@ [["lux;MacroD" macro]] (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) :let [_ (when (and ;; (= "lux/control/monad" ?module) - (= "do" ?name)) + (= "case" ?name)) (->> (&/|map &/show-ast macro-expansion) (&/|interpose "\n") (&/fold str "") - (prn ?module "do")))] + (prn ?module "case")))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) @@ -310,7 +310,9 @@ [["lux;VarT" ?id]] (|do [? (&type/bound? ?id)] (if ? - (|do [dtype (&type/deref ?id)] + (|do [dtype (&type/deref ?id) + ;; dtype* (&type/actual-type dtype) + ] (matchv ::M/objects [dtype] [["lux;ExT" _]] (return (&/T _expr exo-type)) @@ -341,7 +343,7 @@ (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? - (fail (str "[Analyser Error] Can't redefine " ?name)) + (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] diff --git a/src/lux/base.clj b/src/lux/base.clj index d88bb2ec1..e22e51473 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -158,7 +158,6 @@ )))) (defmacro |do [steps return] - (assert (not= 0 (count steps)) "The steps can't be empty!") (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") (reduce (fn [inner [label computation]] (case label @@ -330,6 +329,9 @@ map% |cons flat-map% |++) +(defn list-join [xss] + (fold |++ (V "lux;Nil" nil) xss)) + (defn |as-pairs [xs] (matchv ::M/objects [xs] [["lux;Cons" [x ["lux;Cons" [y xs*]]]]] @@ -669,6 +671,14 @@ [_ _] (fail "Lists don't match in size."))) +(defn map2 [f xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|cons (f x y) (map2 f xs* ys*)) + + [_ _] + (V "lux;Nil" nil))) + (defn fold2 [f init xs ys] (matchv ::M/objects [xs ys] [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 04f4fb4c2..559c1179b 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -74,6 +74,16 @@ [["ann" [?value-ex ?type-ex]]] (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) + + ;; Characters + [["jvm-ceq" [?x ?y]]] + (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) + + [["jvm-clt" [?x ?y]]] + (&&host/compile-jvm-clt compile-expression ?type ?x ?y) + + [["jvm-cgt" [?x ?y]]] + (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) ;; Integer arithmetic [["jvm-iadd" [?x ?y]]] @@ -297,6 +307,9 @@ [["jvm-lushr" [?x ?y]]] (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) + + [["jvm-instanceof" [?class ?object]]] + (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) ) )) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 2a8bdac89..5c2c43296 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -144,6 +144,10 @@ compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I" compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I" compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" + + compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C" + compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C" + compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C" ) (do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>] @@ -186,12 +190,12 @@ (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] - _ (&/map% (fn [[class-name arg]] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) (prepare-return! *type*))]] @@ -319,6 +323,14 @@ ;; else 0))) +(defn compile-jvm-instanceof [compile *type* class object] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile object) + :let [_ (doto *writer* + (.visitLdcInsn class) + (.visitTypeInsn Opcodes/INSTANCEOF class))]] + (return nil))) + (defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] (|do [module &/get-module-name] (let [super-class* (&host/->class ?super-class) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 7d6b2b502..ecb614732 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -25,17 +25,6 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) -(defn compile-int [compile *type* value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW "java/lang/Long") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (bit-shift-left (long value) 0) - ;; (bit-shift-left (long value) 32) - ) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Long" "<init>" "(J)V"))]] - (return nil))) - (do-template [<name> <class> <sig> <caster>] (defn <name> [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer @@ -46,7 +35,7 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]] (return nil))) - ;; compile-int "java/lang/Long" "(J)V" long + compile-int "java/lang/Long" "(J)V" long compile-real "java/lang/Double" "(D)V" double compile-char "java/lang/Character" "(C)V" char ) |