diff options
4 files changed, 270 insertions, 47 deletions
diff --git a/luxc/src/lux/compiler/jvm/proc/host.clj b/luxc/src/lux/compiler/jvm/proc/host.clj index 91c39effb..11cf39ee9 100644 --- a/luxc/src/lux/compiler/jvm/proc/host.clj +++ b/luxc/src/lux/compiler/jvm/proc/host.clj @@ -173,8 +173,9 @@ _ (.visitInsn writer Opcodes/ARETURN))) -(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor] +(defn ^:private prepare-method-input "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" + [idx input ^MethodVisitor method-visitor] (|case input [_ (&/$GenericClass name params)] (case name @@ -225,8 +226,9 @@ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) )) -(defn ^:private prepare-method-inputs [idx inputs method-visitor] +(defn ^:private prepare-method-inputs "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" + [idx inputs method-visitor] (|case inputs (&/$Nil) (return &/$Nil) @@ -437,8 +439,9 @@ (return nil))))) ) -(defn ^:private constant-inits [fields] +(defn ^:private constant-inits "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" + [fields] (&/fold &/|++ &/$Nil (&/|map (fn [field] diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index d3fea1152..dfcbd8f84 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -3,35 +3,45 @@ [abstract ["." monad (#+ do)]] [control - ["ex" exception (#+ exception:)] - ["p" parser ("#@." monad) - ["l" text]]] + ["." exception (#+ exception:)] + ["<>" parser ("#@." monad) + ["<t>" text] + ["<s>" synthesis]]] [data ["." product] + ["." maybe] ["." error] + [number + ["." nat]] ["." text format] [collection - ["." list ("#@." functor)] - ["." dictionary (#+ Dictionary)]]] + ["." list ("#@." monad)] + ["." dictionary (#+ Dictionary)] + ["." set]]] [target [jvm ["_t" type (#+ Primitive Type Method)]]] [tool [compiler - ["." synthesis (#+ Synthesis %synthesis)] + [analysis (#+ Environment)] + ["." reference (#+ Variable)] + ["." synthesis (#+ Synthesis Path %synthesis)] ["." phase ("#@." monad) - [generation + ["." generation [extension (#+ Nullary Unary Binary nullary unary binary)]] ["." extension - ["." bundle]]]]] + ["." bundle] + [analysis + ["/" jvm]]]]]] [host (#+ import:)]] [luxc [lang [host - ["$" jvm (#+ Label Inst Handler Bundle Operation) - ["_" inst]]]]]) + ["$" jvm (#+ Label Inst Handler Bundle Operation Phase) + ["_" inst] + ["_." def]]]]]) (template [<name>] [(exception: #export (<name> {message Text}) @@ -662,31 +672,31 @@ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) (def: base-type - (l.Parser Type) - ($_ p.either - (p.after (l.this "boolean") (p@wrap _t.boolean)) - (p.after (l.this "byte") (p@wrap _t.byte)) - (p.after (l.this "short") (p@wrap _t.short)) - (p.after (l.this "int") (p@wrap _t.int)) - (p.after (l.this "long") (p@wrap _t.long)) - (p.after (l.this "float") (p@wrap _t.float)) - (p.after (l.this "double") (p@wrap _t.double)) - (p.after (l.this "char") (p@wrap _t.char)) - (p@map (function (_ name) - (_t.class name (list))) - (l.many (l.none-of "["))) + (<t>.Parser Type) + ($_ <>.either + (<>.after (<t>.this "boolean") (<>@wrap _t.boolean)) + (<>.after (<t>.this "byte") (<>@wrap _t.byte)) + (<>.after (<t>.this "short") (<>@wrap _t.short)) + (<>.after (<t>.this "int") (<>@wrap _t.int)) + (<>.after (<t>.this "long") (<>@wrap _t.long)) + (<>.after (<t>.this "float") (<>@wrap _t.float)) + (<>.after (<t>.this "double") (<>@wrap _t.double)) + (<>.after (<t>.this "char") (<>@wrap _t.char)) + (<>@map (function (_ name) + (_t.class name (list))) + (<t>.many (<t>.none-of "["))) )) (def: java-type - (l.Parser Type) - (do p.monad + (<t>.Parser Type) + (do <>.monad [raw base-type - nesting (p.some (l.this "[]"))] + nesting (<>.some (<t>.this "[]"))] (wrap (_t.array (list.size nesting) raw)))) (def: (generate-type argD) (-> Text (Operation Type)) - (case (l.run argD java-type) + (case (<t>.run argD java-type) (#error.Failure error) (phase.throw invalid-syntax-for-jvm-type argD) @@ -808,6 +818,199 @@ (bundle.install "constructor" invoke::constructor)))) ))) +(def: (custom [parser handler]) + (All [s] + (-> [(<s>.Parser s) + (-> Text Phase s (Operation Inst))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run input parser) + (#error.Success input') + (handler extension-name phase input') + + (#error.Failure error) + (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) + +(def: jvm-type + (<s>.Parser /.JVM-Type) + (<>.rec + (function (_ jvm-type) + (<s>.tuple (<>.and <s>.text (<>.some jvm-type)))))) + +(def: constructor-arg + (<s>.Parser (/.Constructor-Argument Synthesis)) + (<s>.tuple (<>.and ..jvm-type <s>.any))) + +(def: annotation-parameter + (<s>.Parser (/.Annotation-Parameter Synthesis)) + (<s>.tuple (<>.and <s>.text <s>.any))) + +(def: annotation + (<s>.Parser (/.Annotation Synthesis)) + (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter)))) + +(def: type-parameter + (<s>.Parser /.Type-Parameter) + <s>.text) + +(def: argument + (<s>.Parser /.Argument) + (<s>.tuple (<>.and <s>.text ..jvm-type))) + +(def: overriden-method-definition + (<s>.Parser [Environment (/.Overriden-Method Synthesis)]) + (<s>.tuple (do <>.monad + [ownerT ..jvm-type + name <s>.text + strict-fp? <s>.bit + annotations (<s>.tuple (<>.some ..annotation)) + type-parameters (<s>.tuple (<>.some ..type-parameter)) + self-name <s>.text + arguments (<s>.tuple (<>.some ..argument)) + returnT ..jvm-type + exceptionsT (<s>.tuple (<>.some ..jvm-type)) + [environment body] (<s>.function 1 + (<s>.tuple <s>.any))] + (wrap [environment + [ownerT name + strict-fp? annotations type-parameters + self-name arguments returnT exceptionsT + body]])))) + +(def: (normalize-path normalize) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (recur path) + (case path + (^ (synthesis.path/then bodyS)) + (synthesis.path/then (normalize bodyS)) + + (^template [<tag>] + (^ (<tag> leftP rightP)) + (<tag> (recur leftP) (recur rightP))) + ([#synthesis.Alt] + [#synthesis.Seq]) + + (^template [<tag>] + (^ (<tag> value)) + path) + ([#synthesis.Pop] + [#synthesis.Test] + [#synthesis.Bind] + [#synthesis.Access])))) + +(def: (normalize-method-body mapping) + (-> (Dictionary Variable Variable) Synthesis Synthesis) + (function (recur body) + (case body + (^template [<tag>] + (^ (<tag> value)) + body) + ([#synthesis.Primitive] + [synthesis.constant]) + + (^ (synthesis.variant [lefts right? sub])) + (synthesis.variant [lefts right? (recur sub)]) + + (^ (synthesis.tuple members)) + (synthesis.tuple (list@map recur members)) + + (^ (synthesis.variable var)) + (|> mapping + (dictionary.get var) + (maybe.default var) + synthesis.variable) + + (^ (synthesis.branch/case [inputS pathS])) + (synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) + + (^ (synthesis.branch/let [inputS register outputS])) + (synthesis.branch/let [(recur inputS) register (recur outputS)]) + + (^ (synthesis.branch/if [testS thenS elseS])) + (synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) + + (^ (synthesis.loop/scope [offset initsS+ bodyS])) + (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) + + (^ (synthesis.loop/recur updatesS+)) + (synthesis.loop/recur (list@map recur updatesS+)) + + (^ (synthesis.function/abstraction [environment arity bodyS])) + (synthesis.function/abstraction [(|> environment (list@map (function (_ local) + (|> mapping + (dictionary.get local) + (maybe.default local))))) + arity + bodyS]) + + (^ (synthesis.function/apply [functionS inputsS+])) + (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) + + (#synthesis.Extension [name inputsS+]) + (#synthesis.Extension [name (list@map recur inputsS+)])))) + +(def: class::anonymous + Handler + (..custom + [($_ <>.and + <s>.text + ..jvm-type + (<s>.tuple (<>.some ..jvm-type)) + (<s>.tuple (<>.some ..constructor-arg)) + (<s>.tuple (<>.some ..overriden-method-definition))) + (function (_ extension-name generate [class-name + super-class super-interfaces + constructor-args + overriden-methods]) + (do phase.monad + [#let [global-mapping (|> overriden-methods + ## Get all the environments. + (list@map product.left) + ## Combine them. + list@join + ## Remove duplicates. + (set.from-list reference.hash) + set.to-list + ## Give them names as "foreign" variables. + list.enumerate + (list@map (function (_ [id capture]) + [capture (#reference.Foreign id)])) + (dictionary.from-list reference.hash)) + normalized-methods (list@map (function (_ [environment + [ownerT name + strict-fp? annotations type-parameters + self-name arguments returnT exceptionsT + body]]) + (let [local-mapping (|> environment + list.enumerate + (list@map (function (_ [foreign-id capture]) + [(#reference.Foreign foreign-id) + (|> global-mapping + (dictionary.get capture) + maybe.assume)])) + (dictionary.from-list reference.hash))] + [ownerT name + strict-fp? annotations type-parameters + self-name arguments returnT exceptionsT + (normalize-method-body local-mapping body)])) + overriden-methods)] + ## _ (generation.save! true ["" function-class] + ## [function-class + ## (def.class #$.V1_6 #$.Public $.finalC + ## function-class (list) + ## ($.simple-class //.function-class) (list) + ## functionD)]) + _ (phase.throw extension.invalid-syntax ["YOLO-TRON" %synthesis (list)])] + (wrap _.DUP)))])) + +(def: class + Bundle + (<| (bundle.prefix "class") + (|> (: Bundle bundle.empty) + (bundle.install "anonymous" class::anonymous) + ))) + (def: #export bundle Bundle (<| (bundle.prefix "jvm") @@ -820,4 +1023,5 @@ (dictionary.merge ..array) (dictionary.merge ..object) (dictionary.merge ..member) + (dictionary.merge ..class) ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux index 1c7dfdee7..a9417050a 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -1411,7 +1411,7 @@ ))) ))) -(type: #rec JVM-Type +(type: #export #rec JVM-Type [Text (List JVM-Type)]) (def: (lux-type [name parameters]) @@ -1437,45 +1437,57 @@ (function (_ jvm-type) (s.form (p.and s.text (p.some jvm-type)))))) +(type: #export (Constructor-Argument a) + [JVM-Type a]) + (def: constructor-arg - (Parser [JVM-Type Code]) + (Parser (Constructor-Argument Code)) (s.tuple (p.and ..jvm-type s.any))) -(type: (Annotation-Parameter a) +(type: #export (Annotation-Parameter a) [Text a]) (def: annotation-parameter (Parser (Annotation-Parameter Code)) (s.tuple (p.and s.text s.any))) -(type: (Annotation a) +(type: #export (Annotation a) [Text (List (Annotation-Parameter a))]) (def: annotation (Parser (Annotation Code)) (s.form (p.and s.text (p.some ..annotation-parameter)))) -(type: Type-Parameter Text) +(type: #export Type-Parameter Text) (def: type-parameter (Parser Type-Parameter) s.text) -(type: Argument +(type: #export Argument [Text JVM-Type]) (def: argument (Parser Argument) (s.tuple (p.and s.text ..jvm-type))) -(type: Overriden-Method - [JVM-Type Text Bit (List (Annotation Code)) (List Type-Parameter) Text (List Argument) JVM-Type (List JVM-Type) Code]) - -(type: Method-Definition - (#Overriden-Method Overriden-Method)) +(type: #export (Overriden-Method a) + [JVM-Type + Text + Bit + (List (Annotation a)) + (List Type-Parameter) + Text + (List Argument) + JVM-Type + (List JVM-Type) + a]) + +(type: #export (Method-Definition a) + (#Overriden-Method (Overriden-Method a))) (def: overriden-method-definition - (Parser Overriden-Method) + (Parser (Overriden-Method Code)) (<| s.form (p.after (s.this (` "override"))) ($_ p.and @@ -1510,7 +1522,7 @@ /////analysis.text) (def: (constructor-arg-analysis [type term]) - (-> [JVM-Type Analysis] Analysis) + (-> (Constructor-Argument Analysis) Analysis) (/////analysis.tuple (list (jvm-type-analysis type) term))) (def: lux-module-separator "/") @@ -1573,12 +1585,18 @@ (/////analysis.bit strict-fp?) (/////analysis.tuple (list@map annotation-analysis annotationsA)) (/////analysis.tuple (list@map type-parameter-analysis type-parameters)) + (/////analysis.text self-name) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (jvm-type-analysis argumentJT)))) + arguments)) (jvm-type-analysis return-type) (/////analysis.tuple (list@map jvm-type-analysis exceptions)) (#/////analysis.Function (scope.environment scope) - bodyA) + (/////analysis.tuple (list bodyA))) ))))) methods) _ (typeA.infer selfT)] diff --git a/stdlib/source/lux/tool/compiler/synthesis.lux b/stdlib/source/lux/tool/compiler/synthesis.lux index d12c8c3ea..a30d11b92 100644 --- a/stdlib/source/lux/tool/compiler/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/synthesis.lux @@ -337,9 +337,7 @@ (text.enclose ["[" "]"]))) (#Reference reference) - (|> reference - //reference.%reference - (text.enclose ["(#@ " ")"])) + (//reference.%reference reference) (#Control control) (case control |