From 9eaaaf953ba7ce1eeb805603f4e113aa15f5178f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 8 Jan 2018 21:40:06 -0400 Subject: - Moved all translation code under the JVM path (in preparation for porting the JS back-end). --- .../luxc/lang/translation/jvm/statement.jvm.lux | 159 +++++++++++++++++++++ 1 file changed, 159 insertions(+) create mode 100644 new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux (limited to 'new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux') diff --git a/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux new file mode 100644 index 000000000..1b828535f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux @@ -0,0 +1,159 @@ +(.module: + lux + (lux (control monad + ["ex" exception #+ exception:]) + (data ["e" error] + [maybe] + [text "text/" Monoid Hash] + text/format + (coll [list "list/" Functor Fold])) + [macro] + [host]) + (luxc ["&" lang] + ["&." io] + (lang (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["&." scope] + ["&." module] + [".L" host])) + (// [".T" eval] + [".T" common] + [".T" runtime])) + +(exception: #export Invalid-Definition-Value) +(exception: #export Cannot-Evaluate-Definition) + +(host.import java/lang/reflect/Field + (get [#? Object] #try #? Object)) + +(host.import (java/lang/Class c) + (getField [String] #try Field)) + +(def: #export (translate-def def-name valueT valueI metaI metaV) + (-> Text Type $.Inst $.Inst Code (Meta Unit)) + (do macro.Monad + [current-module macro.current-module-name + #let [def-ident [current-module def-name]]] + (case (macro.get-symbol-ann (ident-for #.alias) metaV) + (#.Some real-def) + (do @ + [[realT realA realV] (macro.find-def real-def) + _ (&module.define def-ident [realT metaV realV])] + (wrap [])) + + _ + (do @ + [#let [normal-name (format (&.normalize-name def-name) (%n (text/hash def-name))) + bytecode-name (format current-module "/" normal-name) + class-name (format (text.replace-all "/" "." current-module) "." normal-name) + bytecode ($d.class #$.V1_6 + #$.Public $.finalC + bytecode-name + (list) ["java.lang.Object" (list)] + (list) + (|>> ($d.field #$.Public ($.++F $.finalF $.staticF) commonT.value-field commonT.$Object) + ($d.method #$.Public $.staticM "" ($t.method (list) #.None (list)) + (|>> valueI + ($i.PUTSTATIC bytecode-name commonT.value-field commonT.$Object) + $i.RETURN))))] + _ (commonT.store-class class-name bytecode) + class (commonT.load-class class-name) + valueV (: (Meta Top) + (case (do e.Monad + [field (Class::getField [commonT.value-field] class)] + (Field::get [#.None] field)) + (#e.Success #.None) + (&.throw Invalid-Definition-Value (%ident def-ident)) + + (#e.Success (#.Some valueV)) + (wrap valueV) + + (#e.Error error) + (&.throw Cannot-Evaluate-Definition + (format "Definition: " (%ident def-ident) "\n" + "Error:\n" + error)))) + _ (&module.define def-ident [valueT metaV valueV]) + _ (if (macro.type? metaV) + (case (macro.declared-tags metaV) + #.Nil + (wrap []) + + tags + (&module.declare-tags tags (macro.export? metaV) (:! Type valueV))) + (wrap [])) + #let [_ (log! (format "DEF " (%ident def-ident)))]] + (commonT.record-artifact (format bytecode-name ".class") bytecode))))) + +(def: #export (translate-program programI) + (-> $.Inst (Meta Unit)) + (let [nilI runtimeT.noneI + num-inputsI (|>> ($i.ALOAD +0) $i.ARRAYLENGTH) + decI (|>> ($i.int 1) $i.ISUB) + headI (|>> $i.DUP + ($i.ALOAD +0) + $i.SWAP + $i.AALOAD + $i.SWAP + $i.DUP_X2 + $i.POP) + pairI (|>> ($i.int 2) + ($i.ANEWARRAY "java.lang.Object") + $i.DUP_X1 + $i.SWAP + ($i.int 0) + $i.SWAP + $i.AASTORE + $i.DUP_X1 + $i.SWAP + ($i.int 1) + $i.SWAP + $i.AASTORE) + consI (|>> ($i.int 1) + ($i.string "") + $i.DUP2_X1 + $i.POP2 + runtimeT.variantI) + prepare-input-listI (<| $i.with-label (function [@loop]) + $i.with-label (function [@end]) + (|>> nilI + num-inputsI + ($i.label @loop) + decI + $i.DUP + ($i.IFLT @end) + headI + pairI + consI + $i.SWAP + ($i.GOTO @loop) + ($i.label @end) + $i.POP + ($i.ASTORE +0))) + run-ioI (|>> ($i.CHECKCAST hostL.function-class) + $i.NULL + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature +1) false)) + main-type ($t.method (list ($t.array +1 ($t.class "java.lang.String" (list)))) + #.None + (list))] + (do macro.Monad + [current-module macro.current-module-name + #let [normal-name "_" + bytecode-name (format current-module "/" normal-name) + class-name (text.replace-all "/" "." bytecode-name) + bytecode ($d.class #$.V1_6 + #$.Public $.finalC + bytecode-name + (list) ["java.lang.Object" (list)] + (list) + (|>> ($d.method #$.Public $.staticM "main" main-type + (|>> prepare-input-listI + programI + run-ioI + $i.POP + $i.RETURN))))] + #let [_ (log! (format "PROGRAM " current-module))] + _ (commonT.store-class class-name bytecode)] + (commonT.record-artifact (format bytecode-name ".class") bytecode)))) -- cgit v1.2.3