From 697707d8560a5735be38fd9b1ff91a02c289d48f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 16 Apr 2019 20:53:41 -0400 Subject: Made some new-luxc modules "old". --- .../source/luxc/lang/translation/jvm/case.jvm.lux | 235 ------- new-luxc/source/luxc/lang/translation/jvm/case.lux | 235 +++++++ .../luxc/lang/translation/jvm/common.jvm.lux | 72 -- .../source/luxc/lang/translation/jvm/common.lux | 72 ++ .../luxc/lang/translation/jvm/expression.jvm.lux | 70 -- .../luxc/lang/translation/jvm/expression.lux | 70 ++ .../luxc/lang/translation/jvm/function.jvm.lux | 330 --------- .../source/luxc/lang/translation/jvm/function.lux | 330 +++++++++ .../source/luxc/lang/translation/jvm/loop.jvm.lux | 79 --- new-luxc/source/luxc/lang/translation/jvm/loop.lux | 79 +++ .../luxc/lang/translation/jvm/primitive.jvm.lux | 33 - .../source/luxc/lang/translation/jvm/primitive.lux | 33 + .../lang/translation/jvm/procedure/common.jvm.lux | 380 ---------- .../luxc/lang/translation/jvm/procedure/common.lux | 327 +++++++++ .../lang/translation/jvm/procedure/host.jvm.lux | 761 --------------------- .../luxc/lang/translation/jvm/procedure/host.lux | 753 ++++++++++++++++++++ .../luxc/lang/translation/jvm/reference.jvm.lux | 57 -- .../source/luxc/lang/translation/jvm/reference.lux | 57 ++ .../luxc/lang/translation/jvm/runtime.jvm.lux | 361 ---------- .../source/luxc/lang/translation/jvm/runtime.lux | 361 ++++++++++ .../luxc/lang/translation/jvm/structure.jvm.lux | 70 -- .../source/luxc/lang/translation/jvm/structure.lux | 70 ++ stdlib/source/lux/host/jvm/loader.jvm.lux | 126 ++++ stdlib/source/lux/host/jvm/loader.old.lux | 126 ---- 24 files changed, 2513 insertions(+), 2574 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/case.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/common.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/expression.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/function.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/loop.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/primitive.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/reference.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/runtime.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/structure.lux create mode 100644 stdlib/source/lux/host/jvm/loader.jvm.lux delete mode 100644 stdlib/source/lux/host/jvm/loader.old.lux diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux deleted file mode 100644 index 43d11c71e..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux +++ /dev/null @@ -1,235 +0,0 @@ -(.module: - [lux (#- if let case) - [abstract - [monad (#+ do)]] - [control - ["." function] - ["ex" exception (#+ exception:)]] - [data - [text - format]] - [tool - [compiler - ["." synthesis (#+ Path Synthesis)] - ["." phase ("operation/." monad)]]]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Operation Phase) - ["$t" type] - ["_" inst]]]]] - ["." // (#+ $Object) - ["." runtime]]) - -(def: (pop-altI stack-depth) - (-> Nat Inst) - (.case stack-depth - 0 function.identity - 1 _.POP - 2 _.POP2 - _ ## (n/> 2) - (|>> _.POP2 - (pop-altI (n/- 2 stack-depth))))) - -(def: peekI - Inst - (|>> _.DUP - (_.INVOKESTATIC //.runtime-class - "pm_peek" - ($t.method (list runtime.$Stack) - (#.Some $Object) - (list)) - #0))) - -(def: popI - Inst - (|>> (_.INVOKESTATIC //.runtime-class - "pm_pop" - ($t.method (list runtime.$Stack) - (#.Some runtime.$Stack) - (list)) - #0))) - -(def: pushI - Inst - (|>> (_.INVOKESTATIC //.runtime-class - "pm_push" - ($t.method (list runtime.$Stack $Object) - (#.Some runtime.$Stack) - (list)) - #0))) - -(def: (path' phase stack-depth @else @end path) - (-> Phase Nat Label Label Path (Operation Inst)) - (.case path - #synthesis.Pop - (operation/wrap popI) - - (#synthesis.Bind register) - (operation/wrap (|>> peekI - (_.ASTORE register))) - - (^ (synthesis.path/bit value)) - (operation/wrap (.let [jumpI (.if value _.IFEQ _.IFNE)] - (|>> peekI - (_.unwrap #$.Boolean) - (jumpI @else)))) - - (^ (synthesis.path/i64 value)) - (operation/wrap (|>> peekI - (_.unwrap #$.Long) - (_.long (.int value)) - _.LCMP - (_.IFNE @else))) - - (^ (synthesis.path/f64 value)) - (operation/wrap (|>> peekI - (_.unwrap #$.Double) - (_.double value) - _.DCMPL - (_.IFNE @else))) - - (^ (synthesis.path/text value)) - (operation/wrap (|>> peekI - (_.string value) - (_.INVOKEVIRTUAL "java.lang.Object" - "equals" - ($t.method (list $Object) - (#.Some $t.boolean) - (list)) - #0) - (_.IFEQ @else))) - - (#synthesis.Then bodyS) - (do phase.monad - [bodyI (phase bodyS)] - (wrap (|>> (pop-altI stack-depth) - bodyI - (_.GOTO @end)))) - - - (^template [ ] - (^ ( idx)) - (operation/wrap (<| _.with-label (function (_ @success)) - _.with-label (function (_ @fail)) - (|>> peekI - (_.CHECKCAST ($t.descriptor runtime.$Variant)) - (_.int (.int ( idx))) - - (_.INVOKESTATIC //.runtime-class "pm_variant" - ($t.method (list runtime.$Variant runtime.$Tag runtime.$Flag) - (#.Some runtime.$Datum) - (list)) - #0) - _.DUP - (_.IFNULL @fail) - (_.GOTO @success) - (_.label @fail) - _.POP - (_.GOTO @else) - (_.label @success) - pushI)))) - ([synthesis.side/left _.NULL function.identity] - [synthesis.side/right (_.string "") .inc]) - - (^ (synthesis.member/left lefts)) - (operation/wrap (.let [accessI (.case lefts - 0 - _.AALOAD - - lefts - (_.INVOKESTATIC //.runtime-class - "tuple_left" - ($t.method (list runtime.$Tuple $t.int) - (#.Some $Object) - (list)) - #0))] - (|>> peekI - (_.CHECKCAST ($t.descriptor runtime.$Tuple)) - (_.int (.int lefts)) - accessI - pushI))) - - (^ (synthesis.member/right lefts)) - (operation/wrap (|>> peekI - (_.CHECKCAST ($t.descriptor runtime.$Tuple)) - (_.int (.int lefts)) - (_.INVOKESTATIC //.runtime-class - "tuple_right" - ($t.method (list runtime.$Tuple $t.int) - (#.Some $Object) - (list)) - #0) - pushI)) - - (#synthesis.Alt leftP rightP) - (do phase.monad - [@alt-else _.make-label - leftI (path' phase (inc stack-depth) @alt-else @end leftP) - rightI (path' phase stack-depth @else @end rightP)] - (wrap (|>> _.DUP - leftI - (_.label @alt-else) - _.POP - rightI))) - - (#synthesis.Seq leftP rightP) - (do phase.monad - [leftI (path' phase stack-depth @else @end leftP) - rightI (path' phase stack-depth @else @end rightP)] - (wrap (|>> leftI - rightI))) - )) - -(def: (path phase path @end) - (-> Phase Path Label (Operation Inst)) - (do phase.monad - [@else _.make-label - pathI (..path' phase 1 @else @end path)] - (wrap (|>> pathI - (_.label @else) - _.POP - (_.INVOKESTATIC //.runtime-class - "pm_fail" - ($t.method (list) #.None (list)) - #0) - _.NULL - (_.GOTO @end))))) - -(def: #export (if phase testS thenS elseS) - (-> Phase Synthesis Synthesis Synthesis (Operation Inst)) - (do phase.monad - [testI (phase testS) - thenI (phase thenS) - elseI (phase elseS)] - (wrap (<| _.with-label (function (_ @else)) - _.with-label (function (_ @end)) - (|>> testI - (_.unwrap #$.Boolean) - (_.IFEQ @else) - thenI - (_.GOTO @end) - (_.label @else) - elseI - (_.label @end)))))) - -(def: #export (let phase inputS register exprS) - (-> Phase Synthesis Nat Synthesis (Operation Inst)) - (do phase.monad - [inputI (phase inputS) - exprI (phase exprS)] - (wrap (|>> inputI - (_.ASTORE register) - exprI)))) - -(def: #export (case phase valueS path) - (-> Phase Synthesis Path (Operation Inst)) - (do phase.monad - [@end _.make-label - valueI (phase valueS) - pathI (..path phase path @end)] - (wrap (|>> _.NULL - valueI - pushI - pathI - (_.label @end))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.lux b/new-luxc/source/luxc/lang/translation/jvm/case.lux new file mode 100644 index 000000000..43d11c71e --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/case.lux @@ -0,0 +1,235 @@ +(.module: + [lux (#- if let case) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["ex" exception (#+ exception:)]] + [data + [text + format]] + [tool + [compiler + ["." synthesis (#+ Path Synthesis)] + ["." phase ("operation/." monad)]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Operation Phase) + ["$t" type] + ["_" inst]]]]] + ["." // (#+ $Object) + ["." runtime]]) + +(def: (pop-altI stack-depth) + (-> Nat Inst) + (.case stack-depth + 0 function.identity + 1 _.POP + 2 _.POP2 + _ ## (n/> 2) + (|>> _.POP2 + (pop-altI (n/- 2 stack-depth))))) + +(def: peekI + Inst + (|>> _.DUP + (_.INVOKESTATIC //.runtime-class + "pm_peek" + ($t.method (list runtime.$Stack) + (#.Some $Object) + (list)) + #0))) + +(def: popI + Inst + (|>> (_.INVOKESTATIC //.runtime-class + "pm_pop" + ($t.method (list runtime.$Stack) + (#.Some runtime.$Stack) + (list)) + #0))) + +(def: pushI + Inst + (|>> (_.INVOKESTATIC //.runtime-class + "pm_push" + ($t.method (list runtime.$Stack $Object) + (#.Some runtime.$Stack) + (list)) + #0))) + +(def: (path' phase stack-depth @else @end path) + (-> Phase Nat Label Label Path (Operation Inst)) + (.case path + #synthesis.Pop + (operation/wrap popI) + + (#synthesis.Bind register) + (operation/wrap (|>> peekI + (_.ASTORE register))) + + (^ (synthesis.path/bit value)) + (operation/wrap (.let [jumpI (.if value _.IFEQ _.IFNE)] + (|>> peekI + (_.unwrap #$.Boolean) + (jumpI @else)))) + + (^ (synthesis.path/i64 value)) + (operation/wrap (|>> peekI + (_.unwrap #$.Long) + (_.long (.int value)) + _.LCMP + (_.IFNE @else))) + + (^ (synthesis.path/f64 value)) + (operation/wrap (|>> peekI + (_.unwrap #$.Double) + (_.double value) + _.DCMPL + (_.IFNE @else))) + + (^ (synthesis.path/text value)) + (operation/wrap (|>> peekI + (_.string value) + (_.INVOKEVIRTUAL "java.lang.Object" + "equals" + ($t.method (list $Object) + (#.Some $t.boolean) + (list)) + #0) + (_.IFEQ @else))) + + (#synthesis.Then bodyS) + (do phase.monad + [bodyI (phase bodyS)] + (wrap (|>> (pop-altI stack-depth) + bodyI + (_.GOTO @end)))) + + + (^template [ ] + (^ ( idx)) + (operation/wrap (<| _.with-label (function (_ @success)) + _.with-label (function (_ @fail)) + (|>> peekI + (_.CHECKCAST ($t.descriptor runtime.$Variant)) + (_.int (.int ( idx))) + + (_.INVOKESTATIC //.runtime-class "pm_variant" + ($t.method (list runtime.$Variant runtime.$Tag runtime.$Flag) + (#.Some runtime.$Datum) + (list)) + #0) + _.DUP + (_.IFNULL @fail) + (_.GOTO @success) + (_.label @fail) + _.POP + (_.GOTO @else) + (_.label @success) + pushI)))) + ([synthesis.side/left _.NULL function.identity] + [synthesis.side/right (_.string "") .inc]) + + (^ (synthesis.member/left lefts)) + (operation/wrap (.let [accessI (.case lefts + 0 + _.AALOAD + + lefts + (_.INVOKESTATIC //.runtime-class + "tuple_left" + ($t.method (list runtime.$Tuple $t.int) + (#.Some $Object) + (list)) + #0))] + (|>> peekI + (_.CHECKCAST ($t.descriptor runtime.$Tuple)) + (_.int (.int lefts)) + accessI + pushI))) + + (^ (synthesis.member/right lefts)) + (operation/wrap (|>> peekI + (_.CHECKCAST ($t.descriptor runtime.$Tuple)) + (_.int (.int lefts)) + (_.INVOKESTATIC //.runtime-class + "tuple_right" + ($t.method (list runtime.$Tuple $t.int) + (#.Some $Object) + (list)) + #0) + pushI)) + + (#synthesis.Alt leftP rightP) + (do phase.monad + [@alt-else _.make-label + leftI (path' phase (inc stack-depth) @alt-else @end leftP) + rightI (path' phase stack-depth @else @end rightP)] + (wrap (|>> _.DUP + leftI + (_.label @alt-else) + _.POP + rightI))) + + (#synthesis.Seq leftP rightP) + (do phase.monad + [leftI (path' phase stack-depth @else @end leftP) + rightI (path' phase stack-depth @else @end rightP)] + (wrap (|>> leftI + rightI))) + )) + +(def: (path phase path @end) + (-> Phase Path Label (Operation Inst)) + (do phase.monad + [@else _.make-label + pathI (..path' phase 1 @else @end path)] + (wrap (|>> pathI + (_.label @else) + _.POP + (_.INVOKESTATIC //.runtime-class + "pm_fail" + ($t.method (list) #.None (list)) + #0) + _.NULL + (_.GOTO @end))))) + +(def: #export (if phase testS thenS elseS) + (-> Phase Synthesis Synthesis Synthesis (Operation Inst)) + (do phase.monad + [testI (phase testS) + thenI (phase thenS) + elseI (phase elseS)] + (wrap (<| _.with-label (function (_ @else)) + _.with-label (function (_ @end)) + (|>> testI + (_.unwrap #$.Boolean) + (_.IFEQ @else) + thenI + (_.GOTO @end) + (_.label @else) + elseI + (_.label @end)))))) + +(def: #export (let phase inputS register exprS) + (-> Phase Synthesis Nat Synthesis (Operation Inst)) + (do phase.monad + [inputI (phase inputS) + exprI (phase exprS)] + (wrap (|>> inputI + (_.ASTORE register) + exprI)))) + +(def: #export (case phase valueS path) + (-> Phase Synthesis Path (Operation Inst)) + (do phase.monad + [@end _.make-label + valueI (phase valueS) + pathI (..path phase path @end)] + (wrap (|>> _.NULL + valueI + pushI + pathI + (_.label @end))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux deleted file mode 100644 index ea6665dc5..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux +++ /dev/null @@ -1,72 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - ["." io]] - [data - ["." error (#+ Error)] - ["." text ("#/." hash) - format] - [collection - ["." dictionary (#+ Dictionary)]]] - ["." macro] - [host (#+ import:)] - [world - [binary (#+ Binary)]] - [tool - [compiler - [reference (#+ Register)] - ["." name] - ["." phase]]]] - ## [luxc - ## [lang - ## [host - ## ["." jvm - ## [type]]]]] - ) - -## (def: #export (with-artifacts action) -## (All [a] (-> (Meta a) (Meta [Artifacts a]))) -## (function (_ state) -## (case (action (update@ #.host -## (|>> (:coerce Host) -## (set@ #artifacts (dictionary.new text.hash)) -## (:coerce Nothing)) -## state)) -## (#error.Success [state' output]) -## (#error.Success [(update@ #.host -## (|>> (:coerce Host) -## (set@ #artifacts (|> (get@ #.host state) (:coerce Host) (get@ #artifacts))) -## (:coerce Nothing)) -## state') -## [(|> state' (get@ #.host) (:coerce Host) (get@ #artifacts)) -## output]]) - -## (#error.Error error) -## (#error.Error error)))) - -## (def: #export (load-definition state) -## (-> Lux (-> Name Binary (Error Any))) -## (function (_ (^@ def-name [def-module def-name]) def-bytecode) -## (let [normal-name (format (name.normalize def-name) (%n (text/hash def-name))) -## class-name (format (text.replace-all "/" "." def-module) "." normal-name)] -## (<| (macro.run state) -## (do macro.monad -## [_ (..store-class class-name def-bytecode) -## class (..load-class class-name)] -## (case (do error.monad -## [field (Class::getField [..value-field] class)] -## (Field::get [#.None] field)) -## (#error.Success (#.Some def-value)) -## (wrap def-value) - -## (#error.Success #.None) -## (phase.throw invalid-definition-value (%name def-name)) - -## (#error.Error error) -## (phase.throw cannot-load-definition -## (format "Definition: " (%name def-name) "\n" -## "Error:\n" -## error)))))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.lux b/new-luxc/source/luxc/lang/translation/jvm/common.lux new file mode 100644 index 000000000..ea6665dc5 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/common.lux @@ -0,0 +1,72 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)] + ["." io]] + [data + ["." error (#+ Error)] + ["." text ("#/." hash) + format] + [collection + ["." dictionary (#+ Dictionary)]]] + ["." macro] + [host (#+ import:)] + [world + [binary (#+ Binary)]] + [tool + [compiler + [reference (#+ Register)] + ["." name] + ["." phase]]]] + ## [luxc + ## [lang + ## [host + ## ["." jvm + ## [type]]]]] + ) + +## (def: #export (with-artifacts action) +## (All [a] (-> (Meta a) (Meta [Artifacts a]))) +## (function (_ state) +## (case (action (update@ #.host +## (|>> (:coerce Host) +## (set@ #artifacts (dictionary.new text.hash)) +## (:coerce Nothing)) +## state)) +## (#error.Success [state' output]) +## (#error.Success [(update@ #.host +## (|>> (:coerce Host) +## (set@ #artifacts (|> (get@ #.host state) (:coerce Host) (get@ #artifacts))) +## (:coerce Nothing)) +## state') +## [(|> state' (get@ #.host) (:coerce Host) (get@ #artifacts)) +## output]]) + +## (#error.Error error) +## (#error.Error error)))) + +## (def: #export (load-definition state) +## (-> Lux (-> Name Binary (Error Any))) +## (function (_ (^@ def-name [def-module def-name]) def-bytecode) +## (let [normal-name (format (name.normalize def-name) (%n (text/hash def-name))) +## class-name (format (text.replace-all "/" "." def-module) "." normal-name)] +## (<| (macro.run state) +## (do macro.monad +## [_ (..store-class class-name def-bytecode) +## class (..load-class class-name)] +## (case (do error.monad +## [field (Class::getField [..value-field] class)] +## (Field::get [#.None] field)) +## (#error.Success (#.Some def-value)) +## (wrap def-value) + +## (#error.Success #.None) +## (phase.throw invalid-definition-value (%name def-name)) + +## (#error.Error error) +## (phase.throw cannot-load-definition +## (format "Definition: " (%name def-name) "\n" +## "Error:\n" +## error)))))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux deleted file mode 100644 index c6b77e549..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux +++ /dev/null @@ -1,70 +0,0 @@ -(.module: - [lux #* - [tool - [compiler - ["." synthesis] - [phase - ["." extension]]]]] - [luxc - [lang - [host - [jvm (#+ Phase)]]]] - [// - ["." common] - ["." primitive] - ["." structure] - ["." reference] - ["." case] - ["." loop] - ["." function]]) - -(def: #export (translate synthesis) - Phase - (case synthesis - (^ (synthesis.bit value)) - (primitive.bit value) - - (^ (synthesis.i64 value)) - (primitive.i64 value) - - (^ (synthesis.f64 value)) - (primitive.f64 value) - - (^ (synthesis.text value)) - (primitive.text value) - - (^ (synthesis.variant [lefts right? value])) - (structure.variant translate lefts right? value) - - (^ (synthesis.tuple members)) - (structure.tuple translate members) - - (^ (synthesis.variable variable)) - (reference.variable variable) - - (^ (synthesis.constant constant)) - (reference.constant constant) - - (^ (synthesis.branch/let [input register expr])) - (case.let translate input register expr) - - (^ (synthesis.branch/if [test then else])) - (case.if translate test then else) - - (^ (synthesis.branch/case [input path])) - (case.case translate input path) - - (^ (synthesis.loop/recur data)) - (loop.recur translate data) - - (^ (synthesis.loop/scope data)) - (loop.scope translate data) - - (^ (synthesis.function/apply apply)) - (function.call translate apply) - - (^ (synthesis.function/abstraction abstraction)) - (function.function translate abstraction) - - (#synthesis.Extension extension) - (extension.apply translate extension))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.lux new file mode 100644 index 000000000..c6b77e549 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/expression.lux @@ -0,0 +1,70 @@ +(.module: + [lux #* + [tool + [compiler + ["." synthesis] + [phase + ["." extension]]]]] + [luxc + [lang + [host + [jvm (#+ Phase)]]]] + [// + ["." common] + ["." primitive] + ["." structure] + ["." reference] + ["." case] + ["." loop] + ["." function]]) + +(def: #export (translate synthesis) + Phase + (case synthesis + (^ (synthesis.bit value)) + (primitive.bit value) + + (^ (synthesis.i64 value)) + (primitive.i64 value) + + (^ (synthesis.f64 value)) + (primitive.f64 value) + + (^ (synthesis.text value)) + (primitive.text value) + + (^ (synthesis.variant [lefts right? value])) + (structure.variant translate lefts right? value) + + (^ (synthesis.tuple members)) + (structure.tuple translate members) + + (^ (synthesis.variable variable)) + (reference.variable variable) + + (^ (synthesis.constant constant)) + (reference.constant constant) + + (^ (synthesis.branch/let [input register expr])) + (case.let translate input register expr) + + (^ (synthesis.branch/if [test then else])) + (case.if translate test then else) + + (^ (synthesis.branch/case [input path])) + (case.case translate input path) + + (^ (synthesis.loop/recur data)) + (loop.recur translate data) + + (^ (synthesis.loop/scope data)) + (loop.scope translate data) + + (^ (synthesis.function/apply apply)) + (function.call translate apply) + + (^ (synthesis.function/abstraction abstraction)) + (function.function translate abstraction) + + (#synthesis.Extension extension) + (extension.apply translate extension))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux deleted file mode 100644 index db8716697..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux +++ /dev/null @@ -1,330 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ when> new>)] - ["." function]] - [data - ["." text - format] - [collection - ["." list ("#/." functor monoid)]]] - [tool - [compiler - [analysis (#+ Arity)] - [synthesis (#+ Synthesis Abstraction Apply)] - ["_." reference (#+ Register Variable)] - ["." phase - ["." generation]]]]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Def Operation Phase) - ["." type] - ["." def] - ["_" inst]]]]] - ["." // - ["." runtime] - ["." reference]]) - - -(def: arity-field Text "arity") -(def: $Object $.Type (type.class "java.lang.Object" (list))) - -(def: (poly-arg? arity) - (-> Arity Bit) - (n/> 1 arity)) - -(def: (reset-method class) - (-> Text $.Method) - (type.method (list) (#.Some (type.class class (list))) (list))) - -(def: (captured-args env) - (-> (List Variable) (List $.Type)) - (list.repeat (list.size env) $Object)) - -(def: (init-method env arity) - (-> (List Variable) Arity $.Method) - (if (poly-arg? arity) - (type.method (list.concat (list (captured-args env) - (list type.int) - (list.repeat (dec arity) $Object))) - #.None - (list)) - (type.method (captured-args env) #.None (list)))) - -(def: (implementation-method arity) - (type.method (list.repeat arity $Object) (#.Some $Object) (list))) - -(def: get-amount-of-partialsI - Inst - (|>> (_.ALOAD 0) - (_.GETFIELD //.function-class runtime.partials-field type.int))) - -(def: (load-fieldI class field) - (-> Text Text Inst) - (|>> (_.ALOAD 0) - (_.GETFIELD class field $Object))) - -(def: (inputsI start amount) - (-> Register Nat Inst) - (|> (list.n/range start (n/+ start (dec amount))) - (list/map _.ALOAD) - _.fuse)) - -(def: (applysI start amount) - (-> Register Nat Inst) - (let [max-args (n/min amount runtime.num-apply-variants) - later-applysI (if (n/> runtime.num-apply-variants amount) - (applysI (n/+ runtime.num-apply-variants start) (n/- runtime.num-apply-variants amount)) - function.identity)] - (|>> (_.CHECKCAST //.function-class) - (inputsI start max-args) - (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature max-args) #0) - later-applysI))) - -(def: (inc-intI by) - (-> Nat Inst) - (|>> (_.int (.int by)) - _.IADD)) - -(def: (nullsI amount) - (-> Nat Inst) - (|> _.NULL - (list.repeat amount) - _.fuse)) - -(def: (with-captured env) - (-> (List Variable) Def) - (|> (list.enumerate env) - (list/map (.function (_ [env-idx env-source]) - (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object))) - def.fuse)) - -(def: (with-partial arity) - (-> Arity Def) - (if (poly-arg? arity) - (|> (list.n/range 0 (n/- 2 arity)) - (list/map (.function (_ idx) - (def.field #$.Private $.finalF (reference.partial-name idx) $Object))) - def.fuse) - function.identity)) - -(def: (instance class arity env) - (-> Text Arity (List Variable) (Operation Inst)) - (do phase.monad - [captureI+ (monad.map @ reference.variable env) - #let [argsI (if (poly-arg? arity) - (|> (nullsI (dec arity)) - (list (_.int +0)) - _.fuse) - function.identity)]] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse captureI+) - argsI - (_.INVOKESPECIAL class "" (init-method env arity) #0))))) - -(def: (with-reset class arity env) - (-> Text Arity (List Variable) Def) - (def.method #$.Public $.noneM "reset" (reset-method class) - (if (poly-arg? arity) - (let [env-size (list.size env) - captureI (|> (case env-size - 0 (list) - _ (list.n/range 0 (dec env-size))) - (list/map (.function (_ source) - (|>> (_.ALOAD 0) - (_.GETFIELD class (reference.foreign-name source) $Object)))) - _.fuse) - argsI (|> (nullsI (dec arity)) - (list (_.int +0)) - _.fuse)] - (|>> (_.NEW class) - _.DUP - captureI - argsI - (_.INVOKESPECIAL class "" (init-method env arity) #0) - _.ARETURN)) - (|>> (_.ALOAD 0) - _.ARETURN)))) - -(def: (with-implementation arity @begin bodyI) - (-> Nat Label Inst Def) - (def.method #$.Public $.strictM "impl" (implementation-method arity) - (|>> (_.label @begin) - bodyI - _.ARETURN))) - -(def: function-init-method - $.Method - (type.method (list type.int) #.None (list))) - -(def: (function-init arity env-size) - (-> Arity Nat Inst) - (if (n/= 1 arity) - (|>> (_.int +0) - (_.INVOKESPECIAL //.function-class "" function-init-method #0)) - (|>> (_.ILOAD (inc env-size)) - (_.INVOKESPECIAL //.function-class "" function-init-method #0)))) - -(def: (with-init class env arity) - (-> Text (List Variable) Arity Def) - (let [env-size (list.size env) - offset-partial (: (-> Nat Nat) - (|>> inc (n/+ env-size))) - store-capturedI (|> (case env-size - 0 (list) - _ (list.n/range 0 (dec env-size))) - (list/map (.function (_ register) - (|>> (_.ALOAD 0) - (_.ALOAD (inc register)) - (_.PUTFIELD class (reference.foreign-name register) $Object)))) - _.fuse) - store-partialI (if (poly-arg? arity) - (|> (list.n/range 0 (n/- 2 arity)) - (list/map (.function (_ idx) - (let [register (offset-partial idx)] - (|>> (_.ALOAD 0) - (_.ALOAD (inc register)) - (_.PUTFIELD class (reference.partial-name idx) $Object))))) - _.fuse) - function.identity)] - (def.method #$.Public $.noneM "" (init-method env arity) - (|>> (_.ALOAD 0) - (function-init arity env-size) - store-capturedI - store-partialI - _.RETURN)))) - -(def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> Text (List Variable) Arity Label Inst Arity - Def) - (let [num-partials (dec function-arity) - @default ($.new-label []) - @labels (list/map $.new-label (list.repeat num-partials [])) - arity-over-extent (|> (.int function-arity) (i/- (.int apply-arity))) - casesI (|> (list/compose @labels (list @default)) - (list.zip2 (list.n/range 0 num-partials)) - (list/map (.function (_ [stage @label]) - (let [load-partialsI (if (n/> 0 stage) - (|> (list.n/range 0 (dec stage)) - (list/map (|>> reference.partial-name (load-fieldI class))) - _.fuse) - function.identity)] - (cond (i/= arity-over-extent (.int stage)) - (|>> (_.label @label) - (_.ALOAD 0) - (when> [(new> (n/> 0 stage) [])] - [(_.INVOKEVIRTUAL class "reset" (reset-method class) #0)]) - load-partialsI - (inputsI 1 apply-arity) - (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity) #0) - _.ARETURN) - - (i/> arity-over-extent (.int stage)) - (let [args-to-completion (|> function-arity (n/- stage)) - args-left (|> apply-arity (n/- args-to-completion))] - (|>> (_.label @label) - (_.ALOAD 0) - (_.INVOKEVIRTUAL class "reset" (reset-method class) #0) - load-partialsI - (inputsI 1 args-to-completion) - (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity) #0) - (applysI (inc args-to-completion) args-left) - _.ARETURN)) - - ## (i/< arity-over-extent (.int stage)) - (let [env-size (list.size env) - load-capturedI (|> (case env-size - 0 (list) - _ (list.n/range 0 (dec env-size))) - (list/map (|>> reference.foreign-name (load-fieldI class))) - _.fuse)] - (|>> (_.label @label) - (_.NEW class) - _.DUP - load-capturedI - get-amount-of-partialsI - (inc-intI apply-arity) - load-partialsI - (inputsI 1 apply-arity) - (nullsI (|> num-partials (n/- apply-arity) (n/- stage))) - (_.INVOKESPECIAL class "" (init-method env function-arity) #0) - _.ARETURN)) - )))) - _.fuse)] - (def.method #$.Public $.noneM runtime.apply-method (runtime.apply-signature apply-arity) - (|>> get-amount-of-partialsI - (_.TABLESWITCH +0 (|> num-partials dec .int) - @default @labels) - casesI - (_.INVOKESTATIC //.runtime-class "apply_fail" (type.method (list) #.None (list)) #0) - _.NULL - _.ARETURN - )))) - -(def: #export (with-function @begin class env arity bodyI) - (-> Label Text (List Variable) Arity Inst - (Operation [Def Inst])) - (let [env-size (list.size env) - applyD (: Def - (if (poly-arg? arity) - (|> (n/min arity runtime.num-apply-variants) - (list.n/range 1) - (list/map (with-apply class env arity @begin bodyI)) - (list& (with-implementation arity @begin bodyI)) - def.fuse) - (def.method #$.Public $.strictM runtime.apply-method (runtime.apply-signature 1) - (|>> (_.label @begin) - bodyI - _.ARETURN)))) - functionD (: Def - (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity)) - (with-captured env) - (with-partial arity) - (with-init class env arity) - (with-reset class arity env) - applyD - ))] - (do phase.monad - [instanceI (instance class arity env)] - (wrap [functionD instanceI])))) - -(def: #export (function translate [env arity bodyS]) - (-> Phase Abstraction (Operation Inst)) - (do phase.monad - [@begin _.make-label - [function-class bodyI] (generation.with-context - (generation.with-anchor [@begin 1] - (translate bodyS))) - [functionD instanceI] (with-function @begin function-class env arity bodyI) - _ (generation.save! ["" function-class] - [function-class - (def.class #$.V1_6 #$.Public $.finalC - function-class (list) - ($.simple-class //.function-class) (list) - functionD)])] - (wrap instanceI))) - -(def: (segment size elems) - (All [a] (-> Nat (List a) (List (List a)))) - (let [[pre post] (list.split size elems)] - (if (list.empty? post) - (list pre) - (list& pre (segment size post))))) - -(def: #export (call translate [functionS argsS]) - (-> Phase Apply (Operation Inst)) - (do phase.monad - [functionI (translate functionS) - argsI (monad.map @ translate argsS) - #let [applyI (|> (segment runtime.num-apply-variants argsI) - (list/map (.function (_ chunkI+) - (|>> (_.CHECKCAST //.function-class) - (_.fuse chunkI+) - (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature (list.size chunkI+)) #0)))) - _.fuse)]] - (wrap (|>> functionI - applyI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux new file mode 100644 index 000000000..db8716697 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux @@ -0,0 +1,330 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ when> new>)] + ["." function]] + [data + ["." text + format] + [collection + ["." list ("#/." functor monoid)]]] + [tool + [compiler + [analysis (#+ Arity)] + [synthesis (#+ Synthesis Abstraction Apply)] + ["_." reference (#+ Register Variable)] + ["." phase + ["." generation]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Def Operation Phase) + ["." type] + ["." def] + ["_" inst]]]]] + ["." // + ["." runtime] + ["." reference]]) + + +(def: arity-field Text "arity") +(def: $Object $.Type (type.class "java.lang.Object" (list))) + +(def: (poly-arg? arity) + (-> Arity Bit) + (n/> 1 arity)) + +(def: (reset-method class) + (-> Text $.Method) + (type.method (list) (#.Some (type.class class (list))) (list))) + +(def: (captured-args env) + (-> (List Variable) (List $.Type)) + (list.repeat (list.size env) $Object)) + +(def: (init-method env arity) + (-> (List Variable) Arity $.Method) + (if (poly-arg? arity) + (type.method (list.concat (list (captured-args env) + (list type.int) + (list.repeat (dec arity) $Object))) + #.None + (list)) + (type.method (captured-args env) #.None (list)))) + +(def: (implementation-method arity) + (type.method (list.repeat arity $Object) (#.Some $Object) (list))) + +(def: get-amount-of-partialsI + Inst + (|>> (_.ALOAD 0) + (_.GETFIELD //.function-class runtime.partials-field type.int))) + +(def: (load-fieldI class field) + (-> Text Text Inst) + (|>> (_.ALOAD 0) + (_.GETFIELD class field $Object))) + +(def: (inputsI start amount) + (-> Register Nat Inst) + (|> (list.n/range start (n/+ start (dec amount))) + (list/map _.ALOAD) + _.fuse)) + +(def: (applysI start amount) + (-> Register Nat Inst) + (let [max-args (n/min amount runtime.num-apply-variants) + later-applysI (if (n/> runtime.num-apply-variants amount) + (applysI (n/+ runtime.num-apply-variants start) (n/- runtime.num-apply-variants amount)) + function.identity)] + (|>> (_.CHECKCAST //.function-class) + (inputsI start max-args) + (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature max-args) #0) + later-applysI))) + +(def: (inc-intI by) + (-> Nat Inst) + (|>> (_.int (.int by)) + _.IADD)) + +(def: (nullsI amount) + (-> Nat Inst) + (|> _.NULL + (list.repeat amount) + _.fuse)) + +(def: (with-captured env) + (-> (List Variable) Def) + (|> (list.enumerate env) + (list/map (.function (_ [env-idx env-source]) + (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object))) + def.fuse)) + +(def: (with-partial arity) + (-> Arity Def) + (if (poly-arg? arity) + (|> (list.n/range 0 (n/- 2 arity)) + (list/map (.function (_ idx) + (def.field #$.Private $.finalF (reference.partial-name idx) $Object))) + def.fuse) + function.identity)) + +(def: (instance class arity env) + (-> Text Arity (List Variable) (Operation Inst)) + (do phase.monad + [captureI+ (monad.map @ reference.variable env) + #let [argsI (if (poly-arg? arity) + (|> (nullsI (dec arity)) + (list (_.int +0)) + _.fuse) + function.identity)]] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse captureI+) + argsI + (_.INVOKESPECIAL class "" (init-method env arity) #0))))) + +(def: (with-reset class arity env) + (-> Text Arity (List Variable) Def) + (def.method #$.Public $.noneM "reset" (reset-method class) + (if (poly-arg? arity) + (let [env-size (list.size env) + captureI (|> (case env-size + 0 (list) + _ (list.n/range 0 (dec env-size))) + (list/map (.function (_ source) + (|>> (_.ALOAD 0) + (_.GETFIELD class (reference.foreign-name source) $Object)))) + _.fuse) + argsI (|> (nullsI (dec arity)) + (list (_.int +0)) + _.fuse)] + (|>> (_.NEW class) + _.DUP + captureI + argsI + (_.INVOKESPECIAL class "" (init-method env arity) #0) + _.ARETURN)) + (|>> (_.ALOAD 0) + _.ARETURN)))) + +(def: (with-implementation arity @begin bodyI) + (-> Nat Label Inst Def) + (def.method #$.Public $.strictM "impl" (implementation-method arity) + (|>> (_.label @begin) + bodyI + _.ARETURN))) + +(def: function-init-method + $.Method + (type.method (list type.int) #.None (list))) + +(def: (function-init arity env-size) + (-> Arity Nat Inst) + (if (n/= 1 arity) + (|>> (_.int +0) + (_.INVOKESPECIAL //.function-class "" function-init-method #0)) + (|>> (_.ILOAD (inc env-size)) + (_.INVOKESPECIAL //.function-class "" function-init-method #0)))) + +(def: (with-init class env arity) + (-> Text (List Variable) Arity Def) + (let [env-size (list.size env) + offset-partial (: (-> Nat Nat) + (|>> inc (n/+ env-size))) + store-capturedI (|> (case env-size + 0 (list) + _ (list.n/range 0 (dec env-size))) + (list/map (.function (_ register) + (|>> (_.ALOAD 0) + (_.ALOAD (inc register)) + (_.PUTFIELD class (reference.foreign-name register) $Object)))) + _.fuse) + store-partialI (if (poly-arg? arity) + (|> (list.n/range 0 (n/- 2 arity)) + (list/map (.function (_ idx) + (let [register (offset-partial idx)] + (|>> (_.ALOAD 0) + (_.ALOAD (inc register)) + (_.PUTFIELD class (reference.partial-name idx) $Object))))) + _.fuse) + function.identity)] + (def.method #$.Public $.noneM "" (init-method env arity) + (|>> (_.ALOAD 0) + (function-init arity env-size) + store-capturedI + store-partialI + _.RETURN)))) + +(def: (with-apply class env function-arity @begin bodyI apply-arity) + (-> Text (List Variable) Arity Label Inst Arity + Def) + (let [num-partials (dec function-arity) + @default ($.new-label []) + @labels (list/map $.new-label (list.repeat num-partials [])) + arity-over-extent (|> (.int function-arity) (i/- (.int apply-arity))) + casesI (|> (list/compose @labels (list @default)) + (list.zip2 (list.n/range 0 num-partials)) + (list/map (.function (_ [stage @label]) + (let [load-partialsI (if (n/> 0 stage) + (|> (list.n/range 0 (dec stage)) + (list/map (|>> reference.partial-name (load-fieldI class))) + _.fuse) + function.identity)] + (cond (i/= arity-over-extent (.int stage)) + (|>> (_.label @label) + (_.ALOAD 0) + (when> [(new> (n/> 0 stage) [])] + [(_.INVOKEVIRTUAL class "reset" (reset-method class) #0)]) + load-partialsI + (inputsI 1 apply-arity) + (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity) #0) + _.ARETURN) + + (i/> arity-over-extent (.int stage)) + (let [args-to-completion (|> function-arity (n/- stage)) + args-left (|> apply-arity (n/- args-to-completion))] + (|>> (_.label @label) + (_.ALOAD 0) + (_.INVOKEVIRTUAL class "reset" (reset-method class) #0) + load-partialsI + (inputsI 1 args-to-completion) + (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity) #0) + (applysI (inc args-to-completion) args-left) + _.ARETURN)) + + ## (i/< arity-over-extent (.int stage)) + (let [env-size (list.size env) + load-capturedI (|> (case env-size + 0 (list) + _ (list.n/range 0 (dec env-size))) + (list/map (|>> reference.foreign-name (load-fieldI class))) + _.fuse)] + (|>> (_.label @label) + (_.NEW class) + _.DUP + load-capturedI + get-amount-of-partialsI + (inc-intI apply-arity) + load-partialsI + (inputsI 1 apply-arity) + (nullsI (|> num-partials (n/- apply-arity) (n/- stage))) + (_.INVOKESPECIAL class "" (init-method env function-arity) #0) + _.ARETURN)) + )))) + _.fuse)] + (def.method #$.Public $.noneM runtime.apply-method (runtime.apply-signature apply-arity) + (|>> get-amount-of-partialsI + (_.TABLESWITCH +0 (|> num-partials dec .int) + @default @labels) + casesI + (_.INVOKESTATIC //.runtime-class "apply_fail" (type.method (list) #.None (list)) #0) + _.NULL + _.ARETURN + )))) + +(def: #export (with-function @begin class env arity bodyI) + (-> Label Text (List Variable) Arity Inst + (Operation [Def Inst])) + (let [env-size (list.size env) + applyD (: Def + (if (poly-arg? arity) + (|> (n/min arity runtime.num-apply-variants) + (list.n/range 1) + (list/map (with-apply class env arity @begin bodyI)) + (list& (with-implementation arity @begin bodyI)) + def.fuse) + (def.method #$.Public $.strictM runtime.apply-method (runtime.apply-signature 1) + (|>> (_.label @begin) + bodyI + _.ARETURN)))) + functionD (: Def + (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity)) + (with-captured env) + (with-partial arity) + (with-init class env arity) + (with-reset class arity env) + applyD + ))] + (do phase.monad + [instanceI (instance class arity env)] + (wrap [functionD instanceI])))) + +(def: #export (function translate [env arity bodyS]) + (-> Phase Abstraction (Operation Inst)) + (do phase.monad + [@begin _.make-label + [function-class bodyI] (generation.with-context + (generation.with-anchor [@begin 1] + (translate bodyS))) + [functionD instanceI] (with-function @begin function-class env arity bodyI) + _ (generation.save! ["" function-class] + [function-class + (def.class #$.V1_6 #$.Public $.finalC + function-class (list) + ($.simple-class //.function-class) (list) + functionD)])] + (wrap instanceI))) + +(def: (segment size elems) + (All [a] (-> Nat (List a) (List (List a)))) + (let [[pre post] (list.split size elems)] + (if (list.empty? post) + (list pre) + (list& pre (segment size post))))) + +(def: #export (call translate [functionS argsS]) + (-> Phase Apply (Operation Inst)) + (do phase.monad + [functionI (translate functionS) + argsI (monad.map @ translate argsS) + #let [applyI (|> (segment runtime.num-apply-variants argsI) + (list/map (.function (_ chunkI+) + (|>> (_.CHECKCAST //.function-class) + (_.fuse chunkI+) + (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature (list.size chunkI+)) #0)))) + _.fuse)]] + (wrap (|>> functionI + applyI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux deleted file mode 100644 index d7e706aaf..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux +++ /dev/null @@ -1,79 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - ["." text - format] - [collection - ["." list ("#/." functor monoid)]]] - [tool - [compiler - [reference (#+ Register)] - ["." synthesis (#+ Synthesis)] - ["." phase - ["." generation]]]]] - [luxc - [lang - [host - [jvm (#+ Inst Operation Phase) - ["_" inst]]]]] - ["." //]) - -(def: (constant? register changeS) - (-> Register Synthesis Bit) - (case changeS - (^ (synthesis.variable/local var)) - (n/= register var) - - _ - #0)) - -(def: #export (recur translate argsS) - (-> Phase (List Synthesis) (Operation Inst)) - (do phase.monad - [[@begin start] generation.anchor - #let [end (|> argsS list.size dec (n/+ start)) - pairs (list.zip2 (list.n/range start end) - argsS)] - ## It may look weird that first I compile the values separately, - ## and then I compile the stores/allocations. - ## It must be done that way in order to avoid a potential bug. - ## Let's say that you'll recur with 2 expressions: X and Y. - ## If Y depends on the value of X, and you don't compile values - ## and stores separately, then by the time Y is evaluated, it - ## will refer to the new value of X, instead of the old value, as - ## should be the case. - valuesI+ (monad.map @ (function (_ [register argS]) - (: (Operation Inst) - (if (constant? register argS) - (wrap function.identity) - (translate argS)))) - pairs) - #let [storesI+ (list/map (function (_ [register argS]) - (: Inst - (if (constant? register argS) - function.identity - (_.ASTORE register)))) - (list.reverse pairs))]] - (wrap (|>> (_.fuse valuesI+) - (_.fuse storesI+) - (_.GOTO @begin))))) - -(def: #export (scope translate [start initsS+ iterationS]) - (-> Phase [Nat (List Synthesis) Synthesis] (Operation Inst)) - (do phase.monad - [@begin _.make-label - initsI+ (monad.map @ translate initsS+) - iterationI (generation.with-anchor [@begin start] - (translate iterationS)) - #let [initializationI (|> (list.enumerate initsI+) - (list/map (function (_ [register initI]) - (|>> initI - (_.ASTORE (n/+ start register))))) - _.fuse)]] - (wrap (|>> initializationI - (_.label @begin) - iterationI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/loop.lux b/new-luxc/source/luxc/lang/translation/jvm/loop.lux new file mode 100644 index 000000000..d7e706aaf --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/loop.lux @@ -0,0 +1,79 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." text + format] + [collection + ["." list ("#/." functor monoid)]]] + [tool + [compiler + [reference (#+ Register)] + ["." synthesis (#+ Synthesis)] + ["." phase + ["." generation]]]]] + [luxc + [lang + [host + [jvm (#+ Inst Operation Phase) + ["_" inst]]]]] + ["." //]) + +(def: (constant? register changeS) + (-> Register Synthesis Bit) + (case changeS + (^ (synthesis.variable/local var)) + (n/= register var) + + _ + #0)) + +(def: #export (recur translate argsS) + (-> Phase (List Synthesis) (Operation Inst)) + (do phase.monad + [[@begin start] generation.anchor + #let [end (|> argsS list.size dec (n/+ start)) + pairs (list.zip2 (list.n/range start end) + argsS)] + ## It may look weird that first I compile the values separately, + ## and then I compile the stores/allocations. + ## It must be done that way in order to avoid a potential bug. + ## Let's say that you'll recur with 2 expressions: X and Y. + ## If Y depends on the value of X, and you don't compile values + ## and stores separately, then by the time Y is evaluated, it + ## will refer to the new value of X, instead of the old value, as + ## should be the case. + valuesI+ (monad.map @ (function (_ [register argS]) + (: (Operation Inst) + (if (constant? register argS) + (wrap function.identity) + (translate argS)))) + pairs) + #let [storesI+ (list/map (function (_ [register argS]) + (: Inst + (if (constant? register argS) + function.identity + (_.ASTORE register)))) + (list.reverse pairs))]] + (wrap (|>> (_.fuse valuesI+) + (_.fuse storesI+) + (_.GOTO @begin))))) + +(def: #export (scope translate [start initsS+ iterationS]) + (-> Phase [Nat (List Synthesis) Synthesis] (Operation Inst)) + (do phase.monad + [@begin _.make-label + initsI+ (monad.map @ translate initsS+) + iterationI (generation.with-anchor [@begin start] + (translate iterationS)) + #let [initializationI (|> (list.enumerate initsI+) + (list/map (function (_ [register initI]) + (|>> initI + (_.ASTORE (n/+ start register))))) + _.fuse)]] + (wrap (|>> initializationI + (_.label @begin) + iterationI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux deleted file mode 100644 index f9d9034ea..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux +++ /dev/null @@ -1,33 +0,0 @@ -(.module: - [lux (#- i64) - [abstract - monad] - [data - [text - format]] - [tool - [compiler - [phase ("operation/." monad)]]]] - [luxc - [lang - [host - ["." jvm (#+ Inst Operation) - ["_" inst] - ["$t" type]]]]]) - -(def: #export (bit value) - (-> Bit (Operation Inst)) - (operation/wrap (_.GETSTATIC "java.lang.Boolean" - (if value "TRUE" "FALSE") - ($t.class "java.lang.Boolean" (list))))) - -(template [ ] - [(def: #export ( value) - (-> (Operation Inst)) - (let [loadI (|> value )] - (operation/wrap (|>> loadI ))))] - - [i64 (I64 Any) (<| _.long .int) (_.wrap #jvm.Long)] - [f64 Frac _.double (_.wrap #jvm.Double)] - [text Text _.string (<|)] - ) diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.lux new file mode 100644 index 000000000..f9d9034ea --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.lux @@ -0,0 +1,33 @@ +(.module: + [lux (#- i64) + [abstract + monad] + [data + [text + format]] + [tool + [compiler + [phase ("operation/." monad)]]]] + [luxc + [lang + [host + ["." jvm (#+ Inst Operation) + ["_" inst] + ["$t" type]]]]]) + +(def: #export (bit value) + (-> Bit (Operation Inst)) + (operation/wrap (_.GETSTATIC "java.lang.Boolean" + (if value "TRUE" "FALSE") + ($t.class "java.lang.Boolean" (list))))) + +(template [ ] + [(def: #export ( value) + (-> (Operation Inst)) + (let [loadI (|> value )] + (operation/wrap (|>> loadI ))))] + + [i64 (I64 Any) (<| _.long .int) (_.wrap #jvm.Long)] + [f64 Frac _.double (_.wrap #jvm.Double)] + [text Text _.string (<|)] + ) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux deleted file mode 100644 index b19287b4e..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ /dev/null @@ -1,380 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["p" parser] - ["ex" exception (#+ exception:)]] - [data - ["." text - format] - [collection - ["." list ("#/." functor)] - ["." dictionary]]] - ["." macro (#+ with-gensyms) - ["." code] - ["s" syntax (#+ syntax:)]] - [tool - [compiler - ["." synthesis (#+ Synthesis)] - ["." phase - ["." extension - ["." bundle]]]]] - [host (#+ import:)]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Method Handler Bundle) - ["_t" type] - ["_" inst]]]]] - ["." /// - ["." runtime]]) - -(import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -## [Types] -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector 0 Inst) Inst)) -(type: #export Unary (-> (Vector 1 Inst) Inst)) -(type: #export Binary (-> (Vector 2 Inst) Inst)) -(type: #export Trinary (-> (Vector 3 Inst) Inst)) -(type: #export Variadic (-> (List Inst) Inst)) - -## [Utils] -(def: $Object-Array $.Type (_t.array 1 ///.$Object)) -(def: $String $.Type (_t.class "java.lang.String" (list))) -(def: $CharSequence $.Type (_t.class "java.lang.CharSequence" (list))) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!extension-name g!phase g!inputs] - (do @ - [g!inputC+ (monad.seq @ (list.repeat arity (macro.gensym "input"))) - #let [arityC (code.nat arity)]] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) - (-> (-> (..Vector (~ arityC) Inst) Inst) ..Handler) - (function ((~ g!_) (~ g!extension-name) (~ g!phase) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!inputC+))) - (do phase.monad - [(~+ (|> g!inputC+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!inputC+)]))) - - (~ g!_) - (phase.fail (ex.construct extension.incorrect-arity - [(~ g!extension-name) (~ arityC) (list.size (~ g!inputs))]))))))))))) - -(arity: nullary 0) -(arity: unary 1) -(arity: binary 2) -(arity: trinary 3) - -(def: #export (variadic extension) - (-> Variadic Handler) - (function (_ extension-name phase inputsS) - (do phase.monad - [inputsH (monad.map @ phase inputsS)] - (wrap (extension inputsH))))) - -## [Instructions] -(def: lux-intI Inst (|>> _.I2L (_.wrap #$.Long))) -(def: jvm-intI Inst (|>> (_.unwrap #$.Long) _.L2I)) -(def: check-stringI Inst (_.CHECKCAST "java.lang.String")) - -(def: (predicateI tester) - (-> (-> Label Inst) - Inst) - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> (tester @then) - (_.GETSTATIC "java.lang.Boolean" "FALSE" (_t.class "java.lang.Boolean" (list))) - (_.GOTO @end) - (_.label @then) - (_.GETSTATIC "java.lang.Boolean" "TRUE" (_t.class "java.lang.Boolean" (list))) - (_.label @end) - ))) - -(def: unitI Inst (_.string synthesis.unit)) - -## Extensions -### Lux -(def: (lux::is [referenceI sampleI]) - Binary - (|>> referenceI - sampleI - (predicateI _.IF_ACMPEQ))) - -(def: (lux::try riskyI) - Unary - (|>> riskyI - (_.CHECKCAST ///.function-class) - (_.INVOKESTATIC ///.runtime-class "try" - (_t.method (list ///.$Function) (#.Some $Object-Array) (list)) - #0))) - -### Bits -(template [ ] - [(def: ( [maskI inputI]) - Binary - (|>> inputI (_.unwrap #$.Long) - maskI (_.unwrap #$.Long) - (_.wrap #$.Long)))] - - [bit::and _.LAND] - [bit::or _.LOR] - [bit::xor _.LXOR] - ) - -(template [ ] - [(def: ( [shiftI inputI]) - Binary - (|>> inputI (_.unwrap #$.Long) - shiftI jvm-intI - - (_.wrap #$.Long)))] - - [bit::left-shift _.LSHL] - [bit::arithmetic-right-shift _.LSHR] - [bit::logical-right-shift _.LUSHR] - ) - -### Numbers -(template [ ] - [(def: ( _) - Nullary - (|>> (_.wrap )))] - - [frac::smallest (_.double (Double::MIN_VALUE)) #$.Double] - [frac::min (_.double (f/* -1.0 (Double::MAX_VALUE))) #$.Double] - [frac::max (_.double (Double::MAX_VALUE)) #$.Double] - ) - -(template [ ] - [(def: ( [paramI subjectI]) - Binary - (|>> subjectI (_.unwrap ) - paramI (_.unwrap ) - - (_.wrap )))] - - [i64::+ #$.Long _.LADD] - [i64::- #$.Long _.LSUB] - [int::* #$.Long _.LMUL] - [int::/ #$.Long _.LDIV] - [int::% #$.Long _.LREM] - - [frac::+ #$.Double _.DADD] - [frac::- #$.Double _.DSUB] - [frac::* #$.Double _.DMUL] - [frac::/ #$.Double _.DDIV] - [frac::% #$.Double _.DREM] - ) - -(template [ ] - [(template [ ] - [(def: ( [paramI subjectI]) - Binary - (|>> subjectI - paramI - - (_.int ) - (predicateI _.IF_ICMPEQ)))] - - [ +0] - [ -1])] - - [i64::= int::< (_.unwrap #$.Long) _.LCMP] - [frac::= frac::< (_.unwrap #$.Double) _.DCMPG] - ) - -(template [ ] - [(def: ( inputI) - Unary - (|>> inputI ))] - - [int::frac (_.unwrap #$.Long) (<| (_.wrap #$.Double) _.L2D)] - [int::char (_.unwrap #$.Long) - ((|>> _.L2I _.I2C (_.INVOKESTATIC "java.lang.Character" "toString" (_t.method (list _t.char) (#.Some $String) (list)) #0)))] - - [frac::int (_.unwrap #$.Double) (<| (_.wrap #$.Long) _.D2L)] - [frac::encode (_.unwrap #$.Double) - (_.INVOKESTATIC "java.lang.Double" "toString" (_t.method (list _t.double) (#.Some $String) (list)) #0)] - [frac::decode ..check-stringI - (_.INVOKESTATIC ///.runtime-class "decode_frac" (_t.method (list $String) (#.Some $Object-Array) (list)) #0)] - ) - -### Text -(def: (text::size inputI) - Unary - (|>> inputI - ..check-stringI - (_.INVOKEVIRTUAL "java.lang.String" "length" (_t.method (list) (#.Some _t.int) (list)) #0) - lux-intI)) - -(template [ ] - [(def: ( [paramI subjectI]) - Binary - (|>> subjectI - paramI - ))] - - [text::= (<|) (<|) - (_.INVOKEVIRTUAL "java.lang.Object" "equals" (_t.method (list ///.$Object) (#.Some _t.boolean) (list)) #0) - (_.wrap #$.Boolean)] - [text::< ..check-stringI ..check-stringI - (_.INVOKEVIRTUAL "java.lang.String" "compareTo" (_t.method (list $String) (#.Some _t.int) (list)) #0) - (predicateI _.IFLT)] - [text::char ..check-stringI jvm-intI - (_.INVOKEVIRTUAL "java.lang.String" "charAt" (_t.method (list _t.int) (#.Some _t.char) (list)) #0) - lux-intI] - ) - -(def: (text::concat [leftI rightI]) - Binary - (|>> leftI ..check-stringI - rightI ..check-stringI - (_.INVOKEVIRTUAL "java.lang.String" "concat" (_t.method (list $String) (#.Some $String) (list)) #0))) - -(def: (text::clip [startI endI subjectI]) - Trinary - (|>> subjectI ..check-stringI - startI jvm-intI - endI jvm-intI - (_.INVOKEVIRTUAL "java.lang.String" "substring" (_t.method (list _t.int _t.int) (#.Some $String) (list)) #0))) - -(def: index-method Method (_t.method (list $String _t.int) (#.Some _t.int) (list))) -(def: (text::index [startI partI textI]) - Trinary - (<| _.with-label (function (_ @not-found)) - _.with-label (function (_ @end)) - (|>> textI ..check-stringI - partI ..check-stringI - startI jvm-intI - (_.INVOKEVIRTUAL "java.lang.String" "indexOf" index-method #0) - _.DUP - (_.int -1) - (_.IF_ICMPEQ @not-found) - lux-intI - runtime.someI - (_.GOTO @end) - (_.label @not-found) - _.POP - runtime.noneI - (_.label @end)))) - -### I/O -(def: string-method Method (_t.method (list $String) #.None (list))) -(def: (io::log messageI) - Unary - (|>> (_.GETSTATIC "java.lang.System" "out" (_t.class "java.io.PrintStream" (list))) - messageI - ..check-stringI - (_.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method #0) - unitI)) - -(def: (io::error messageI) - Unary - (|>> (_.NEW "java.lang.Error") - _.DUP - messageI - ..check-stringI - (_.INVOKESPECIAL "java.lang.Error" "" string-method #0) - _.ATHROW)) - -(def: (io::exit codeI) - Unary - (|>> codeI jvm-intI - (_.INVOKESTATIC "java.lang.System" "exit" (_t.method (list _t.int) #.None (list)) #0) - _.NULL)) - -(def: (io::current-time _) - Nullary - (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" (_t.method (list) (#.Some _t.long) (list)) #0) - (_.wrap #$.Long))) - -## Bundles -(def: bundle::lux - Bundle - (|> (: Bundle bundle.empty) - (bundle.install "is" (binary lux::is)) - (bundle.install "try" (unary lux::try)))) - -(def: bundle::i64 - Bundle - (<| (bundle.prefix "i64") - (|> (: Bundle bundle.empty) - (bundle.install "and" (binary bit::and)) - (bundle.install "or" (binary bit::or)) - (bundle.install "xor" (binary bit::xor)) - (bundle.install "left-shift" (binary bit::left-shift)) - (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) - (bundle.install "+" (binary i64::+)) - (bundle.install "-" (binary i64::-)) - (bundle.install "=" (binary i64::=))))) - -(def: bundle::int - Bundle - (<| (bundle.prefix "int") - (|> (: Bundle bundle.empty) - (bundle.install "*" (binary int::*)) - (bundle.install "/" (binary int::/)) - (bundle.install "%" (binary int::%)) - (bundle.install "<" (binary int::<)) - (bundle.install "frac" (unary int::frac)) - (bundle.install "char" (unary int::char))))) - -(def: bundle::frac - Bundle - (<| (bundle.prefix "frac") - (|> (: Bundle bundle.empty) - (bundle.install "+" (binary frac::+)) - (bundle.install "-" (binary frac::-)) - (bundle.install "*" (binary frac::*)) - (bundle.install "/" (binary frac::/)) - (bundle.install "%" (binary frac::%)) - (bundle.install "=" (binary frac::=)) - (bundle.install "<" (binary frac::<)) - (bundle.install "smallest" (nullary frac::smallest)) - (bundle.install "min" (nullary frac::min)) - (bundle.install "max" (nullary frac::max)) - (bundle.install "int" (unary frac::int)) - (bundle.install "encode" (unary frac::encode)) - (bundle.install "decode" (unary frac::decode))))) - -(def: bundle::text - Bundle - (<| (bundle.prefix "text") - (|> (: Bundle bundle.empty) - (bundle.install "=" (binary text::=)) - (bundle.install "<" (binary text::<)) - (bundle.install "concat" (binary text::concat)) - (bundle.install "index" (trinary text::index)) - (bundle.install "size" (unary text::size)) - (bundle.install "char" (binary text::char)) - (bundle.install "clip" (trinary text::clip))))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> (: Bundle bundle.empty) - (bundle.install "log" (unary io::log)) - (bundle.install "error" (unary io::error)) - (bundle.install "exit" (unary io::exit)) - (bundle.install "current-time" (nullary io::current-time))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle::lux - (dictionary.merge bundle::i64) - (dictionary.merge bundle::int) - (dictionary.merge bundle::frac) - (dictionary.merge bundle::text) - (dictionary.merge bundle::io)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux new file mode 100644 index 000000000..aeaa1d664 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux @@ -0,0 +1,327 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["p" parser] + ["ex" exception (#+ exception:)]] + [data + ["." text + format] + [collection + ["." dictionary]]] + [tool + [compiler + ["." synthesis (#+ Synthesis)] + ["." phase + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)]] + ["." extension + ["." bundle]]]]] + [host (#+ import:)]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Method Bundle) + ["_t" type] + ["_" inst]]]]] + ["." /// + ["." runtime]]) + +(import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(def: $Object-Array $.Type (_t.array 1 ///.$Object)) +(def: $String $.Type (_t.class "java.lang.String" (list))) +(def: $CharSequence $.Type (_t.class "java.lang.CharSequence" (list))) + +(def: lux-intI Inst (|>> _.I2L (_.wrap #$.Long))) +(def: jvm-intI Inst (|>> (_.unwrap #$.Long) _.L2I)) +(def: check-stringI Inst (_.CHECKCAST "java.lang.String")) + +(def: (predicateI tester) + (-> (-> Label Inst) + Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> (tester @then) + (_.GETSTATIC "java.lang.Boolean" "FALSE" (_t.class "java.lang.Boolean" (list))) + (_.GOTO @end) + (_.label @then) + (_.GETSTATIC "java.lang.Boolean" "TRUE" (_t.class "java.lang.Boolean" (list))) + (_.label @end) + ))) + +(def: unitI Inst (_.string synthesis.unit)) + +(def: (lux::is [referenceI sampleI]) + (Binary Inst) + (|>> referenceI + sampleI + (predicateI _.IF_ACMPEQ))) + +(def: (lux::try riskyI) + (Unary Inst) + (|>> riskyI + (_.CHECKCAST ///.function-class) + (_.INVOKESTATIC ///.runtime-class "try" + (_t.method (list ///.$Function) (#.Some $Object-Array) (list)) + #0))) + +(template [ ] + [(def: ( [maskI inputI]) + (Binary Inst) + (|>> inputI (_.unwrap #$.Long) + maskI (_.unwrap #$.Long) + (_.wrap #$.Long)))] + + [bit::and _.LAND] + [bit::or _.LOR] + [bit::xor _.LXOR] + ) + +(template [ ] + [(def: ( [shiftI inputI]) + (Binary Inst) + (|>> inputI (_.unwrap #$.Long) + shiftI jvm-intI + + (_.wrap #$.Long)))] + + [bit::left-shift _.LSHL] + [bit::arithmetic-right-shift _.LSHR] + [bit::logical-right-shift _.LUSHR] + ) + +(template [ ] + [(def: ( _) + (Nullary Inst) + (|>> (_.wrap )))] + + [frac::smallest (_.double (Double::MIN_VALUE)) #$.Double] + [frac::min (_.double (f/* -1.0 (Double::MAX_VALUE))) #$.Double] + [frac::max (_.double (Double::MAX_VALUE)) #$.Double] + ) + +(template [ ] + [(def: ( [paramI subjectI]) + (Binary Inst) + (|>> subjectI (_.unwrap ) + paramI (_.unwrap ) + + (_.wrap )))] + + [i64::+ #$.Long _.LADD] + [i64::- #$.Long _.LSUB] + [int::* #$.Long _.LMUL] + [int::/ #$.Long _.LDIV] + [int::% #$.Long _.LREM] + + [frac::+ #$.Double _.DADD] + [frac::- #$.Double _.DSUB] + [frac::* #$.Double _.DMUL] + [frac::/ #$.Double _.DDIV] + [frac::% #$.Double _.DREM] + ) + +(template [ ] + [(template [ ] + [(def: ( [paramI subjectI]) + (Binary Inst) + (|>> subjectI + paramI + + (_.int ) + (predicateI _.IF_ICMPEQ)))] + + [ +0] + [ -1])] + + [i64::= int::< (_.unwrap #$.Long) _.LCMP] + [frac::= frac::< (_.unwrap #$.Double) _.DCMPG] + ) + +(template [ ] + [(def: ( inputI) + (Unary Inst) + (|>> inputI ))] + + [int::frac (_.unwrap #$.Long) (<| (_.wrap #$.Double) _.L2D)] + [int::char (_.unwrap #$.Long) + ((|>> _.L2I _.I2C (_.INVOKESTATIC "java.lang.Character" "toString" (_t.method (list _t.char) (#.Some $String) (list)) #0)))] + + [frac::int (_.unwrap #$.Double) (<| (_.wrap #$.Long) _.D2L)] + [frac::encode (_.unwrap #$.Double) + (_.INVOKESTATIC "java.lang.Double" "toString" (_t.method (list _t.double) (#.Some $String) (list)) #0)] + [frac::decode ..check-stringI + (_.INVOKESTATIC ///.runtime-class "decode_frac" (_t.method (list $String) (#.Some $Object-Array) (list)) #0)] + ) + +(def: (text::size inputI) + (Unary Inst) + (|>> inputI + ..check-stringI + (_.INVOKEVIRTUAL "java.lang.String" "length" (_t.method (list) (#.Some _t.int) (list)) #0) + lux-intI)) + +(template [ ] + [(def: ( [paramI subjectI]) + (Binary Inst) + (|>> subjectI + paramI + ))] + + [text::= (<|) (<|) + (_.INVOKEVIRTUAL "java.lang.Object" "equals" (_t.method (list ///.$Object) (#.Some _t.boolean) (list)) #0) + (_.wrap #$.Boolean)] + [text::< ..check-stringI ..check-stringI + (_.INVOKEVIRTUAL "java.lang.String" "compareTo" (_t.method (list $String) (#.Some _t.int) (list)) #0) + (predicateI _.IFLT)] + [text::char ..check-stringI jvm-intI + (_.INVOKEVIRTUAL "java.lang.String" "charAt" (_t.method (list _t.int) (#.Some _t.char) (list)) #0) + lux-intI] + ) + +(def: (text::concat [leftI rightI]) + (Binary Inst) + (|>> leftI ..check-stringI + rightI ..check-stringI + (_.INVOKEVIRTUAL "java.lang.String" "concat" (_t.method (list $String) (#.Some $String) (list)) #0))) + +(def: (text::clip [startI endI subjectI]) + (Trinary Inst) + (|>> subjectI ..check-stringI + startI jvm-intI + endI jvm-intI + (_.INVOKEVIRTUAL "java.lang.String" "substring" (_t.method (list _t.int _t.int) (#.Some $String) (list)) #0))) + +(def: index-method Method (_t.method (list $String _t.int) (#.Some _t.int) (list))) +(def: (text::index [startI partI textI]) + (Trinary Inst) + (<| _.with-label (function (_ @not-found)) + _.with-label (function (_ @end)) + (|>> textI ..check-stringI + partI ..check-stringI + startI jvm-intI + (_.INVOKEVIRTUAL "java.lang.String" "indexOf" index-method #0) + _.DUP + (_.int -1) + (_.IF_ICMPEQ @not-found) + lux-intI + runtime.someI + (_.GOTO @end) + (_.label @not-found) + _.POP + runtime.noneI + (_.label @end)))) + +(def: string-method Method (_t.method (list $String) #.None (list))) +(def: (io::log messageI) + (Unary Inst) + (|>> (_.GETSTATIC "java.lang.System" "out" (_t.class "java.io.PrintStream" (list))) + messageI + ..check-stringI + (_.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method #0) + unitI)) + +(def: (io::error messageI) + (Unary Inst) + (|>> (_.NEW "java.lang.Error") + _.DUP + messageI + ..check-stringI + (_.INVOKESPECIAL "java.lang.Error" "" string-method #0) + _.ATHROW)) + +(def: (io::exit codeI) + (Unary Inst) + (|>> codeI jvm-intI + (_.INVOKESTATIC "java.lang.System" "exit" (_t.method (list _t.int) #.None (list)) #0) + _.NULL)) + +(def: (io::current-time _) + (Nullary Inst) + (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" (_t.method (list) (#.Some _t.long) (list)) #0) + (_.wrap #$.Long))) + +(def: bundle::lux + Bundle + (|> (: Bundle bundle.empty) + (bundle.install "is" (binary lux::is)) + (bundle.install "try" (unary lux::try)))) + +(def: bundle::i64 + Bundle + (<| (bundle.prefix "i64") + (|> (: Bundle bundle.empty) + (bundle.install "and" (binary bit::and)) + (bundle.install "or" (binary bit::or)) + (bundle.install "xor" (binary bit::xor)) + (bundle.install "left-shift" (binary bit::left-shift)) + (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) + (bundle.install "+" (binary i64::+)) + (bundle.install "-" (binary i64::-)) + (bundle.install "=" (binary i64::=))))) + +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> (: Bundle bundle.empty) + (bundle.install "*" (binary int::*)) + (bundle.install "/" (binary int::/)) + (bundle.install "%" (binary int::%)) + (bundle.install "<" (binary int::<)) + (bundle.install "frac" (unary int::frac)) + (bundle.install "char" (unary int::char))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary frac::+)) + (bundle.install "-" (binary frac::-)) + (bundle.install "*" (binary frac::*)) + (bundle.install "/" (binary frac::/)) + (bundle.install "%" (binary frac::%)) + (bundle.install "=" (binary frac::=)) + (bundle.install "<" (binary frac::<)) + (bundle.install "smallest" (nullary frac::smallest)) + (bundle.install "min" (nullary frac::min)) + (bundle.install "max" (nullary frac::max)) + (bundle.install "int" (unary frac::int)) + (bundle.install "encode" (unary frac::encode)) + (bundle.install "decode" (unary frac::decode))))) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> (: Bundle bundle.empty) + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) + (bundle.install "concat" (binary text::concat)) + (bundle.install "index" (trinary text::index)) + (bundle.install "size" (unary text::size)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> (: Bundle bundle.empty) + (bundle.install "log" (unary io::log)) + (bundle.install "error" (unary io::error)) + (bundle.install "exit" (unary io::exit)) + (bundle.install "current-time" (nullary io::current-time))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dictionary.merge bundle::i64) + (dictionary.merge bundle::int) + (dictionary.merge bundle::frac) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux deleted file mode 100644 index 624af7ed8..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux +++ /dev/null @@ -1,761 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["p" parser ("#/." monad)] - ["ex" exception #+ exception:]) - (data [product] - ["e" error] - [text ("#/." equivalence)] - (text format - ["l" lexer]) - (coll [list ("#/." functor)] - (dictionary ["dict" unordered #+ Dict]))) - [macro ("#/." monad)] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["_" inst])) - ["la" analysis] - (extension (analysis ["&." host])) - ["ls" synthesis])) - (// ["@" common])) - -(template [] - [(exception: #export ( {message Text}) - message)] - - [Invalid-Syntax-For-JVM-Type] - [Invalid-Syntax-For-Argument-Generation] - ) - -(template [ ] - [(def: - $.Inst - )] - - [L2S (|>> _.L2I _.I2S)] - [L2B (|>> _.L2I _.I2B)] - [L2C (|>> _.L2I _.I2C)] - ) - -(template [ ] - [(def: ( inputI) - @.Unary - (if (is? _.NOP ) - (|>> inputI - (_.unwrap ) - (_.wrap )) - (|>> inputI - (_.unwrap ) - - (_.wrap ))))] - - [convert//double-to-float #$.Double _.D2F #$.Float] - [convert//double-to-int #$.Double _.D2I #$.Int] - [convert//double-to-long #$.Double _.D2L #$.Long] - [convert//float-to-double #$.Float _.F2D #$.Double] - [convert//float-to-int #$.Float _.F2I #$.Int] - [convert//float-to-long #$.Float _.F2L #$.Long] - [convert//int-to-byte #$.Int _.I2B #$.Byte] - [convert//int-to-char #$.Int _.I2C #$.Char] - [convert//int-to-double #$.Int _.I2D #$.Double] - [convert//int-to-float #$.Int _.I2F #$.Float] - [convert//int-to-long #$.Int _.I2L #$.Long] - [convert//int-to-short #$.Int _.I2S #$.Short] - [convert//long-to-double #$.Long _.L2D #$.Double] - [convert//long-to-float #$.Long _.L2F #$.Float] - [convert//long-to-int #$.Long _.L2I #$.Int] - [convert//long-to-short #$.Long L2S #$.Short] - [convert//long-to-byte #$.Long L2B #$.Byte] - [convert//long-to-char #$.Long L2C #$.Char] - [convert//char-to-byte #$.Char _.I2B #$.Byte] - [convert//char-to-short #$.Char _.I2S #$.Short] - [convert//char-to-int #$.Char _.NOP #$.Int] - [convert//char-to-long #$.Char _.I2L #$.Long] - [convert//byte-to-long #$.Byte _.I2L #$.Long] - [convert//short-to-long #$.Short _.I2L #$.Long] - ) - -(def: conversion-procs - @.Bundle - (<| (@.prefix "convert") - (|> (dict.new text.hash) - (@.install "double-to-float" (@.unary convert//double-to-float)) - (@.install "double-to-int" (@.unary convert//double-to-int)) - (@.install "double-to-long" (@.unary convert//double-to-long)) - (@.install "float-to-double" (@.unary convert//float-to-double)) - (@.install "float-to-int" (@.unary convert//float-to-int)) - (@.install "float-to-long" (@.unary convert//float-to-long)) - (@.install "int-to-byte" (@.unary convert//int-to-byte)) - (@.install "int-to-char" (@.unary convert//int-to-char)) - (@.install "int-to-double" (@.unary convert//int-to-double)) - (@.install "int-to-float" (@.unary convert//int-to-float)) - (@.install "int-to-long" (@.unary convert//int-to-long)) - (@.install "int-to-short" (@.unary convert//int-to-short)) - (@.install "long-to-double" (@.unary convert//long-to-double)) - (@.install "long-to-float" (@.unary convert//long-to-float)) - (@.install "long-to-int" (@.unary convert//long-to-int)) - (@.install "long-to-short" (@.unary convert//long-to-short)) - (@.install "long-to-byte" (@.unary convert//long-to-byte)) - (@.install "long-to-char" (@.unary convert//long-to-char)) - (@.install "char-to-byte" (@.unary convert//char-to-byte)) - (@.install "char-to-short" (@.unary convert//char-to-short)) - (@.install "char-to-int" (@.unary convert//char-to-int)) - (@.install "char-to-long" (@.unary convert//char-to-long)) - (@.install "byte-to-long" (@.unary convert//byte-to-long)) - (@.install "short-to-long" (@.unary convert//short-to-long)) - ))) - -(template [ ] - [(def: ( [xI yI]) - @.Binary - (|>> xI (_.unwrap ) - yI (_.unwrap ) - (_.wrap )))] - - [int//+ _.IADD #$.Int #$.Int #$.Int] - [int//- _.ISUB #$.Int #$.Int #$.Int] - [int//* _.IMUL #$.Int #$.Int #$.Int] - [int/// _.IDIV #$.Int #$.Int #$.Int] - [int//% _.IREM #$.Int #$.Int #$.Int] - [int//and _.IAND #$.Int #$.Int #$.Int] - [int//or _.IOR #$.Int #$.Int #$.Int] - [int//xor _.IXOR #$.Int #$.Int #$.Int] - [int//shl _.ISHL #$.Int #$.Int #$.Int] - [int//shr _.ISHR #$.Int #$.Int #$.Int] - [int//ushr _.IUSHR #$.Int #$.Int #$.Int] - - [long//+ _.LADD #$.Long #$.Long #$.Long] - [long//- _.LSUB #$.Long #$.Long #$.Long] - [long//* _.LMUL #$.Long #$.Long #$.Long] - [long/// _.LDIV #$.Long #$.Long #$.Long] - [long//% _.LREM #$.Long #$.Long #$.Long] - [long//and _.LAND #$.Long #$.Long #$.Long] - [long//or _.LOR #$.Long #$.Long #$.Long] - [long//xor _.LXOR #$.Long #$.Long #$.Long] - [long//shl _.LSHL #$.Long #$.Int #$.Long] - [long//shr _.LSHR #$.Long #$.Int #$.Long] - [long//ushr _.LUSHR #$.Long #$.Int #$.Long] - - [float//+ _.FADD #$.Float #$.Float #$.Float] - [float//- _.FSUB #$.Float #$.Float #$.Float] - [float//* _.FMUL #$.Float #$.Float #$.Float] - [float/// _.FDIV #$.Float #$.Float #$.Float] - [float//% _.FREM #$.Float #$.Float #$.Float] - - [double//+ _.DADD #$.Double #$.Double #$.Double] - [double//- _.DSUB #$.Double #$.Double #$.Double] - [double//* _.DMUL #$.Double #$.Double #$.Double] - [double/// _.DDIV #$.Double #$.Double #$.Double] - [double//% _.DREM #$.Double #$.Double #$.Double] - ) - -(def: boolean-class ($t.class "java.lang.Boolean" (list))) -(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class)) -(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class)) - -(template [ ] - [(def: ( [xI yI]) - @.Binary - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> xI (_.unwrap ) - yI (_.unwrap ) - ( @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [int//= _.IF_ICMPEQ #$.Int #$.Int #$.Boolean] - [int//< _.IF_ICMPLT #$.Int #$.Int #$.Boolean] - - [char//= _.IF_ICMPEQ #$.Char #$.Char #$.Boolean] - [char//< _.IF_ICMPLT #$.Char #$.Char #$.Boolean] - ) - -(template [ ] - [(def: ( [xI yI]) - @.Binary - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> xI (_.unwrap ) - yI (_.unwrap ) - - (_.int ) - (_.IF_ICMPEQ @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [long//= _.LCMP 0 #$.Long #$.Long #$.Boolean] - [long//< _.LCMP -1 #$.Long #$.Long #$.Boolean] - - [float//= _.FCMPG 0 #$.Float #$.Float #$.Boolean] - [float//< _.FCMPG -1 #$.Float #$.Float #$.Boolean] - - [double//= _.DCMPG 0 #$.Double #$.Double #$.Boolean] - [double//< _.DCMPG -1 #$.Double #$.Double #$.Boolean] - ) - -(def: int-procs - @.Bundle - (<| (@.prefix "int") - (|> (dict.new text.hash) - (@.install "+" (@.binary int//+)) - (@.install "-" (@.binary int//-)) - (@.install "*" (@.binary int//*)) - (@.install "/" (@.binary int///)) - (@.install "%" (@.binary int//%)) - (@.install "=" (@.binary int//=)) - (@.install "<" (@.binary int//<)) - (@.install "and" (@.binary int//and)) - (@.install "or" (@.binary int//or)) - (@.install "xor" (@.binary int//xor)) - (@.install "shl" (@.binary int//shl)) - (@.install "shr" (@.binary int//shr)) - (@.install "ushr" (@.binary int//ushr)) - ))) - -(def: long-procs - @.Bundle - (<| (@.prefix "long") - (|> (dict.new text.hash) - (@.install "+" (@.binary long//+)) - (@.install "-" (@.binary long//-)) - (@.install "*" (@.binary long//*)) - (@.install "/" (@.binary long///)) - (@.install "%" (@.binary long//%)) - (@.install "=" (@.binary long//=)) - (@.install "<" (@.binary long//<)) - (@.install "and" (@.binary long//and)) - (@.install "or" (@.binary long//or)) - (@.install "xor" (@.binary long//xor)) - (@.install "shl" (@.binary long//shl)) - (@.install "shr" (@.binary long//shr)) - (@.install "ushr" (@.binary long//ushr)) - ))) - -(def: float-procs - @.Bundle - (<| (@.prefix "float") - (|> (dict.new text.hash) - (@.install "+" (@.binary float//+)) - (@.install "-" (@.binary float//-)) - (@.install "*" (@.binary float//*)) - (@.install "/" (@.binary float///)) - (@.install "%" (@.binary float//%)) - (@.install "=" (@.binary float//=)) - (@.install "<" (@.binary float//<)) - ))) - -(def: double-procs - @.Bundle - (<| (@.prefix "double") - (|> (dict.new text.hash) - (@.install "+" (@.binary double//+)) - (@.install "-" (@.binary double//-)) - (@.install "*" (@.binary double//*)) - (@.install "/" (@.binary double///)) - (@.install "%" (@.binary double//%)) - (@.install "=" (@.binary double//=)) - (@.install "<" (@.binary double//<)) - ))) - -(def: char-procs - @.Bundle - (<| (@.prefix "char") - (|> (dict.new text.hash) - (@.install "=" (@.binary char//=)) - (@.install "<" (@.binary char//<)) - ))) - -(def: (array//length arrayI) - @.Unary - (|>> arrayI - _.ARRAYLENGTH - _.I2L - (_.wrap #$.Long))) - -(def: (array//new proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS)) - (do macro.monad - [lengthI (translate lengthS) - #let [arrayJT ($t.array level (case class - "boolean" $t.boolean - "byte" $t.byte - "short" $t.short - "int" $t.int - "long" $t.long - "float" $t.float - "double" $t.double - "char" $t.char - _ ($t.class class (list))))]] - (wrap (|>> lengthI - (_.unwrap #$.Long) - _.L2I - (_.array arrayJT)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (array//read proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] idxS arrayS)) - (do macro.monad - [arrayI (translate arrayS) - idxI (translate idxS) - #let [loadI (case class - "boolean" (|>> _.BALOAD (_.wrap #$.Boolean)) - "byte" (|>> _.BALOAD (_.wrap #$.Byte)) - "short" (|>> _.SALOAD (_.wrap #$.Short)) - "int" (|>> _.IALOAD (_.wrap #$.Int)) - "long" (|>> _.LALOAD (_.wrap #$.Long)) - "float" (|>> _.FALOAD (_.wrap #$.Float)) - "double" (|>> _.DALOAD (_.wrap #$.Double)) - "char" (|>> _.CALOAD (_.wrap #$.Char)) - _ _.AALOAD)]] - (wrap (|>> arrayI - idxI - (_.unwrap #$.Long) - _.L2I - loadI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (array//write proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] idxS valueS arrayS)) - (do macro.monad - [arrayI (translate arrayS) - idxI (translate idxS) - valueI (translate valueS) - #let [storeI (case class - "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE) - "byte" (|>> (_.unwrap #$.Byte) _.BASTORE) - "short" (|>> (_.unwrap #$.Short) _.SASTORE) - "int" (|>> (_.unwrap #$.Int) _.IASTORE) - "long" (|>> (_.unwrap #$.Long) _.LASTORE) - "float" (|>> (_.unwrap #$.Float) _.FASTORE) - "double" (|>> (_.unwrap #$.Double) _.DASTORE) - "char" (|>> (_.unwrap #$.Char) _.CASTORE) - _ _.AASTORE)]] - (wrap (|>> arrayI - _.DUP - idxI - (_.unwrap #$.Long) - _.L2I - valueI - storeI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: array-procs - @.Bundle - (<| (@.prefix "array") - (|> (dict.new text.hash) - (@.install "length" (@.unary array//length)) - (@.install "new" array//new) - (@.install "read" array//read) - (@.install "write" array//write) - ))) - -(def: (object//null _) - @.Nullary - _.NULL) - -(def: (object//null? objectI) - @.Unary - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> objectI - (_.IFNULL @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end)))) - -(def: (object//synchronized [monitorI exprI]) - @.Binary - (|>> monitorI - _.DUP - _.MONITORENTER - exprI - _.SWAP - _.MONITOREXIT)) - -(def: (object//throw exceptionI) - @.Unary - (|>> exceptionI - _.ATHROW)) - -(def: (object//class proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)])) - (do macro.monad - [] - (wrap (|>> (_.string class) - (_.INVOKESTATIC "java.lang.Class" "forName" - ($t.method (list ($t.class "java.lang.String" (list))) - (#.Some ($t.class "java.lang.Class" (list))) - (list)) - #0)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (object//instance? proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] objectS)) - (do macro.monad - [objectI (translate objectS)] - (wrap (|>> objectI - (_.INSTANCEOF class) - (_.wrap #$.Boolean)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (object//cast proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text from)] [_ (#.Text to)] valueS)) - (do macro.monad - [valueI (translate valueS)] - (case [from to] - ## Wrap - (^template [ ] - [ ] - (wrap (|>> valueI (_.wrap ))) - - [ ] - (wrap (|>> valueI (_.unwrap )))) - (["boolean" "java.lang.Boolean" #$.Boolean] - ["byte" "java.lang.Byte" #$.Byte] - ["short" "java.lang.Short" #$.Short] - ["int" "java.lang.Integer" #$.Int] - ["long" "java.lang.Long" #$.Long] - ["float" "java.lang.Float" #$.Float] - ["double" "java.lang.Double" #$.Double] - ["char" "java.lang.Character" #$.Char]) - - _ - (wrap valueI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: object-procs - @.Bundle - (<| (@.prefix "object") - (|> (dict.new text.hash) - (@.install "null" (@.nullary object//null)) - (@.install "null?" (@.unary object//null?)) - (@.install "synchronized" (@.binary object//synchronized)) - (@.install "throw" (@.unary object//throw)) - (@.install "class" object//class) - (@.install "instance?" object//instance?) - (@.install "cast" object//cast) - ))) - -(def: primitives - (Dict Text $.Primitive) - (|> (list ["boolean" #$.Boolean] - ["byte" #$.Byte] - ["short" #$.Short] - ["int" #$.Int] - ["long" #$.Long] - ["float" #$.Float] - ["double" #$.Double] - ["char" #$.Char]) - (dict.from-list text.hash))) - -(def: (static//get proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)])) - (do macro.monad - [] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> (_.GETSTATIC class field (#$.Primitive primitive)) - (_.wrap primitive)))) - - #.None - (wrap (_.GETSTATIC class field ($t.class unboxed (list)))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (static//put proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS)) - (do macro.monad - [valueI (translate valueS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> valueI - (_.unwrap primitive) - (_.PUTSTATIC class field (#$.Primitive primitive)) - (_.string hostL.unit)))) - - #.None - (wrap (|>> valueI - (_.CHECKCAST class) - (_.PUTSTATIC class field ($t.class class (list))) - (_.string hostL.unit))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (virtual//get proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS)) - (do macro.monad - [objectI (translate objectS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> objectI - (_.CHECKCAST class) - (_.GETFIELD class field (#$.Primitive primitive)) - (_.wrap primitive)))) - - #.None - (wrap (|>> objectI - (_.CHECKCAST class) - (_.GETFIELD class field ($t.class unboxed (list))))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (virtual//put proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS)) - (do macro.monad - [valueI (translate valueS) - objectI (translate objectS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> objectI - (_.CHECKCAST class) - _.DUP - valueI - (_.unwrap primitive) - (_.PUTFIELD class field (#$.Primitive primitive))))) - - #.None - (wrap (|>> objectI - (_.CHECKCAST class) - _.DUP - valueI - (_.CHECKCAST unboxed) - (_.PUTFIELD class field ($t.class unboxed (list))))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: base-type - (l.Lexer $.Type) - ($_ p.either - (p.after (l.this "boolean") (parser/wrap $t.boolean)) - (p.after (l.this "byte") (parser/wrap $t.byte)) - (p.after (l.this "short") (parser/wrap $t.short)) - (p.after (l.this "int") (parser/wrap $t.int)) - (p.after (l.this "long") (parser/wrap $t.long)) - (p.after (l.this "float") (parser/wrap $t.float)) - (p.after (l.this "double") (parser/wrap $t.double)) - (p.after (l.this "char") (parser/wrap $t.char)) - (parser/map (function (_ name) - ($t.class name (list))) - (l.many (l.none-of "["))) - )) - -(def: java-type - (l.Lexer $.Type) - (do p.monad - [raw base-type - nesting (p.some (l.this "[]"))] - (wrap ($t.array (list.size nesting) raw)))) - -(def: (translate-type argD) - (-> Text (Meta $.Type)) - (case (l.run argD java-type) - (#e.Error error) - (&.throw Invalid-Syntax-For-JVM-Type argD) - - (#e.Success type) - (macro/wrap type))) - -(def: (translate-arg translate argS) - (-> (-> ls.Synthesis (Meta $.Inst)) ls.Synthesis - (Meta [$.Type $.Inst])) - (case argS - (^ [_ (#.Tuple (list [_ (#.Text argD)] argS))]) - (do macro.monad - [argT (translate-type argD) - argI (translate argS)] - (wrap [argT argI])) - - _ - (&.throw Invalid-Syntax-For-Argument-Generation ""))) - -(def: (method-return-type description) - (-> Text (Meta (Maybe $.Type))) - (case description - "void" - (macro/wrap #.None) - - _ - (macro/map (|>> #.Some) (translate-type description)))) - -(def: (invoke//static proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] [_ (#.Text method)] - [_ (#.Text unboxed)] argsS)) - (do macro.monad - [argsTI (monad.map @ (translate-arg translate) argsS) - returnT (method-return-type unboxed)] - (wrap (|>> (_.fuse (list/map product.right argsTI)) - (_.INVOKESTATIC class method - ($t.method (list/map product.left argsTI) returnT (list)) - #0)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(template [ ] - [(def: ( proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] [_ (#.Text method)] - [_ (#.Text unboxed)] objectS argsS)) - (do macro.monad - [objectI (translate objectS) - argsTI (monad.map @ (translate-arg translate) argsS) - returnT (method-return-type unboxed)] - (wrap (|>> objectI - (_.CHECKCAST class) - (_.fuse (list/map product.right argsTI)) - ( class method - ($t.method (list/map product.left argsTI) returnT (list)) - )))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))] - - [invoke//virtual _.INVOKEVIRTUAL #0] - [invoke//special _.INVOKESPECIAL #0] - [invoke//interface _.INVOKEINTERFACE #1] - ) - -(def: (invoke//constructor proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] argsS)) - (do macro.monad - [argsTI (monad.map @ (translate-arg translate) argsS)] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse (list/map product.right argsTI)) - (_.INVOKESPECIAL class "" - ($t.method (list/map product.left argsTI) #.None (list)) - #0)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: member-procs - @.Bundle - (<| (@.prefix "member") - (|> (dict.new text.hash) - (dict.merge (<| (@.prefix "static") - (|> (dict.new text.hash) - (@.install "get" static//get) - (@.install "put" static//put)))) - (dict.merge (<| (@.prefix "virtual") - (|> (dict.new text.hash) - (@.install "get" virtual//get) - (@.install "put" virtual//put)))) - (dict.merge (<| (@.prefix "invoke") - (|> (dict.new text.hash) - (@.install "static" invoke//static) - (@.install "virtual" invoke//virtual) - (@.install "special" invoke//special) - (@.install "interface" invoke//interface) - (@.install "constructor" invoke//constructor)))) - ))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "jvm") - (|> conversion-procs - (dict.merge int-procs) - (dict.merge long-procs) - (dict.merge float-procs) - (dict.merge double-procs) - (dict.merge char-procs) - (dict.merge array-procs) - (dict.merge object-procs) - (dict.merge member-procs) - ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux new file mode 100644 index 000000000..45e025d0b --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -0,0 +1,753 @@ +(.module: + [lux (#- int char) + [abstract + ["." monad (#+ do)]] + [control + ["p" parser ("#@." monad)] + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." error] + ["." text + format + ["l" lexer]] + [collection + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)]]] + [tool + [compiler + ["." synthesis (#+ Synthesis %synthesis)] + ["." phase ("#@." monad) + [generation + [extension (#+ Nullary Unary Binary + nullary unary binary)]] + ["." extension + ["." bundle]]]]] + [host (#+ import:)]] + [luxc + [lang + [host + ["$" jvm (#+ Primitive Label Inst Method Handler Bundle Operation) + ["_t" type] + ["_" inst]]]]]) + +(template [] + [(exception: #export ( {message Text}) + message)] + + [invalid-syntax-for-jvm-type] + [invalid-syntax-for-argument-generation] + ) + +(template [ ] + [(def: + Inst + )] + + [L2S (|>> _.L2I _.I2S)] + [L2B (|>> _.L2I _.I2B)] + [L2C (|>> _.L2I _.I2C)] + ) + +(template [ ] + [(def: ( inputI) + (Unary Inst) + (if (is? _.NOP ) + (|>> inputI + (_.unwrap ) + (_.wrap )) + (|>> inputI + (_.unwrap ) + + (_.wrap ))))] + + [convert::double-to-float #$.Double _.D2F #$.Float] + [convert::double-to-int #$.Double _.D2I #$.Int] + [convert::double-to-long #$.Double _.D2L #$.Long] + [convert::float-to-double #$.Float _.F2D #$.Double] + [convert::float-to-int #$.Float _.F2I #$.Int] + [convert::float-to-long #$.Float _.F2L #$.Long] + [convert::int-to-byte #$.Int _.I2B #$.Byte] + [convert::int-to-char #$.Int _.I2C #$.Char] + [convert::int-to-double #$.Int _.I2D #$.Double] + [convert::int-to-float #$.Int _.I2F #$.Float] + [convert::int-to-long #$.Int _.I2L #$.Long] + [convert::int-to-short #$.Int _.I2S #$.Short] + [convert::long-to-double #$.Long _.L2D #$.Double] + [convert::long-to-float #$.Long _.L2F #$.Float] + [convert::long-to-int #$.Long _.L2I #$.Int] + [convert::long-to-short #$.Long L2S #$.Short] + [convert::long-to-byte #$.Long L2B #$.Byte] + [convert::long-to-char #$.Long L2C #$.Char] + [convert::char-to-byte #$.Char _.I2B #$.Byte] + [convert::char-to-short #$.Char _.I2S #$.Short] + [convert::char-to-int #$.Char _.NOP #$.Int] + [convert::char-to-long #$.Char _.I2L #$.Long] + [convert::byte-to-long #$.Byte _.I2L #$.Long] + [convert::short-to-long #$.Short _.I2L #$.Long] + ) + +(def: conversion + Bundle + (<| (bundle.prefix "convert") + (|> (: Bundle bundle.empty) + (bundle.install "double-to-float" (unary convert::double-to-float)) + (bundle.install "double-to-int" (unary convert::double-to-int)) + (bundle.install "double-to-long" (unary convert::double-to-long)) + (bundle.install "float-to-double" (unary convert::float-to-double)) + (bundle.install "float-to-int" (unary convert::float-to-int)) + (bundle.install "float-to-long" (unary convert::float-to-long)) + (bundle.install "int-to-byte" (unary convert::int-to-byte)) + (bundle.install "int-to-char" (unary convert::int-to-char)) + (bundle.install "int-to-double" (unary convert::int-to-double)) + (bundle.install "int-to-float" (unary convert::int-to-float)) + (bundle.install "int-to-long" (unary convert::int-to-long)) + (bundle.install "int-to-short" (unary convert::int-to-short)) + (bundle.install "long-to-double" (unary convert::long-to-double)) + (bundle.install "long-to-float" (unary convert::long-to-float)) + (bundle.install "long-to-int" (unary convert::long-to-int)) + (bundle.install "long-to-short" (unary convert::long-to-short)) + (bundle.install "long-to-byte" (unary convert::long-to-byte)) + (bundle.install "long-to-char" (unary convert::long-to-char)) + (bundle.install "char-to-byte" (unary convert::char-to-byte)) + (bundle.install "char-to-short" (unary convert::char-to-short)) + (bundle.install "char-to-int" (unary convert::char-to-int)) + (bundle.install "char-to-long" (unary convert::char-to-long)) + (bundle.install "byte-to-long" (unary convert::byte-to-long)) + (bundle.install "short-to-long" (unary convert::short-to-long)) + ))) + +(template [ ] + [(def: ( [xI yI]) + (Binary Inst) + (|>> xI (_.unwrap ) + yI (_.unwrap ) + (_.wrap )))] + + [int::+ _.IADD #$.Int #$.Int #$.Int] + [int::- _.ISUB #$.Int #$.Int #$.Int] + [int::* _.IMUL #$.Int #$.Int #$.Int] + [int::/ _.IDIV #$.Int #$.Int #$.Int] + [int::% _.IREM #$.Int #$.Int #$.Int] + [int::and _.IAND #$.Int #$.Int #$.Int] + [int::or _.IOR #$.Int #$.Int #$.Int] + [int::xor _.IXOR #$.Int #$.Int #$.Int] + [int::shl _.ISHL #$.Int #$.Int #$.Int] + [int::shr _.ISHR #$.Int #$.Int #$.Int] + [int::ushr _.IUSHR #$.Int #$.Int #$.Int] + + [long::+ _.LADD #$.Long #$.Long #$.Long] + [long::- _.LSUB #$.Long #$.Long #$.Long] + [long::* _.LMUL #$.Long #$.Long #$.Long] + [long::/ _.LDIV #$.Long #$.Long #$.Long] + [long::% _.LREM #$.Long #$.Long #$.Long] + [long::and _.LAND #$.Long #$.Long #$.Long] + [long::or _.LOR #$.Long #$.Long #$.Long] + [long::xor _.LXOR #$.Long #$.Long #$.Long] + [long::shl _.LSHL #$.Long #$.Int #$.Long] + [long::shr _.LSHR #$.Long #$.Int #$.Long] + [long::ushr _.LUSHR #$.Long #$.Int #$.Long] + + [float::+ _.FADD #$.Float #$.Float #$.Float] + [float::- _.FSUB #$.Float #$.Float #$.Float] + [float::* _.FMUL #$.Float #$.Float #$.Float] + [float::/ _.FDIV #$.Float #$.Float #$.Float] + [float::% _.FREM #$.Float #$.Float #$.Float] + + [double::+ _.DADD #$.Double #$.Double #$.Double] + [double::- _.DSUB #$.Double #$.Double #$.Double] + [double::* _.DMUL #$.Double #$.Double #$.Double] + [double::/ _.DDIV #$.Double #$.Double #$.Double] + [double::% _.DREM #$.Double #$.Double #$.Double] + ) + +(def: boolean-class (_t.class "java.lang.Boolean" (list))) +(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class)) +(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class)) + +(template [ ] + [(def: ( [xI yI]) + (Binary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> xI (_.unwrap ) + yI (_.unwrap ) + ( @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end))))] + + [int::= _.IF_ICMPEQ #$.Int] + [int::< _.IF_ICMPLT #$.Int] + + [char::= _.IF_ICMPEQ #$.Char] + [char::< _.IF_ICMPLT #$.Char] + ) + +(template [ ] + [(def: ( [xI yI]) + (Binary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> xI (_.unwrap ) + yI (_.unwrap ) + + (_.int ) + (_.IF_ICMPEQ @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end))))] + + [long::= _.LCMP +0 #$.Long] + [long::< _.LCMP -1 #$.Long] + + [float::= _.FCMPG +0 #$.Float] + [float::< _.FCMPG -1 #$.Float] + + [double::= _.DCMPG +0 #$.Double] + [double::< _.DCMPG -1 #$.Double] + ) + +(def: int + Bundle + (<| (bundle.prefix "int") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary int::+)) + (bundle.install "-" (binary int::-)) + (bundle.install "*" (binary int::*)) + (bundle.install "/" (binary int::/)) + (bundle.install "%" (binary int::%)) + (bundle.install "=" (binary int::=)) + (bundle.install "<" (binary int::<)) + (bundle.install "and" (binary int::and)) + (bundle.install "or" (binary int::or)) + (bundle.install "xor" (binary int::xor)) + (bundle.install "shl" (binary int::shl)) + (bundle.install "shr" (binary int::shr)) + (bundle.install "ushr" (binary int::ushr)) + ))) + +(def: long + Bundle + (<| (bundle.prefix "long") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary long::+)) + (bundle.install "-" (binary long::-)) + (bundle.install "*" (binary long::*)) + (bundle.install "/" (binary long::/)) + (bundle.install "%" (binary long::%)) + (bundle.install "=" (binary long::=)) + (bundle.install "<" (binary long::<)) + (bundle.install "and" (binary long::and)) + (bundle.install "or" (binary long::or)) + (bundle.install "xor" (binary long::xor)) + (bundle.install "shl" (binary long::shl)) + (bundle.install "shr" (binary long::shr)) + (bundle.install "ushr" (binary long::ushr)) + ))) + +(def: float + Bundle + (<| (bundle.prefix "float") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary float::+)) + (bundle.install "-" (binary float::-)) + (bundle.install "*" (binary float::*)) + (bundle.install "/" (binary float::/)) + (bundle.install "%" (binary float::%)) + (bundle.install "=" (binary float::=)) + (bundle.install "<" (binary float::<)) + ))) + +(def: double + Bundle + (<| (bundle.prefix "double") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary double::+)) + (bundle.install "-" (binary double::-)) + (bundle.install "*" (binary double::*)) + (bundle.install "/" (binary double::/)) + (bundle.install "%" (binary double::%)) + (bundle.install "=" (binary double::=)) + (bundle.install "<" (binary double::<)) + ))) + +(def: char + Bundle + (<| (bundle.prefix "char") + (|> (: Bundle bundle.empty) + (bundle.install "=" (binary char::=)) + (bundle.install "<" (binary char::<)) + ))) + +(def: (array::length arrayD arrayI) + (Binary Inst) + (|>> arrayI + (_.CHECKCAST arrayD) + _.ARRAYLENGTH + _.I2L + (_.wrap #$.Long))) + +(def: (array::new proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.i64 level) + (synthesis.text class) + lengthS)) + (do phase.monad + [lengthI (generate lengthS) + #let [arrayJT (_t.array (.nat level) + (case class + "boolean" _t.boolean + "byte" _t.byte + "short" _t.short + "int" _t.int + "long" _t.long + "float" _t.float + "double" _t.double + "char" _t.char + _ (_t.class class (list))))]] + (wrap (|>> lengthI + (_.unwrap #$.Long) + _.L2I + (_.array arrayJT)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (array::read proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + idxS + arrayS)) + (do phase.monad + [arrayI (generate arrayS) + idxI (generate idxS) + #let [loadI (case class + "boolean" (|>> _.BALOAD (_.wrap #$.Boolean)) + "byte" (|>> _.BALOAD (_.wrap #$.Byte)) + "short" (|>> _.SALOAD (_.wrap #$.Short)) + "int" (|>> _.IALOAD (_.wrap #$.Int)) + "long" (|>> _.LALOAD (_.wrap #$.Long)) + "float" (|>> _.FALOAD (_.wrap #$.Float)) + "double" (|>> _.DALOAD (_.wrap #$.Double)) + "char" (|>> _.CALOAD (_.wrap #$.Char)) + _ _.AALOAD)]] + (wrap (|>> arrayI + idxI + (_.unwrap #$.Long) + _.L2I + loadI))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (array::write proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + idxS + valueS + arrayS)) + (do phase.monad + [arrayI (generate arrayS) + idxI (generate idxS) + valueI (generate valueS) + #let [storeI (case class + "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE) + "byte" (|>> (_.unwrap #$.Byte) _.BASTORE) + "short" (|>> (_.unwrap #$.Short) _.SASTORE) + "int" (|>> (_.unwrap #$.Int) _.IASTORE) + "long" (|>> (_.unwrap #$.Long) _.LASTORE) + "float" (|>> (_.unwrap #$.Float) _.FASTORE) + "double" (|>> (_.unwrap #$.Double) _.DASTORE) + "char" (|>> (_.unwrap #$.Char) _.CASTORE) + _ _.AASTORE)]] + (wrap (|>> arrayI + _.DUP + idxI + (_.unwrap #$.Long) + _.L2I + valueI + storeI))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: array + Bundle + (<| (bundle.prefix "array") + (|> (: Bundle bundle.empty) + (bundle.install "length" (unary array::length)) + (bundle.install "new" array::new) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + ))) + +(def: (object::null _) + (Nullary Inst) + _.NULL) + +(def: (object::null? objectI) + (Unary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> objectI + (_.IFNULL @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end)))) + +(def: (object::synchronized [monitorI exprI]) + (Binary Inst) + (|>> monitorI + _.DUP + _.MONITORENTER + exprI + _.SWAP + _.MONITOREXIT)) + +(def: (object::throw exceptionI) + (Unary Inst) + (|>> exceptionI + _.ATHROW)) + +(def: (object::class proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class))) + (do phase.monad + [] + (wrap (|>> (_.string class) + (_.INVOKESTATIC "java.lang.Class" "forName" + (_t.method (list (_t.class "java.lang.String" (list))) + (#.Some (_t.class "java.lang.Class" (list))) + (list)) + false)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (object::instance? proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) objectS)) + (do phase.monad + [objectI (generate objectS)] + (wrap (|>> objectI + (_.INSTANCEOF class) + (_.wrap #$.Boolean)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (object::cast proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text from) (synthesis.text to) valueS)) + (do phase.monad + [valueI (generate valueS)] + (case [from to] + ## Wrap + (^template [ ] + [ ] + (wrap (|>> valueI (_.wrap ))) + + [ ] + (wrap (|>> valueI (_.unwrap )))) + (["boolean" "java.lang.Boolean" #$.Boolean] + ["byte" "java.lang.Byte" #$.Byte] + ["short" "java.lang.Short" #$.Short] + ["int" "java.lang.Integer" #$.Int] + ["long" "java.lang.Long" #$.Long] + ["float" "java.lang.Float" #$.Float] + ["double" "java.lang.Double" #$.Double] + ["char" "java.lang.Character" #$.Char]) + + _ + (wrap valueI))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: object + Bundle + (<| (bundle.prefix "object") + (|> (: Bundle bundle.empty) + (bundle.install "null" (nullary object::null)) + (bundle.install "null?" (unary object::null?)) + (bundle.install "synchronized" (binary object::synchronized)) + (bundle.install "throw" (unary object::throw)) + (bundle.install "class" object::class) + (bundle.install "instance?" object::instance?) + (bundle.install "cast" object::cast) + ))) + +(def: primitives + (Dictionary Text Primitive) + (|> (list ["boolean" #$.Boolean] + ["byte" #$.Byte] + ["short" #$.Short] + ["int" #$.Int] + ["long" #$.Long] + ["float" #$.Float] + ["double" #$.Double] + ["char" #$.Char]) + (dictionary.from-list text.hash))) + +(def: (static::get proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + (synthesis.text field) + (synthesis.text unboxed))) + (do phase.monad + [] + (case (dictionary.get unboxed primitives) + (#.Some primitive) + (wrap (|>> (_.GETSTATIC class field (#$.Primitive primitive)) + (_.wrap primitive))) + + #.None + (wrap (_.GETSTATIC class field (_t.class unboxed (list)))))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (static::put proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + (synthesis.text field) + (synthesis.text unboxed) + valueS)) + (do phase.monad + [valueI (generate valueS)] + (case (dictionary.get unboxed primitives) + (#.Some primitive) + (wrap (|>> valueI + (_.unwrap primitive) + (_.PUTSTATIC class field (#$.Primitive primitive)) + (_.string synthesis.unit))) + + #.None + (wrap (|>> valueI + (_.CHECKCAST class) + (_.PUTSTATIC class field (_t.class class (list))) + (_.string synthesis.unit))))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (virtual::get proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + (synthesis.text field) + (synthesis.text unboxed) + objectS)) + (do phase.monad + [objectI (generate objectS)] + (case (dictionary.get unboxed primitives) + (#.Some primitive) + (wrap (|>> objectI + (_.CHECKCAST class) + (_.GETFIELD class field (#$.Primitive primitive)) + (_.wrap primitive))) + + #.None + (wrap (|>> objectI + (_.CHECKCAST class) + (_.GETFIELD class field (_t.class unboxed (list))))))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (virtual::put proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + (synthesis.text field) + (synthesis.text unboxed) + valueS + objectS)) + (do phase.monad + [valueI (generate valueS) + objectI (generate objectS)] + (case (dictionary.get unboxed primitives) + (#.Some primitive) + (wrap (|>> objectI + (_.CHECKCAST class) + _.DUP + valueI + (_.unwrap primitive) + (_.PUTFIELD class field (#$.Primitive primitive)))) + + #.None + (wrap (|>> objectI + (_.CHECKCAST class) + _.DUP + valueI + (_.CHECKCAST unboxed) + (_.PUTFIELD class field (_t.class unboxed (list))))))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: base-type + (l.Lexer $.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 "["))) + )) + +(def: java-type + (l.Lexer $.Type) + (do p.monad + [raw base-type + nesting (p.some (l.this "[]"))] + (wrap (_t.array (list.size nesting) raw)))) + +(def: (generate-type argD) + (-> Text (Operation $.Type)) + (case (l.run argD java-type) + (#error.Failure error) + (phase.throw invalid-syntax-for-jvm-type argD) + + (#error.Success type) + (phase@wrap type))) + +(def: (generate-arg generate argS) + (-> (-> Synthesis (Operation Inst)) Synthesis + (Operation [$.Type Inst])) + (case argS + (^ (synthesis.tuple (list (synthesis.text argD) argS))) + (do phase.monad + [argT (generate-type argD) + argI (generate argS)] + (wrap [argT argI])) + + _ + (phase.throw invalid-syntax-for-argument-generation ""))) + +(def: (method-return-type description) + (-> Text (Operation (Maybe $.Type))) + (case description + "void" + (phase@wrap #.None) + + _ + (phase@map (|>> #.Some) (generate-type description)))) + +(def: (invoke::static proc generate inputs) + Handler + (case inputs + (^ (list& (synthesis.text class) + (synthesis.text method) + (synthesis.text unboxed) + argsS)) + (do phase.monad + [argsTI (monad.map @ (generate-arg generate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> (_.fuse (list@map product.right argsTI)) + (_.INVOKESTATIC class method + (_t.method (list@map product.left argsTI) returnT (list)) + false)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(template [ ] + [(def: ( proc generate inputs) + Handler + (case inputs + (^ (list& (synthesis.text class) + (synthesis.text method) + (synthesis.text unboxed) + objectS + argsS)) + (do phase.monad + [objectI (generate objectS) + argsTI (monad.map @ (generate-arg generate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> objectI + (_.CHECKCAST class) + (_.fuse (list@map product.right argsTI)) + ( class method + (_t.method (list@map product.left argsTI) returnT (list)) + )))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs])))] + + [invoke::virtual _.INVOKEVIRTUAL false] + [invoke::special _.INVOKESPECIAL false] + [invoke::interface _.INVOKEINTERFACE true] + ) + +(def: (invoke::constructor proc generate inputs) + Handler + (case inputs + (^ (list& (synthesis.text class) argsS)) + (do phase.monad + [argsTI (monad.map @ (generate-arg generate) argsS)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse (list@map product.right argsTI)) + (_.INVOKESPECIAL class "" + (_t.method (list@map product.left argsTI) #.None (list)) + false)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: member + Bundle + (<| (bundle.prefix "member") + (|> (: Bundle bundle.empty) + (dictionary.merge (<| (bundle.prefix "static") + (|> (: Bundle bundle.empty) + (bundle.install "get" static::get) + (bundle.install "put" static::put)))) + (dictionary.merge (<| (bundle.prefix "virtual") + (|> (: Bundle bundle.empty) + (bundle.install "get" virtual::get) + (bundle.install "put" virtual::put)))) + (dictionary.merge (<| (bundle.prefix "invoke") + (|> (: Bundle bundle.empty) + (bundle.install "static" invoke::static) + (bundle.install "virtual" invoke::virtual) + (bundle.install "special" invoke::special) + (bundle.install "interface" invoke::interface) + (bundle.install "constructor" invoke::constructor)))) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "jvm") + (|> ..conversion + (dictionary.merge ..int) + (dictionary.merge ..long) + (dictionary.merge ..float) + (dictionary.merge ..double) + (dictionary.merge ..char) + (dictionary.merge ..array) + (dictionary.merge ..object) + (dictionary.merge ..member) + ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux deleted file mode 100644 index c821a9de2..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux +++ /dev/null @@ -1,57 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [data - [text - format]] - [tool - [compiler - ["." name] - ["." reference (#+ Register Variable)] - ["." phase ("operation/." monad) - ["." generation]]]]] - [luxc - [lang - [host - [jvm (#+ Inst Operation) - ["$t" type] - ["_" inst]]]]] - ["." //]) - -(template [ ] - [(def: #export ( idx) - (-> Nat Text) - (|> idx %n (format )))] - - [foreign-name "f"] - [partial-name "p"] - ) - -(def: (foreign variable) - (-> Register (Operation Inst)) - (do phase.monad - [function-class generation.context] - (wrap (|>> (_.ALOAD 0) - (_.GETFIELD function-class - (|> variable .nat foreign-name) - //.$Object))))) - -(def: local - (-> Register (Operation Inst)) - (|>> _.ALOAD operation/wrap)) - -(def: #export (variable variable) - (-> Variable (Operation Inst)) - (case variable - (#reference.Local variable) - (local variable) - - (#reference.Foreign variable) - (foreign variable))) - -(def: #export (constant name) - (-> Name (Operation Inst)) - (do phase.monad - [bytecode-name (generation.remember name)] - (operation/wrap (_.GETSTATIC bytecode-name //.value-field //.$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.lux new file mode 100644 index 000000000..c821a9de2 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/reference.lux @@ -0,0 +1,57 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [data + [text + format]] + [tool + [compiler + ["." name] + ["." reference (#+ Register Variable)] + ["." phase ("operation/." monad) + ["." generation]]]]] + [luxc + [lang + [host + [jvm (#+ Inst Operation) + ["$t" type] + ["_" inst]]]]] + ["." //]) + +(template [ ] + [(def: #export ( idx) + (-> Nat Text) + (|> idx %n (format )))] + + [foreign-name "f"] + [partial-name "p"] + ) + +(def: (foreign variable) + (-> Register (Operation Inst)) + (do phase.monad + [function-class generation.context] + (wrap (|>> (_.ALOAD 0) + (_.GETFIELD function-class + (|> variable .nat foreign-name) + //.$Object))))) + +(def: local + (-> Register (Operation Inst)) + (|>> _.ALOAD operation/wrap)) + +(def: #export (variable variable) + (-> Variable (Operation Inst)) + (case variable + (#reference.Local variable) + (local variable) + + (#reference.Foreign variable) + (foreign variable))) + +(def: #export (constant name) + (-> Name (Operation Inst)) + (do phase.monad + [bytecode-name (generation.remember name)] + (operation/wrap (_.GETSTATIC bytecode-name //.value-field //.$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux deleted file mode 100644 index d21729d0e..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux +++ /dev/null @@ -1,361 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [data - [text - format] - [collection - ["." list ("#/." functor)]]] - ["." math] - [tool - [compiler - [analysis (#+ Arity)] - ["." synthesis] - ["." phase - ["." generation]]]]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Method Def Operation) - ["$t" type] - ["$d" def] - ["_" inst]]]]] - ["." // (#+ ByteCode)]) - -(def: $Object $.Type ($t.class "java.lang.Object" (list))) -(def: $Object-Array $.Type ($t.array 1 $Object)) -(def: $String $.Type ($t.class "java.lang.String" (list))) -(def: #export $Stack $.Type ($t.array 1 $Object)) -(def: #export $Tuple $.Type $Object-Array) -(def: #export $Variant $.Type $Object-Array) -(def: #export $Tag $.Type $t.int) -(def: #export $Flag $.Type $Object) -(def: #export $Datum $.Type $Object) -(def: #export $Function $.Type ($t.class //.function-class (list))) -(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list))) -(def: $Runtime $.Type ($t.class "java.lang.Runtime" (list))) - -(def: #export logI - Inst - (let [outI (_.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) - printI (function (_ method) (_.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) #0))] - (|>> outI (_.string "LOG: ") (printI "print") - outI _.SWAP (printI "println")))) - -(def: variant-method - Method - ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list))) - -(def: #export variantI - Inst - (_.INVOKESTATIC //.runtime-class "variant_make" variant-method #0)) - -(def: #export leftI - Inst - (|>> (_.int +0) - _.NULL - _.DUP2_X1 - _.POP2 - variantI)) - -(def: #export rightI - Inst - (|>> (_.int +1) - (_.string "") - _.DUP2_X1 - _.POP2 - variantI)) - -(def: #export someI Inst rightI) - -(def: #export noneI - Inst - (|>> (_.int +0) - _.NULL - (_.string synthesis.unit) - variantI)) - -(def: (try-methodI unsafeI) - (-> Inst Inst) - (<| _.with-label (function (_ @from)) - _.with-label (function (_ @to)) - _.with-label (function (_ @handler)) - (|>> (_.try @from @to @handler "java.lang.Exception") - (_.label @from) - unsafeI - someI - _.ARETURN - (_.label @to) - (_.label @handler) - noneI - _.ARETURN))) - -(def: #export string-concatI - Inst - (_.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0)) - -(def: #export partials-field Text "partials") -(def: #export apply-method Text "apply") -(def: #export num-apply-variants Nat 8) - -(def: #export (apply-signature arity) - (-> Arity Method) - ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) - -(def: adt-methods - Def - (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap #$.Int) _.AASTORE) - store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) - store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] - (|>> ($d.method #$.Public $.staticM "variant_make" - ($t.method (list $t.int $Object $Object) - (#.Some $Variant) - (list)) - (|>> (_.int +3) - (_.array $Object) - store-tagI - store-flagI - store-valueI - _.ARETURN))))) - -(def: frac-shiftI Inst (_.double (math.pow +32.0 +2.0))) - -(def: frac-methods - Def - (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) - (try-methodI - (|>> (_.ALOAD 0) - (_.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) #0) - (_.wrap #$.Double)))) - )) - -(def: pm-methods - Def - (let [tuple-sizeI (|>> (_.ALOAD 0) _.ARRAYLENGTH) - last-rightI (|>> tuple-sizeI (_.int +1) _.ISUB) - leftsI (_.ILOAD 1) - left-indexI leftsI - sub-leftsI (|>> leftsI - last-rightI - _.ISUB) - sub-tupleI (|>> (_.ALOAD 0) last-rightI _.AALOAD (_.CHECKCAST ($t.descriptor $Tuple))) - recurI (: (-> Label Inst) - (function (_ @loop) - (|>> sub-leftsI (_.ISTORE 1) - sub-tupleI (_.ASTORE 0) - (_.GOTO @loop))))] - (|>> ($d.method #$.Public $.staticM "pm_fail" ($t.method (list) #.None (list)) - (|>> (_.NEW "java.lang.IllegalStateException") - _.DUP - (_.string "Invalid expression for pattern-matching.") - (_.INVOKESPECIAL "java.lang.IllegalStateException" "" ($t.method (list $String) #.None (list)) #0) - _.ATHROW)) - ($d.method #$.Public $.staticM "apply_fail" ($t.method (list) #.None (list)) - (|>> (_.NEW "java.lang.IllegalStateException") - _.DUP - (_.string "Error while applying function.") - (_.INVOKESPECIAL "java.lang.IllegalStateException" "" ($t.method (list $String) #.None (list)) #0) - _.ATHROW)) - ($d.method #$.Public $.staticM "pm_push" ($t.method (list $Stack $Object) (#.Some $Stack) (list)) - (|>> (_.int +2) - (_.ANEWARRAY "java.lang.Object") - _.DUP - (_.int +0) - (_.ALOAD 0) - _.AASTORE - _.DUP - (_.int +1) - (_.ALOAD 1) - _.AASTORE - _.ARETURN)) - ($d.method #$.Public $.staticM "pm_pop" ($t.method (list $Stack) (#.Some $Stack) (list)) - (|>> (_.ALOAD 0) - (_.int +0) - _.AALOAD - (_.CHECKCAST ($t.descriptor $Stack)) - _.ARETURN)) - ($d.method #$.Public $.staticM "pm_peek" ($t.method (list $Stack) (#.Some $Object) (list)) - (|>> (_.ALOAD 0) - (_.int +1) - _.AALOAD - _.ARETURN)) - ($d.method #$.Public $.staticM "pm_variant" ($t.method (list $Variant $Tag $Flag) (#.Some $Object) (list)) - (<| _.with-label (function (_ @loop)) - _.with-label (function (_ @just-return)) - _.with-label (function (_ @then)) - _.with-label (function (_ @further)) - _.with-label (function (_ @shorten)) - _.with-label (function (_ @wrong)) - (let [variant-partI (: (-> Nat Inst) - (function (_ idx) - (|>> (_.int (.int idx)) _.AALOAD))) - tagI (: Inst - (|>> (variant-partI 0) (_.unwrap #$.Int))) - flagI (variant-partI 1) - datumI (variant-partI 2) - shortenI (|>> (_.ALOAD 0) tagI ## Get tag - (_.ILOAD 1) _.ISUB ## Shorten tag - (_.ALOAD 0) flagI ## Get flag - (_.ALOAD 0) datumI ## Get value - variantI ## Build sum - _.ARETURN) - update-tagI (|>> _.ISUB (_.ISTORE 1)) - update-variantI (|>> (_.ALOAD 0) datumI (_.CHECKCAST ($t.descriptor $Variant)) (_.ASTORE 0)) - failureI (|>> _.NULL _.ARETURN) - return-datumI (|>> (_.ALOAD 0) datumI _.ARETURN)]) - (|>> (_.label @loop) - (_.ILOAD 1) ## tag - (_.ALOAD 0) tagI ## tag, sumT - _.DUP2 (_.IF_ICMPEQ @then) - _.DUP2 (_.IF_ICMPGT @further) - _.DUP2 (_.IF_ICMPLT @shorten) - ## _.POP2 - failureI - (_.label @then) ## tag, sumT - (_.ALOAD 2) ## tag, sumT, wants-last? - (_.ALOAD 0) flagI ## tag, sumT, wants-last?, is-last? - (_.IF_ACMPEQ @just-return) ## tag, sumT - (_.label @further) ## tag, sumT - (_.ALOAD 0) flagI ## tag, sumT, last? - (_.IFNULL @wrong) ## tag, sumT - update-tagI - update-variantI - (_.GOTO @loop) - (_.label @just-return) ## tag, sumT - ## _.POP2 - return-datumI - (_.label @shorten) ## tag, sumT - (_.ALOAD 2) (_.IFNULL @wrong) - ## _.POP2 - shortenI - (_.label @wrong) ## tag, sumT - ## _.POP2 - failureI))) - ($d.method #$.Public $.staticM "tuple_left" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) - (<| _.with-label (function (_ @loop)) - _.with-label (function (_ @recursive)) - (let [left-accessI (|>> (_.ALOAD 0) left-indexI _.AALOAD)]) - (|>> (_.label @loop) - leftsI last-rightI (_.IF_ICMPGE @recursive) - left-accessI - _.ARETURN - (_.label @recursive) - ## Recursive - (recurI @loop)))) - ($d.method #$.Public $.staticM "tuple_right" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) - (<| _.with-label (function (_ @loop)) - _.with-label (function (_ @not-tail)) - _.with-label (function (_ @slice)) - (let [right-indexI (|>> leftsI - (_.int +1) - _.IADD) - right-accessI (|>> (_.ALOAD 0) - _.SWAP - _.AALOAD) - sub-rightI (|>> (_.ALOAD 0) - right-indexI - tuple-sizeI - (_.INVOKESTATIC "java.util.Arrays" "copyOfRange" - ($t.method (list $Object-Array $t.int $t.int) - (#.Some $Object-Array) - (list)) - #0))]) - (|>> (_.label @loop) - last-rightI right-indexI - _.DUP2 (_.IF_ICMPNE @not-tail) - ## _.POP - right-accessI - _.ARETURN - (_.label @not-tail) - (_.IF_ICMPGT @slice) - ## Must recurse - (recurI @loop) - (_.label @slice) - sub-rightI - _.ARETURN - ))) - ))) - -(def: io-methods - Def - (let [string-writerI (|>> (_.NEW "java.io.StringWriter") - _.DUP - (_.INVOKESPECIAL "java.io.StringWriter" "" ($t.method (list) #.None (list)) #0)) - print-writerI (|>> (_.NEW "java.io.PrintWriter") - _.SWAP - _.DUP2 - _.POP - _.SWAP - (_.boolean #1) - (_.INVOKESPECIAL "java.io.PrintWriter" "" ($t.method (list ($t.class "java.io.Writer" (list)) $t.boolean) #.None (list)) #0) - )] - (|>> ($d.method #$.Public $.staticM "try" ($t.method (list $Function) (#.Some $Variant) (list)) - (<| _.with-label (function (_ @from)) - _.with-label (function (_ @to)) - _.with-label (function (_ @handler)) - (|>> (_.try @from @to @handler "java.lang.Throwable") - (_.label @from) - (_.ALOAD 0) - _.NULL - (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature 1) #0) - rightI - _.ARETURN - (_.label @to) - (_.label @handler) - string-writerI ## TW - _.DUP2 ## TWTW - print-writerI ## TWTP - (_.INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t.method (list ($t.class "java.io.PrintWriter" (list))) #.None (list)) #0) ## TW - (_.INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t.method (list) (#.Some $String) (list)) #0) ## TS - _.SWAP _.POP leftI - _.ARETURN))) - ))) - -(def: translate-runtime - (Operation ByteCode) - (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) ["java.lang.Object" (list)] (list) - (|>> adt-methods - frac-methods - pm-methods - io-methods))] - (do phase.monad - [_ (generation.execute! //.runtime-class [//.runtime-class bytecode])] - (wrap bytecode)))) - -(def: translate-function - (Operation ByteCode) - (let [applyI (|> (list.n/range 2 num-apply-variants) - (list/map (function (_ arity) - ($d.method #$.Public $.noneM apply-method (apply-signature arity) - (let [preI (|> (list.n/range 0 (dec arity)) - (list/map _.ALOAD) - _.fuse)] - (|>> preI - (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature (dec arity)) #0) - (_.CHECKCAST //.function-class) - (_.ALOAD arity) - (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature 1) #0) - _.ARETURN))))) - (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1))) - $d.fuse) - bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) ["java.lang.Object" (list)] (list) - (|>> ($d.field #$.Public $.finalF partials-field $t.int) - ($d.method #$.Public $.noneM "" ($t.method (list $t.int) #.None (list)) - (|>> (_.ALOAD 0) - (_.INVOKESPECIAL "java.lang.Object" "" ($t.method (list) #.None (list)) #0) - (_.ALOAD 0) - (_.ILOAD 1) - (_.PUTFIELD //.function-class partials-field $t.int) - _.RETURN)) - applyI))] - (do phase.monad - [_ (generation.execute! //.function-class [//.function-class bytecode])] - (wrap bytecode)))) - -(def: #export translate - (Operation Any) - (do phase.monad - [runtime-bc translate-runtime - function-bc translate-function] - (wrap []))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux new file mode 100644 index 000000000..d21729d0e --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux @@ -0,0 +1,361 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [data + [text + format] + [collection + ["." list ("#/." functor)]]] + ["." math] + [tool + [compiler + [analysis (#+ Arity)] + ["." synthesis] + ["." phase + ["." generation]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Method Def Operation) + ["$t" type] + ["$d" def] + ["_" inst]]]]] + ["." // (#+ ByteCode)]) + +(def: $Object $.Type ($t.class "java.lang.Object" (list))) +(def: $Object-Array $.Type ($t.array 1 $Object)) +(def: $String $.Type ($t.class "java.lang.String" (list))) +(def: #export $Stack $.Type ($t.array 1 $Object)) +(def: #export $Tuple $.Type $Object-Array) +(def: #export $Variant $.Type $Object-Array) +(def: #export $Tag $.Type $t.int) +(def: #export $Flag $.Type $Object) +(def: #export $Datum $.Type $Object) +(def: #export $Function $.Type ($t.class //.function-class (list))) +(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list))) +(def: $Runtime $.Type ($t.class "java.lang.Runtime" (list))) + +(def: #export logI + Inst + (let [outI (_.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) + printI (function (_ method) (_.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) #0))] + (|>> outI (_.string "LOG: ") (printI "print") + outI _.SWAP (printI "println")))) + +(def: variant-method + Method + ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list))) + +(def: #export variantI + Inst + (_.INVOKESTATIC //.runtime-class "variant_make" variant-method #0)) + +(def: #export leftI + Inst + (|>> (_.int +0) + _.NULL + _.DUP2_X1 + _.POP2 + variantI)) + +(def: #export rightI + Inst + (|>> (_.int +1) + (_.string "") + _.DUP2_X1 + _.POP2 + variantI)) + +(def: #export someI Inst rightI) + +(def: #export noneI + Inst + (|>> (_.int +0) + _.NULL + (_.string synthesis.unit) + variantI)) + +(def: (try-methodI unsafeI) + (-> Inst Inst) + (<| _.with-label (function (_ @from)) + _.with-label (function (_ @to)) + _.with-label (function (_ @handler)) + (|>> (_.try @from @to @handler "java.lang.Exception") + (_.label @from) + unsafeI + someI + _.ARETURN + (_.label @to) + (_.label @handler) + noneI + _.ARETURN))) + +(def: #export string-concatI + Inst + (_.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0)) + +(def: #export partials-field Text "partials") +(def: #export apply-method Text "apply") +(def: #export num-apply-variants Nat 8) + +(def: #export (apply-signature arity) + (-> Arity Method) + ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) + +(def: adt-methods + Def + (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap #$.Int) _.AASTORE) + store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) + store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] + (|>> ($d.method #$.Public $.staticM "variant_make" + ($t.method (list $t.int $Object $Object) + (#.Some $Variant) + (list)) + (|>> (_.int +3) + (_.array $Object) + store-tagI + store-flagI + store-valueI + _.ARETURN))))) + +(def: frac-shiftI Inst (_.double (math.pow +32.0 +2.0))) + +(def: frac-methods + Def + (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) + (try-methodI + (|>> (_.ALOAD 0) + (_.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) #0) + (_.wrap #$.Double)))) + )) + +(def: pm-methods + Def + (let [tuple-sizeI (|>> (_.ALOAD 0) _.ARRAYLENGTH) + last-rightI (|>> tuple-sizeI (_.int +1) _.ISUB) + leftsI (_.ILOAD 1) + left-indexI leftsI + sub-leftsI (|>> leftsI + last-rightI + _.ISUB) + sub-tupleI (|>> (_.ALOAD 0) last-rightI _.AALOAD (_.CHECKCAST ($t.descriptor $Tuple))) + recurI (: (-> Label Inst) + (function (_ @loop) + (|>> sub-leftsI (_.ISTORE 1) + sub-tupleI (_.ASTORE 0) + (_.GOTO @loop))))] + (|>> ($d.method #$.Public $.staticM "pm_fail" ($t.method (list) #.None (list)) + (|>> (_.NEW "java.lang.IllegalStateException") + _.DUP + (_.string "Invalid expression for pattern-matching.") + (_.INVOKESPECIAL "java.lang.IllegalStateException" "" ($t.method (list $String) #.None (list)) #0) + _.ATHROW)) + ($d.method #$.Public $.staticM "apply_fail" ($t.method (list) #.None (list)) + (|>> (_.NEW "java.lang.IllegalStateException") + _.DUP + (_.string "Error while applying function.") + (_.INVOKESPECIAL "java.lang.IllegalStateException" "" ($t.method (list $String) #.None (list)) #0) + _.ATHROW)) + ($d.method #$.Public $.staticM "pm_push" ($t.method (list $Stack $Object) (#.Some $Stack) (list)) + (|>> (_.int +2) + (_.ANEWARRAY "java.lang.Object") + _.DUP + (_.int +0) + (_.ALOAD 0) + _.AASTORE + _.DUP + (_.int +1) + (_.ALOAD 1) + _.AASTORE + _.ARETURN)) + ($d.method #$.Public $.staticM "pm_pop" ($t.method (list $Stack) (#.Some $Stack) (list)) + (|>> (_.ALOAD 0) + (_.int +0) + _.AALOAD + (_.CHECKCAST ($t.descriptor $Stack)) + _.ARETURN)) + ($d.method #$.Public $.staticM "pm_peek" ($t.method (list $Stack) (#.Some $Object) (list)) + (|>> (_.ALOAD 0) + (_.int +1) + _.AALOAD + _.ARETURN)) + ($d.method #$.Public $.staticM "pm_variant" ($t.method (list $Variant $Tag $Flag) (#.Some $Object) (list)) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @just-return)) + _.with-label (function (_ @then)) + _.with-label (function (_ @further)) + _.with-label (function (_ @shorten)) + _.with-label (function (_ @wrong)) + (let [variant-partI (: (-> Nat Inst) + (function (_ idx) + (|>> (_.int (.int idx)) _.AALOAD))) + tagI (: Inst + (|>> (variant-partI 0) (_.unwrap #$.Int))) + flagI (variant-partI 1) + datumI (variant-partI 2) + shortenI (|>> (_.ALOAD 0) tagI ## Get tag + (_.ILOAD 1) _.ISUB ## Shorten tag + (_.ALOAD 0) flagI ## Get flag + (_.ALOAD 0) datumI ## Get value + variantI ## Build sum + _.ARETURN) + update-tagI (|>> _.ISUB (_.ISTORE 1)) + update-variantI (|>> (_.ALOAD 0) datumI (_.CHECKCAST ($t.descriptor $Variant)) (_.ASTORE 0)) + failureI (|>> _.NULL _.ARETURN) + return-datumI (|>> (_.ALOAD 0) datumI _.ARETURN)]) + (|>> (_.label @loop) + (_.ILOAD 1) ## tag + (_.ALOAD 0) tagI ## tag, sumT + _.DUP2 (_.IF_ICMPEQ @then) + _.DUP2 (_.IF_ICMPGT @further) + _.DUP2 (_.IF_ICMPLT @shorten) + ## _.POP2 + failureI + (_.label @then) ## tag, sumT + (_.ALOAD 2) ## tag, sumT, wants-last? + (_.ALOAD 0) flagI ## tag, sumT, wants-last?, is-last? + (_.IF_ACMPEQ @just-return) ## tag, sumT + (_.label @further) ## tag, sumT + (_.ALOAD 0) flagI ## tag, sumT, last? + (_.IFNULL @wrong) ## tag, sumT + update-tagI + update-variantI + (_.GOTO @loop) + (_.label @just-return) ## tag, sumT + ## _.POP2 + return-datumI + (_.label @shorten) ## tag, sumT + (_.ALOAD 2) (_.IFNULL @wrong) + ## _.POP2 + shortenI + (_.label @wrong) ## tag, sumT + ## _.POP2 + failureI))) + ($d.method #$.Public $.staticM "tuple_left" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @recursive)) + (let [left-accessI (|>> (_.ALOAD 0) left-indexI _.AALOAD)]) + (|>> (_.label @loop) + leftsI last-rightI (_.IF_ICMPGE @recursive) + left-accessI + _.ARETURN + (_.label @recursive) + ## Recursive + (recurI @loop)))) + ($d.method #$.Public $.staticM "tuple_right" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @not-tail)) + _.with-label (function (_ @slice)) + (let [right-indexI (|>> leftsI + (_.int +1) + _.IADD) + right-accessI (|>> (_.ALOAD 0) + _.SWAP + _.AALOAD) + sub-rightI (|>> (_.ALOAD 0) + right-indexI + tuple-sizeI + (_.INVOKESTATIC "java.util.Arrays" "copyOfRange" + ($t.method (list $Object-Array $t.int $t.int) + (#.Some $Object-Array) + (list)) + #0))]) + (|>> (_.label @loop) + last-rightI right-indexI + _.DUP2 (_.IF_ICMPNE @not-tail) + ## _.POP + right-accessI + _.ARETURN + (_.label @not-tail) + (_.IF_ICMPGT @slice) + ## Must recurse + (recurI @loop) + (_.label @slice) + sub-rightI + _.ARETURN + ))) + ))) + +(def: io-methods + Def + (let [string-writerI (|>> (_.NEW "java.io.StringWriter") + _.DUP + (_.INVOKESPECIAL "java.io.StringWriter" "" ($t.method (list) #.None (list)) #0)) + print-writerI (|>> (_.NEW "java.io.PrintWriter") + _.SWAP + _.DUP2 + _.POP + _.SWAP + (_.boolean #1) + (_.INVOKESPECIAL "java.io.PrintWriter" "" ($t.method (list ($t.class "java.io.Writer" (list)) $t.boolean) #.None (list)) #0) + )] + (|>> ($d.method #$.Public $.staticM "try" ($t.method (list $Function) (#.Some $Variant) (list)) + (<| _.with-label (function (_ @from)) + _.with-label (function (_ @to)) + _.with-label (function (_ @handler)) + (|>> (_.try @from @to @handler "java.lang.Throwable") + (_.label @from) + (_.ALOAD 0) + _.NULL + (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature 1) #0) + rightI + _.ARETURN + (_.label @to) + (_.label @handler) + string-writerI ## TW + _.DUP2 ## TWTW + print-writerI ## TWTP + (_.INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t.method (list ($t.class "java.io.PrintWriter" (list))) #.None (list)) #0) ## TW + (_.INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t.method (list) (#.Some $String) (list)) #0) ## TS + _.SWAP _.POP leftI + _.ARETURN))) + ))) + +(def: translate-runtime + (Operation ByteCode) + (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) ["java.lang.Object" (list)] (list) + (|>> adt-methods + frac-methods + pm-methods + io-methods))] + (do phase.monad + [_ (generation.execute! //.runtime-class [//.runtime-class bytecode])] + (wrap bytecode)))) + +(def: translate-function + (Operation ByteCode) + (let [applyI (|> (list.n/range 2 num-apply-variants) + (list/map (function (_ arity) + ($d.method #$.Public $.noneM apply-method (apply-signature arity) + (let [preI (|> (list.n/range 0 (dec arity)) + (list/map _.ALOAD) + _.fuse)] + (|>> preI + (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature (dec arity)) #0) + (_.CHECKCAST //.function-class) + (_.ALOAD arity) + (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature 1) #0) + _.ARETURN))))) + (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1))) + $d.fuse) + bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) ["java.lang.Object" (list)] (list) + (|>> ($d.field #$.Public $.finalF partials-field $t.int) + ($d.method #$.Public $.noneM "" ($t.method (list $t.int) #.None (list)) + (|>> (_.ALOAD 0) + (_.INVOKESPECIAL "java.lang.Object" "" ($t.method (list) #.None (list)) #0) + (_.ALOAD 0) + (_.ILOAD 1) + (_.PUTFIELD //.function-class partials-field $t.int) + _.RETURN)) + applyI))] + (do phase.monad + [_ (generation.execute! //.function-class [//.function-class bytecode])] + (wrap bytecode)))) + +(def: #export translate + (Operation Any) + (do phase.monad + [runtime-bc translate-runtime + function-bc translate-function] + (wrap []))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux deleted file mode 100644 index 527228c8e..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux +++ /dev/null @@ -1,70 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["ex" exception (#+ exception:)]] - [data - [text - format] - [collection - ["." list]]] - [tool - [compiler - [synthesis (#+ Synthesis)] - ["." phase]]]] - [luxc - [lang - [host - ["." jvm (#+ Inst Operation Phase) - ["$t" type] - ["_" inst]]]]] - ["." //]) - -(exception: #export (not-a-tuple {size Nat}) - (ex.report ["Expected size" ">= 2"] - ["Actual size" (%n size)])) - -(def: $Object jvm.Type ($t.class "java.lang.Object" (list))) - -(def: #export (tuple translate members) - (-> Phase (List Synthesis) (Operation Inst)) - (do phase.monad - [#let [size (list.size members)] - _ (phase.assert not-a-tuple size - (n/>= 2 size)) - membersI (|> members - list.enumerate - (monad.map @ (function (_ [idx member]) - (do @ - [memberI (translate member)] - (wrap (|>> _.DUP - (_.int (.int idx)) - memberI - _.AASTORE))))) - (:: @ map _.fuse))] - (wrap (|>> (_.int (.int size)) - (_.array $Object) - membersI)))) - -(def: (flagI right?) - (-> Bit Inst) - (if right? - (_.string "") - _.NULL)) - -(def: #export (variant translate lefts right? member) - (-> Phase Nat Bit Synthesis (Operation Inst)) - (do phase.monad - [memberI (translate member)] - (wrap (|>> (_.int (.int (if right? - (.inc lefts) - lefts))) - (flagI right?) - memberI - (_.INVOKESTATIC //.runtime-class - "variant_make" - ($t.method (list $t.int $Object $Object) - (#.Some ($t.array 1 $Object)) - (list)) - #0))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.lux new file mode 100644 index 000000000..527228c8e --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/structure.lux @@ -0,0 +1,70 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + [text + format] + [collection + ["." list]]] + [tool + [compiler + [synthesis (#+ Synthesis)] + ["." phase]]]] + [luxc + [lang + [host + ["." jvm (#+ Inst Operation Phase) + ["$t" type] + ["_" inst]]]]] + ["." //]) + +(exception: #export (not-a-tuple {size Nat}) + (ex.report ["Expected size" ">= 2"] + ["Actual size" (%n size)])) + +(def: $Object jvm.Type ($t.class "java.lang.Object" (list))) + +(def: #export (tuple translate members) + (-> Phase (List Synthesis) (Operation Inst)) + (do phase.monad + [#let [size (list.size members)] + _ (phase.assert not-a-tuple size + (n/>= 2 size)) + membersI (|> members + list.enumerate + (monad.map @ (function (_ [idx member]) + (do @ + [memberI (translate member)] + (wrap (|>> _.DUP + (_.int (.int idx)) + memberI + _.AASTORE))))) + (:: @ map _.fuse))] + (wrap (|>> (_.int (.int size)) + (_.array $Object) + membersI)))) + +(def: (flagI right?) + (-> Bit Inst) + (if right? + (_.string "") + _.NULL)) + +(def: #export (variant translate lefts right? member) + (-> Phase Nat Bit Synthesis (Operation Inst)) + (do phase.monad + [memberI (translate member)] + (wrap (|>> (_.int (.int (if right? + (.inc lefts) + lefts))) + (flagI right?) + memberI + (_.INVOKESTATIC //.runtime-class + "variant_make" + ($t.method (list $t.int $Object $Object) + (#.Some ($t.array 1 $Object)) + (list)) + #0))))) diff --git a/stdlib/source/lux/host/jvm/loader.jvm.lux b/stdlib/source/lux/host/jvm/loader.jvm.lux new file mode 100644 index 000000000..0ca92fa23 --- /dev/null +++ b/stdlib/source/lux/host/jvm/loader.jvm.lux @@ -0,0 +1,126 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)] + ["." io (#+ IO)] + [concurrency + ["." atom (#+ Atom)]]] + [data + ["." error (#+ Error)] + ["." text + format] + [collection + ["." array] + ["." list ("#;." functor)] + ["." dictionary (#+ Dictionary)]]] + [world + ["." binary (#+ Binary)]] + ["." host (#+ import: object do-to)]]) + +(type: #export Library + (Atom (Dictionary Text Binary))) + +(exception: #export (already-stored {class Text}) + (ex.report ["Class" class])) + +(exception: #export (unknown {class Text} {known-classes (List Text)}) + (ex.report ["Class" class] + ["Known classes" (|> known-classes + (list.sort (:: text.order <)) + (list;map (|>> (format text.new-line text.tab))) + (text.join-with ""))])) + +(exception: #export (cannot-define {class Text} {error Text}) + (ex.report ["Class" class] + ["Error" error])) + +(import: #long java/lang/Object + (getClass [] (java/lang/Class java/lang/Object))) + +(import: #long java/lang/String) + +(import: #long java/lang/reflect/Method + (invoke [java/lang/Object (Array java/lang/Object)] + #try java/lang/Object)) + +(import: #long (java/lang/Class a) + (getDeclaredMethod [java/lang/String (Array (java/lang/Class java/lang/Object))] + #try java/lang/reflect/Method)) + +(import: #long java/lang/Integer + (#static TYPE (java/lang/Class java/lang/Integer))) + +(import: #long java/lang/reflect/AccessibleObject + (setAccessible [boolean] void)) + +(import: #long java/lang/ClassLoader + (loadClass [java/lang/String] + #io #try (java/lang/Class java/lang/Object))) + +(def: java/lang/ClassLoader::defineClass + java/lang/reflect/Method + (let [signature (|> (host.array (java/lang/Class java/lang/Object) 4) + (host.array-write 0 (:coerce (java/lang/Class java/lang/Object) + (host.class-for java/lang/String))) + (host.array-write 1 (java/lang/Object::getClass (host.array byte 0))) + (host.array-write 2 (:coerce (java/lang/Class java/lang/Object) + (java/lang/Integer::TYPE))) + (host.array-write 3 (:coerce (java/lang/Class java/lang/Object) + (java/lang/Integer::TYPE))))] + (do-to (error.assume + (java/lang/Class::getDeclaredMethod "defineClass" + signature + (host.class-for java/lang/ClassLoader))) + (java/lang/reflect/AccessibleObject::setAccessible true)))) + +(def: #export (define class-name bytecode loader) + (-> Text Binary java/lang/ClassLoader (Error java/lang/Object)) + (let [signature (array.from-list (list (:coerce java/lang/Object + class-name) + (:coerce java/lang/Object + bytecode) + (:coerce java/lang/Object + (host.long-to-int +0)) + (:coerce java/lang/Object + (host.long-to-int (.int (binary.size bytecode))))))] + (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) + +(def: #export (new-library _) + (-> Any Library) + (atom.atom (dictionary.new text.hash))) + +(def: #export (memory library) + (-> Library java/lang/ClassLoader) + (object [] java/lang/ClassLoader [] + [] + (java/lang/ClassLoader (findClass {class-name java/lang/String}) java/lang/Class + (let [classes (|> library atom.read io.run)] + (case (dictionary.get class-name classes) + (#.Some bytecode) + (case (|> _jvm_this + (..define class-name bytecode)) + (#error.Success class) + (:assume class) + + (#error.Failure error) + (error! (ex.construct ..cannot-define [class-name error]))) + + #.None + (error! (ex.construct ..unknown [class-name (dictionary.keys classes)]))))))) + +(def: #export (store name bytecode library) + (-> Text Binary Library (IO (Error Any))) + (do io.monad + [library' (atom.read library)] + (if (dictionary.contains? name library') + (wrap (ex.throw ..already-stored name)) + (do @ + [_ (atom.update (dictionary.put name bytecode) library)] + (wrap (#error.Success [])))))) + +(def: #export (load name loader) + (-> Text java/lang/ClassLoader + (IO (Error (java/lang/Class java/lang/Object)))) + (java/lang/ClassLoader::loadClass name loader)) diff --git a/stdlib/source/lux/host/jvm/loader.old.lux b/stdlib/source/lux/host/jvm/loader.old.lux deleted file mode 100644 index 0ca92fa23..000000000 --- a/stdlib/source/lux/host/jvm/loader.old.lux +++ /dev/null @@ -1,126 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - ["." io (#+ IO)] - [concurrency - ["." atom (#+ Atom)]]] - [data - ["." error (#+ Error)] - ["." text - format] - [collection - ["." array] - ["." list ("#;." functor)] - ["." dictionary (#+ Dictionary)]]] - [world - ["." binary (#+ Binary)]] - ["." host (#+ import: object do-to)]]) - -(type: #export Library - (Atom (Dictionary Text Binary))) - -(exception: #export (already-stored {class Text}) - (ex.report ["Class" class])) - -(exception: #export (unknown {class Text} {known-classes (List Text)}) - (ex.report ["Class" class] - ["Known classes" (|> known-classes - (list.sort (:: text.order <)) - (list;map (|>> (format text.new-line text.tab))) - (text.join-with ""))])) - -(exception: #export (cannot-define {class Text} {error Text}) - (ex.report ["Class" class] - ["Error" error])) - -(import: #long java/lang/Object - (getClass [] (java/lang/Class java/lang/Object))) - -(import: #long java/lang/String) - -(import: #long java/lang/reflect/Method - (invoke [java/lang/Object (Array java/lang/Object)] - #try java/lang/Object)) - -(import: #long (java/lang/Class a) - (getDeclaredMethod [java/lang/String (Array (java/lang/Class java/lang/Object))] - #try java/lang/reflect/Method)) - -(import: #long java/lang/Integer - (#static TYPE (java/lang/Class java/lang/Integer))) - -(import: #long java/lang/reflect/AccessibleObject - (setAccessible [boolean] void)) - -(import: #long java/lang/ClassLoader - (loadClass [java/lang/String] - #io #try (java/lang/Class java/lang/Object))) - -(def: java/lang/ClassLoader::defineClass - java/lang/reflect/Method - (let [signature (|> (host.array (java/lang/Class java/lang/Object) 4) - (host.array-write 0 (:coerce (java/lang/Class java/lang/Object) - (host.class-for java/lang/String))) - (host.array-write 1 (java/lang/Object::getClass (host.array byte 0))) - (host.array-write 2 (:coerce (java/lang/Class java/lang/Object) - (java/lang/Integer::TYPE))) - (host.array-write 3 (:coerce (java/lang/Class java/lang/Object) - (java/lang/Integer::TYPE))))] - (do-to (error.assume - (java/lang/Class::getDeclaredMethod "defineClass" - signature - (host.class-for java/lang/ClassLoader))) - (java/lang/reflect/AccessibleObject::setAccessible true)))) - -(def: #export (define class-name bytecode loader) - (-> Text Binary java/lang/ClassLoader (Error java/lang/Object)) - (let [signature (array.from-list (list (:coerce java/lang/Object - class-name) - (:coerce java/lang/Object - bytecode) - (:coerce java/lang/Object - (host.long-to-int +0)) - (:coerce java/lang/Object - (host.long-to-int (.int (binary.size bytecode))))))] - (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) - -(def: #export (new-library _) - (-> Any Library) - (atom.atom (dictionary.new text.hash))) - -(def: #export (memory library) - (-> Library java/lang/ClassLoader) - (object [] java/lang/ClassLoader [] - [] - (java/lang/ClassLoader (findClass {class-name java/lang/String}) java/lang/Class - (let [classes (|> library atom.read io.run)] - (case (dictionary.get class-name classes) - (#.Some bytecode) - (case (|> _jvm_this - (..define class-name bytecode)) - (#error.Success class) - (:assume class) - - (#error.Failure error) - (error! (ex.construct ..cannot-define [class-name error]))) - - #.None - (error! (ex.construct ..unknown [class-name (dictionary.keys classes)]))))))) - -(def: #export (store name bytecode library) - (-> Text Binary Library (IO (Error Any))) - (do io.monad - [library' (atom.read library)] - (if (dictionary.contains? name library') - (wrap (ex.throw ..already-stored name)) - (do @ - [_ (atom.update (dictionary.put name bytecode) library)] - (wrap (#error.Success [])))))) - -(def: #export (load name loader) - (-> Text java/lang/ClassLoader - (IO (Error (java/lang/Class java/lang/Object)))) - (java/lang/ClassLoader::loadClass name loader)) -- cgit v1.2.3