From f0a95ee657fef968df1f5f88dc741256e1153e63 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 17 Sep 2019 21:51:05 -0400 Subject: Some refactoring. --- .../source/luxc/lang/translation/jvm/extension.lux | 16 + .../luxc/lang/translation/jvm/extension/common.lux | 385 ++++++++ .../luxc/lang/translation/jvm/extension/host.lux | 1038 ++++++++++++++++++++ .../luxc/lang/translation/jvm/procedure/common.lux | 385 -------- .../luxc/lang/translation/jvm/procedure/host.lux | 1038 -------------------- 5 files changed, 1439 insertions(+), 1423 deletions(-) create mode 100644 new-luxc/source/luxc/lang/translation/jvm/extension.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/extension/common.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/extension/host.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux delete mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux (limited to 'new-luxc/source/luxc/lang') diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension.lux b/new-luxc/source/luxc/lang/translation/jvm/extension.lux new file mode 100644 index 000000000..9066dd156 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/extension.lux @@ -0,0 +1,16 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [//// + [host + [jvm (#+ Bundle)]]] + ["." / #_ + ["#." common] + ["#." host]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux new file mode 100644 index 000000000..a46813232 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux @@ -0,0 +1,385 @@ +(.module: + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["" synthesis (#+ Parser)]] + ["ex" exception (#+ exception:)]] + [data + ["." product] + [number + ["f" frac]] + [collection + ["." list ("#@." monad)] + ["." dictionary]]] + [target + [jvm + ["." type + ["." signature]]]] + [tool + [compiler + ["." synthesis (#+ 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 Def Handler Bundle Operation Phase) + ["_" inst]]]]] + ["." /// + ["." runtime]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation Inst))] + Handler)) + (function (_ extension-name phase input) + (case (.run input parser) + (#try.Success input') + (handler extension-name phase input') + + (#try.Failure error) + (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) + +(import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(def: $String (type.class "java.lang.String" (list))) +(def: $CharSequence (type.class "java.lang.CharSequence" (list))) +(def: $System (type.class "java.lang.System" (list))) +(def: $Object (type.class "java.lang.Object" (list))) + +(def: lux-intI Inst (|>> _.I2L (_.wrap type.long))) +(def: jvm-intI Inst (|>> (_.unwrap type.long) _.L2I)) +(def: check-stringI Inst (_.CHECKCAST $String)) + +(def: (predicateI tester) + (-> (-> Label Inst) + Inst) + (let [$Boolean (type.class "java.lang.Boolean" (list))] + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> (tester @then) + (_.GETSTATIC $Boolean "FALSE" $Boolean) + (_.GOTO @end) + (_.label @then) + (_.GETSTATIC $Boolean "TRUE" $Boolean) + (_.label @end) + )))) + +(def: unitI Inst (_.string synthesis.unit)) + +## TODO: Get rid of this ASAP +(def: lux::syntax-char-case! + (..custom [($_ <>.and + .any + .any + (<>.some (.tuple ($_ <>.and + (.tuple (<>.many .i64)) + .any)))) + (function (_ extension-name phase [input else conditionals]) + (<| _.with-label (function (_ @end)) + _.with-label (function (_ @else)) + (do phase.monad + [inputG (phase input) + elseG (phase else) + conditionalsG+ (: (Operation (List [(List [Int Label]) + Inst])) + (monad.map @ (function (_ [chars branch]) + (do @ + [branchG (phase branch)] + (wrap (<| _.with-label (function (_ @branch)) + [(list@map (function (_ char) + [(.int char) @branch]) + chars) + (|>> (_.label @branch) + branchG + (_.GOTO @end))])))) + conditionals)) + #let [table (|> conditionalsG+ + (list@map product.left) + list@join) + conditionalsG (|> conditionalsG+ + (list@map product.right) + _.fuse)]] + (wrap (|>> inputG (_.unwrap type.long) _.L2I + (_.LOOKUPSWITCH @else table) + conditionalsG + (_.label @else) + elseG + (_.label @end) + )))))])) + +(def: (lux::is [referenceI sampleI]) + (Binary Inst) + (|>> referenceI + sampleI + (predicateI _.IF_ACMPEQ))) + +(def: (lux::try riskyI) + (Unary Inst) + (|>> riskyI + (_.CHECKCAST ///.$Function) + (_.INVOKESTATIC ///.$Runtime "try" runtime.try))) + +(template [ ] + [(def: ( [maskI inputI]) + (Binary Inst) + (|>> inputI (_.unwrap type.long) + maskI (_.unwrap type.long) + (_.wrap type.long)))] + + [i64::and _.LAND] + [i64::or _.LOR] + [i64::xor _.LXOR] + ) + +(template [ ] + [(def: ( [shiftI inputI]) + (Binary Inst) + (|>> inputI (_.unwrap type.long) + shiftI jvm-intI + + (_.wrap type.long)))] + + [i64::left-shift _.LSHL] + [i64::arithmetic-right-shift _.LSHR] + [i64::logical-right-shift _.LUSHR] + ) + +(template [ ] + [(def: ( _) + (Nullary Inst) + (|>> (_.wrap )))] + + [f64::smallest (_.double (Double::MIN_VALUE)) type.double] + [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) type.double] + [f64::max (_.double (Double::MAX_VALUE)) type.double] + ) + +(template [ ] + [(def: ( [paramI subjectI]) + (Binary Inst) + (|>> subjectI (_.unwrap ) + paramI (_.unwrap ) + + (_.wrap )))] + + [i64::+ type.long _.LADD] + [i64::- type.long _.LSUB] + [i64::* type.long _.LMUL] + [i64::/ type.long _.LDIV] + [i64::% type.long _.LREM] + + [f64::+ type.double _.DADD] + [f64::- type.double _.DSUB] + [f64::* type.double _.DMUL] + [f64::/ type.double _.DDIV] + [f64::% type.double _.DREM] + ) + +(template [ ] + [(template [ ] + [(def: ( [paramI subjectI]) + (Binary Inst) + (|>> subjectI (_.unwrap ) + paramI (_.unwrap ) + + (_.int ) + (predicateI _.IF_ICMPEQ)))] + + [ +0] + [ -1])] + + [i64::= i64::< type.long _.LCMP] + [f64::= f64::< type.double _.DCMPG] + ) + +(template [ ] + [(def: ( inputI) + (Unary Inst) + (|>> inputI ))] + + [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)] + [i64::char (_.unwrap type.long) + ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list type.char) $String (list)]))))] + + [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)] + [f64::encode (_.unwrap type.double) + (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list type.double) $String (list)]))] + [f64::decode ..check-stringI + (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]))] + ) + +(def: (text::size inputI) + (Unary Inst) + (|>> inputI + ..check-stringI + (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)])) + lux-intI)) + +(template [ ] + [(def: ( [paramI subjectI]) + (Binary Inst) + (|>> subjectI + paramI + ))] + + [text::= (<|) (<|) + (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)])) + (_.wrap type.boolean)] + [text::< ..check-stringI ..check-stringI + (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)])) + (predicateI _.IFLT)] + [text::char ..check-stringI jvm-intI + (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)])) + lux-intI] + ) + +(def: (text::concat [leftI rightI]) + (Binary Inst) + (|>> leftI ..check-stringI + rightI ..check-stringI + (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)])))) + +(def: (text::clip [startI endI subjectI]) + (Trinary Inst) + (|>> subjectI ..check-stringI + startI jvm-intI + endI jvm-intI + (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)])))) + +(def: index-method (type.method [(list $String type.int) type.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 $String "indexOf" index-method) + _.DUP + (_.int -1) + (_.IF_ICMPEQ @not-found) + lux-intI + runtime.someI + (_.GOTO @end) + (_.label @not-found) + _.POP + runtime.noneI + (_.label @end)))) + +(def: string-method (type.method [(list $String) type.void (list)])) +(def: (io::log messageI) + (Unary Inst) + (let [$PrintStream (type.class "java.io.PrintStream" (list))] + (|>> (_.GETSTATIC $System "out" $PrintStream) + messageI + ..check-stringI + (_.INVOKEVIRTUAL $PrintStream "println" string-method) + unitI))) + +(def: (io::error messageI) + (Unary Inst) + (let [$Error (type.class "java.lang.Error" (list))] + (|>> (_.NEW $Error) + _.DUP + messageI + ..check-stringI + (_.INVOKESPECIAL $Error "" string-method) + _.ATHROW))) + +(def: (io::exit codeI) + (Unary Inst) + (|>> codeI jvm-intI + (_.INVOKESTATIC $System "exit" (type.method [(list type.int) type.void (list)])) + _.NULL)) + +(def: (io::current-time _) + (Nullary Inst) + (|>> (_.INVOKESTATIC $System "currentTimeMillis" (type.method [(list) type.long (list)])) + (_.wrap type.long))) + +(def: bundle::lux + Bundle + (|> (: Bundle bundle.empty) + (bundle.install "syntax char case!" lux::syntax-char-case!) + (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 i64::and)) + (bundle.install "or" (binary i64::or)) + (bundle.install "xor" (binary i64::xor)) + (bundle.install "left-shift" (binary i64::left-shift)) + (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) + (bundle.install "=" (binary i64::=)) + (bundle.install "<" (binary i64::<)) + (bundle.install "+" (binary i64::+)) + (bundle.install "-" (binary i64::-)) + (bundle.install "*" (binary i64::*)) + (bundle.install "/" (binary i64::/)) + (bundle.install "%" (binary i64::%)) + (bundle.install "f64" (unary i64::f64)) + (bundle.install "char" (unary i64::char))))) + +(def: bundle::f64 + Bundle + (<| (bundle.prefix "f64") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary f64::+)) + (bundle.install "-" (binary f64::-)) + (bundle.install "*" (binary f64::*)) + (bundle.install "/" (binary f64::/)) + (bundle.install "%" (binary f64::%)) + (bundle.install "=" (binary f64::=)) + (bundle.install "<" (binary f64::<)) + (bundle.install "smallest" (nullary f64::smallest)) + (bundle.install "min" (nullary f64::min)) + (bundle.install "max" (nullary f64::max)) + (bundle.install "i64" (unary f64::i64)) + (bundle.install "encode" (unary f64::encode)) + (bundle.install "decode" (unary f64::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::f64) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux new file mode 100644 index 000000000..ca6e31bfd --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux @@ -0,0 +1,1038 @@ +(.module: + [lux (#- Type primitive int char type) + [abstract + ["." monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["." function] + ["<>" parser ("#@." monad) + ["" text] + ["" synthesis (#+ Parser)]]] + [data + ["." product] + ["." maybe] + [number + ["." nat]] + ["." text ("#@." equivalence)] + [collection + ["." list ("#@." monad)] + ["." dictionary (#+ Dictionary)] + ["." set]]] + [target + [jvm + ["." type (#+ Type Typed Argument) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." box] + ["." reflection] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)] + ["." parser]]]] + [tool + [compiler + [analysis (#+ Environment)] + ["." reference (#+ Variable)] + ["." synthesis (#+ Synthesis Path %synthesis)] + ["." phase ("#@." monad) + ["." generation + [extension (#+ Nullary Unary Binary + nullary unary binary)]] + [analysis + [".A" reference]] + ["." extension + ["." bundle] + [analysis + ["/" jvm]]]]]] + [host (#+ import:)]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) + ["_" inst] + ["_." def]]]]] + ["." // #_ + [common (#+ custom)] + ["/#" // #_ + ["#." reference] + ["#." function]]]) + +(template [ ] + [(def: #export + (Parser (Type )) + (.embed .text))] + + [var Var parser.var] + [class Class parser.class] + [object Object parser.object] + [value Value parser.value] + [return Return parser.return] + ) + +(exception: #export (not-an-object-array {arrayJT (Type Array)}) + (exception.report + ["JVM Type" (|> arrayJT type.signature signature.signature)])) + +(def: #export object-array + (Parser (Type Object)) + (do <>.monad + [arrayJT (.embed parser.array .text)] + (case (parser.array? arrayJT) + (#.Some elementJT) + (case (parser.object? elementJT) + (#.Some elementJT) + (wrap elementJT) + + #.None + (<>.fail (exception.construct ..not-an-object-array arrayJT))) + + #.None + (undefined)))) + +(template [ ] + [(def: + Inst + )] + + [L2S (|>> _.L2I _.I2S)] + [L2B (|>> _.L2I _.I2B)] + [L2C (|>> _.L2I _.I2C)] + ) + +(template [ ] + [(def: ( inputI) + (Unary Inst) + (if (is? _.NOP ) + inputI + (|>> inputI + )))] + + [_.D2F conversion::double-to-float] + [_.D2I conversion::double-to-int] + [_.D2L conversion::double-to-long] + [_.F2D conversion::float-to-double] + [_.F2I conversion::float-to-int] + [_.F2L conversion::float-to-long] + [_.I2B conversion::int-to-byte] + [_.I2C conversion::int-to-char] + [_.I2D conversion::int-to-double] + [_.I2F conversion::int-to-float] + [_.I2L conversion::int-to-long] + [_.I2S conversion::int-to-short] + [_.L2D conversion::long-to-double] + [_.L2F conversion::long-to-float] + [_.L2I conversion::long-to-int] + [..L2S conversion::long-to-short] + [..L2B conversion::long-to-byte] + [..L2C conversion::long-to-char] + [_.I2B conversion::char-to-byte] + [_.I2S conversion::char-to-short] + [_.NOP conversion::char-to-int] + [_.I2L conversion::char-to-long] + [_.I2L conversion::byte-to-long] + [_.I2L conversion::short-to-long] + ) + +(def: conversion + Bundle + (<| (bundle.prefix "conversion") + (|> (: Bundle bundle.empty) + (bundle.install "double-to-float" (unary conversion::double-to-float)) + (bundle.install "double-to-int" (unary conversion::double-to-int)) + (bundle.install "double-to-long" (unary conversion::double-to-long)) + (bundle.install "float-to-double" (unary conversion::float-to-double)) + (bundle.install "float-to-int" (unary conversion::float-to-int)) + (bundle.install "float-to-long" (unary conversion::float-to-long)) + (bundle.install "int-to-byte" (unary conversion::int-to-byte)) + (bundle.install "int-to-char" (unary conversion::int-to-char)) + (bundle.install "int-to-double" (unary conversion::int-to-double)) + (bundle.install "int-to-float" (unary conversion::int-to-float)) + (bundle.install "int-to-long" (unary conversion::int-to-long)) + (bundle.install "int-to-short" (unary conversion::int-to-short)) + (bundle.install "long-to-double" (unary conversion::long-to-double)) + (bundle.install "long-to-float" (unary conversion::long-to-float)) + (bundle.install "long-to-int" (unary conversion::long-to-int)) + (bundle.install "long-to-short" (unary conversion::long-to-short)) + (bundle.install "long-to-byte" (unary conversion::long-to-byte)) + (bundle.install "long-to-char" (unary conversion::long-to-char)) + (bundle.install "char-to-byte" (unary conversion::char-to-byte)) + (bundle.install "char-to-short" (unary conversion::char-to-short)) + (bundle.install "char-to-int" (unary conversion::char-to-int)) + (bundle.install "char-to-long" (unary conversion::char-to-long)) + (bundle.install "byte-to-long" (unary conversion::byte-to-long)) + (bundle.install "short-to-long" (unary conversion::short-to-long)) + ))) + +(template [ ] + [(def: ( [xI yI]) + (Binary Inst) + (|>> xI + yI + ))] + + [int::+ _.IADD] + [int::- _.ISUB] + [int::* _.IMUL] + [int::/ _.IDIV] + [int::% _.IREM] + [int::and _.IAND] + [int::or _.IOR] + [int::xor _.IXOR] + [int::shl _.ISHL] + [int::shr _.ISHR] + [int::ushr _.IUSHR] + + [long::+ _.LADD] + [long::- _.LSUB] + [long::* _.LMUL] + [long::/ _.LDIV] + [long::% _.LREM] + [long::and _.LAND] + [long::or _.LOR] + [long::xor _.LXOR] + [long::shl _.LSHL] + [long::shr _.LSHR] + [long::ushr _.LUSHR] + + [float::+ _.FADD] + [float::- _.FSUB] + [float::* _.FMUL] + [float::/ _.FDIV] + [float::% _.FREM] + + [double::+ _.DADD] + [double::- _.DSUB] + [double::* _.DMUL] + [double::/ _.DDIV] + [double::% _.DREM] + ) + +(def: $Boolean (type.class box.boolean (list))) +(def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean)) +(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean)) + +(template [ ] + [(def: ( [xI yI]) + (Binary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> xI + yI + ( @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end))))] + + [int::= _.IF_ICMPEQ] + [int::< _.IF_ICMPLT] + + [char::= _.IF_ICMPEQ] + [char::< _.IF_ICMPLT] + ) + +(template [ ] + [(def: ( [xI yI]) + (Binary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> xI + yI + + (_.int ) + (_.IF_ICMPEQ @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end))))] + + [long::= _.LCMP +0] + [long::< _.LCMP -1] + + [float::= _.FCMPG +0] + [float::< _.FCMPG -1] + + [double::= _.DCMPG +0] + [double::< _.DCMPG -1] + ) + +(def: int + Bundle + (<| (bundle.prefix (reflection.reflection reflection.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 (reflection.reflection reflection.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 (reflection.reflection reflection.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 (reflection.reflection reflection.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 (reflection.reflection reflection.char)) + (|> (: Bundle bundle.empty) + (bundle.install "=" (binary char::=)) + (bundle.install "<" (binary char::<)) + ))) + +(def: (primitive-array-length-handler jvm-primitive) + (-> (Type Primitive) Handler) + (..custom + [.any + (function (_ extension-name generate arrayS) + (do phase.monad + [arrayI (generate arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array jvm-primitive)) + _.ARRAYLENGTH))))])) + +(def: array::length::object + Handler + (..custom + [($_ <>.and ..object-array .any) + (function (_ extension-name generate [elementJT arrayS]) + (do phase.monad + [arrayI (generate arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array elementJT)) + _.ARRAYLENGTH))))])) + +(def: (new-primitive-array-handler jvm-primitive) + (-> (Type Primitive) Handler) + (function (_ extension-name generate inputs) + (case inputs + (^ (list lengthS)) + (do phase.monad + [lengthI (generate lengthS)] + (wrap (|>> lengthI + (_.array jvm-primitive)))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) + +(def: array::new::object + Handler + (..custom + [($_ <>.and ..object .any) + (function (_ extension-name generate [objectJT lengthS]) + (do phase.monad + [lengthI (generate lengthS)] + (wrap (|>> lengthI + (_.ANEWARRAY objectJT)))))])) + +(def: (read-primitive-array-handler jvm-primitive loadI) + (-> (Type Primitive) Inst Handler) + (function (_ extension-name generate inputs) + (case inputs + (^ (list idxS arrayS)) + (do phase.monad + [arrayI (generate arrayS) + idxI (generate idxS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array jvm-primitive)) + idxI + loadI))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) + +(def: array::read::object + Handler + (..custom + [($_ <>.and ..object-array .any .any) + (function (_ extension-name generate [elementJT idxS arrayS]) + (do phase.monad + [arrayI (generate arrayS) + idxI (generate idxS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array elementJT)) + idxI + _.AALOAD))))])) + +(def: (write-primitive-array-handler jvm-primitive storeI) + (-> (Type Primitive) Inst Handler) + (function (_ extension-name generate inputs) + (case inputs + (^ (list idxS valueS arrayS)) + (do phase.monad + [arrayI (generate arrayS) + idxI (generate idxS) + valueI (generate valueS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array jvm-primitive)) + _.DUP + idxI + valueI + storeI))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) + +(def: array::write::object + Handler + (..custom + [($_ <>.and ..object-array .any .any .any) + (function (_ extension-name generate [elementJT idxS valueS arrayS]) + (do phase.monad + [arrayI (generate arrayS) + idxI (generate idxS) + valueI (generate valueS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array elementJT)) + _.DUP + idxI + valueI + _.AASTORE))))])) + +(def: array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (dictionary.merge (<| (bundle.prefix "length") + (|> bundle.empty + (bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) + (bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) + (bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) + (bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) + (bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) + (bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) + (bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) + (bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) + (bundle.install "object" array::length::object)))) + (dictionary.merge (<| (bundle.prefix "new") + (|> bundle.empty + (bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler type.boolean)) + (bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler type.byte)) + (bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler type.short)) + (bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler type.int)) + (bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler type.long)) + (bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler type.float)) + (bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler type.double)) + (bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler type.char)) + (bundle.install "object" array::new::object)))) + (dictionary.merge (<| (bundle.prefix "read") + (|> bundle.empty + (bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.BALOAD)) + (bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.BALOAD)) + (bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.SALOAD)) + (bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.IALOAD)) + (bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.LALOAD)) + (bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.FALOAD)) + (bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.DALOAD)) + (bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.CALOAD)) + (bundle.install "object" array::read::object)))) + (dictionary.merge (<| (bundle.prefix "write") + (|> bundle.empty + (bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.BASTORE)) + (bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.BASTORE)) + (bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.SASTORE)) + (bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.IASTORE)) + (bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.LASTORE)) + (bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.FASTORE)) + (bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.DASTORE)) + (bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.CASTORE)) + (bundle.install "object" array::write::object)))) + ))) + +(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: $Class (type.class "java.lang.Class" (list))) + +(def: (object::class extension-name generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class))) + (do phase.monad + [] + (wrap (|>> (_.string class) + (_.INVOKESTATIC $Class "forName" (type.method [(list (type.class "java.lang.String" (list))) $Class (list)]))))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + +(def: object::instance? + Handler + (..custom + [($_ <>.and .text .any) + (function (_ extension-name generate [class objectS]) + (do phase.monad + [objectI (generate objectS)] + (wrap (|>> objectI + (_.INSTANCEOF (type.class class (list))) + (_.wrap type.boolean)))))])) + +(def: (object::cast extension-name generate inputs) + Handler + (case inputs + (^ (list (synthesis.text from) (synthesis.text to) valueS)) + (do phase.monad + [valueI (generate valueS)] + (`` (cond (~~ (template [ ] + [(and (text@= (reflection.reflection (type.reflection )) + from) + (text@= + to)) + (wrap (|>> valueI (_.wrap ))) + + (and (text@= + from) + (text@= (reflection.reflection (type.reflection )) + to)) + (wrap (|>> valueI (_.unwrap )))] + + [box.boolean type.boolean] + [box.byte type.byte] + [box.short type.short] + [box.int type.int] + [box.long type.long] + [box.float type.float] + [box.double type.double] + [box.char type.char])) + ## else + (wrap valueI)))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + +(def: object-bundle + 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 (Type Primitive)) + (|> (list [(reflection.reflection reflection.boolean) type.boolean] + [(reflection.reflection reflection.byte) type.byte] + [(reflection.reflection reflection.short) type.short] + [(reflection.reflection reflection.int) type.int] + [(reflection.reflection reflection.long) type.long] + [(reflection.reflection reflection.float) type.float] + [(reflection.reflection reflection.double) type.double] + [(reflection.reflection reflection.char) type.char]) + (dictionary.from-list text.hash))) + +(def: get::static + Handler + (..custom + [($_ <>.and .text .text .text) + (function (_ extension-name generate [class field unboxed]) + (do phase.monad + [] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (_.GETSTATIC (type.class class (list)) field primitive)) + + #.None + (wrap (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))])) + +(def: put::static + Handler + (..custom + [($_ <>.and .text .text .text .any) + (function (_ extension-name generate [class field unboxed valueS]) + (do phase.monad + [valueI (generate valueS) + #let [$class (type.class class (list))]] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (|>> valueI + (_.PUTSTATIC $class field primitive) + (_.string synthesis.unit))) + + #.None + (wrap (|>> valueI + (_.CHECKCAST $class) + (_.PUTSTATIC $class field $class) + (_.string synthesis.unit))))))])) + +(def: get::virtual + Handler + (..custom + [($_ <>.and .text .text .text .any) + (function (_ extension-name generate [class field unboxed objectS]) + (do phase.monad + [objectI (generate objectS) + #let [$class (type.class class (list)) + getI (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.GETFIELD $class field primitive) + + #.None + (_.GETFIELD $class field (type.class unboxed (list))))]] + (wrap (|>> objectI + (_.CHECKCAST $class) + getI))))])) + +(def: put::virtual + Handler + (..custom + [($_ <>.and .text .text .text .any .any) + (function (_ extension-name generate [class field unboxed valueS objectS]) + (do phase.monad + [valueI (generate valueS) + objectI (generate objectS) + #let [$class (type.class class (list)) + putI (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.PUTFIELD $class field primitive) + + #.None + (let [$unboxed (type.class unboxed (list))] + (|>> (_.CHECKCAST $unboxed) + (_.PUTFIELD $class field $unboxed))))]] + (wrap (|>> objectI + (_.CHECKCAST $class) + _.DUP + valueI + putI))))])) + +(type: Input (Typed Synthesis)) + +(def: input + (Parser Input) + (.tuple (<>.and ..value .any))) + +(def: (generate-input generate [valueT valueS]) + (-> (-> Synthesis (Operation Inst)) Input + (Operation (Typed Inst))) + (do phase.monad + [valueI (generate valueS)] + (case (type.primitive? valueT) + (#.Right valueT) + (wrap [valueT valueI]) + + (#.Left valueT) + (wrap [valueT (|>> valueI + (_.CHECKCAST valueT))])))) + +(def: voidI (_.string synthesis.unit)) + +(def: (prepare-output outputT) + (-> (Type Return) Inst) + (case (type.void? outputT) + (#.Right outputT) + ..voidI + + (#.Left outputT) + function.identity)) + +(def: invoke::static + Handler + (..custom + [($_ <>.and ..class .text ..return (<>.some ..input)) + (function (_ extension-name generate [class method outputT inputsTS]) + (do phase.monad + [inputsTI (monad.map @ (generate-input generate) inputsTS)] + (wrap (|>> (_.fuse (list@map product.right inputsTI)) + (_.INVOKESTATIC class method (type.method [(list@map product.left inputsTI) outputT (list)])) + (prepare-output outputT)))))])) + +(template [ ] + [(def: + Handler + (..custom + [($_ <>.and ..class .text ..return .any (<>.some ..input)) + (function (_ extension-name generate [class method outputT objectS inputsTS]) + (do phase.monad + [objectI (generate objectS) + inputsTI (monad.map @ (generate-input generate) inputsTS)] + (wrap (|>> objectI + (_.CHECKCAST class) + (_.fuse (list@map product.right inputsTI)) + ( class method + (type.method [(list@map product.left inputsTI) + outputT + (list)])) + (prepare-output outputT)))))]))] + + [invoke::virtual _.INVOKEVIRTUAL] + [invoke::special _.INVOKESPECIAL] + [invoke::interface _.INVOKEINTERFACE] + ) + +(def: invoke::constructor + Handler + (..custom + [($_ <>.and ..class (<>.some ..input)) + (function (_ extension-name generate [class inputsTS]) + (do phase.monad + [inputsTI (monad.map @ (generate-input generate) inputsTS)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse (list@map product.right inputsTI)) + (_.INVOKESPECIAL class "" (type.method [(list@map product.left inputsTI) type.void (list)]))))))])) + +(def: member + Bundle + (<| (bundle.prefix "member") + (|> (: Bundle bundle.empty) + (dictionary.merge (<| (bundle.prefix "get") + (|> (: Bundle bundle.empty) + (bundle.install "static" get::static) + (bundle.install "virtual" get::virtual)))) + (dictionary.merge (<| (bundle.prefix "put") + (|> (: Bundle bundle.empty) + (bundle.install "static" put::static) + (bundle.install "virtual" put::virtual)))) + (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: annotation-parameter + (Parser (/.Annotation-Parameter Synthesis)) + (.tuple (<>.and .text .any))) + +(def: annotation + (Parser (/.Annotation Synthesis)) + (.tuple (<>.and .text (<>.some ..annotation-parameter)))) + +(def: argument + (Parser Argument) + (.tuple (<>.and .text ..value))) + +(def: overriden-method-definition + (Parser [Environment (/.Overriden-Method Synthesis)]) + (.tuple (do <>.monad + [_ (.text! /.overriden-tag) + ownerT ..class + name .text + strict-fp? .bit + annotations (.tuple (<>.some ..annotation)) + vars (.tuple (<>.some ..var)) + self-name .text + arguments (.tuple (<>.some ..argument)) + returnT ..return + exceptionsT (.tuple (<>.some ..class)) + [environment body] (.function 1 + (.tuple .any))] + (wrap [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]])))) + +(def: (normalize-path normalize) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (recur path) + (case path + (^ (synthesis.path/then bodyS)) + (synthesis.path/then (normalize bodyS)) + + (^template [] + (^ ( leftP rightP)) + ( (recur leftP) (recur rightP))) + ([#synthesis.Alt] + [#synthesis.Seq]) + + (^template [] + (^ ( value)) + path) + ([#synthesis.Pop] + [#synthesis.Test] + [#synthesis.Bind] + [#synthesis.Access])))) + +(def: (normalize-method-body mapping) + (-> (Dictionary Variable Variable) Synthesis Synthesis) + (function (recur body) + (case body + (^template [] + (^ ( value)) + body) + ([#synthesis.Primitive] + [synthesis.constant]) + + (^ (synthesis.variant [lefts right? sub])) + (synthesis.variant [lefts right? (recur sub)]) + + (^ (synthesis.tuple members)) + (synthesis.tuple (list@map recur members)) + + (^ (synthesis.variable var)) + (|> mapping + (dictionary.get var) + (maybe.default var) + synthesis.variable) + + (^ (synthesis.branch/case [inputS pathS])) + (synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) + + (^ (synthesis.branch/let [inputS register outputS])) + (synthesis.branch/let [(recur inputS) register (recur outputS)]) + + (^ (synthesis.branch/if [testS thenS elseS])) + (synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) + + (^ (synthesis.loop/scope [offset initsS+ bodyS])) + (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) + + (^ (synthesis.loop/recur updatesS+)) + (synthesis.loop/recur (list@map recur updatesS+)) + + (^ (synthesis.function/abstraction [environment arity bodyS])) + (synthesis.function/abstraction [(|> environment (list@map (function (_ local) + (|> mapping + (dictionary.get local) + (maybe.default local))))) + arity + bodyS]) + + (^ (synthesis.function/apply [functionS inputsS+])) + (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) + + (#synthesis.Extension [name inputsS+]) + (#synthesis.Extension [name (list@map recur inputsS+)])))) + +(def: $Object (type.class "java.lang.Object" (list))) + +(def: (anonymous-init-method env) + (-> Environment [(Signature Method) (Descriptor Method)]) + (type.method [(list.repeat (list.size env) $Object) + type.void + (list)])) + +(def: (with-anonymous-init class env super-class inputsTI) + (-> (Type Class) Environment (Type Class) (List (Typed Inst)) Def) + (let [store-capturedI (|> env + list.size + list.indices + (list@map (.function (_ register) + (|>> (_.ALOAD 0) + (_.ALOAD (inc register)) + (_.PUTFIELD class (///reference.foreign-name register) $Object)))) + _.fuse)] + (_def.method #$.Public $.noneM "" (anonymous-init-method env) + (|>> (_.ALOAD 0) + ((_.fuse (list@map product.right inputsTI))) + (_.INVOKESPECIAL super-class "" (type.method [(list@map product.left inputsTI) type.void (list)])) + store-capturedI + _.RETURN)))) + +(def: (anonymous-instance class env) + (-> (Type Class) Environment (Operation Inst)) + (do phase.monad + [captureI+ (monad.map @ ///reference.variable env)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse captureI+) + (_.INVOKESPECIAL class "" (anonymous-init-method env)))))) + +(def: (returnI returnT) + (-> (Type Return) Inst) + (case (type.void? returnT) + (#.Right returnT) + _.RETURN + + (#.Left returnT) + (case (type.primitive? returnT) + (#.Left returnT) + _.ARETURN + + (#.Right returnT) + (cond (or (:: type.equivalence = type.boolean returnT) + (:: type.equivalence = type.byte returnT) + (:: type.equivalence = type.short returnT) + (:: type.equivalence = type.int returnT) + (:: type.equivalence = type.char returnT)) + _.IRETURN + + (:: type.equivalence = type.long returnT) + _.LRETURN + + (:: type.equivalence = type.float returnT) + _.FRETURN + + ## (:: type.equivalence = type.double returnT) + _.DRETURN)))) + +(def: class::anonymous + Handler + (..custom + [($_ <>.and + .text + ..class + (.tuple (<>.some ..class)) + (.tuple (<>.some ..input)) + (.tuple (<>.some ..overriden-method-definition))) + (function (_ extension-name generate [class-name + super-class super-interfaces + inputsTS + overriden-methods]) + (do phase.monad + [#let [class (type.class class-name (list)) + total-environment (|> overriden-methods + ## Get all the environments. + (list@map product.left) + ## Combine them. + list@join + ## Remove duplicates. + (set.from-list reference.hash) + set.to-list) + global-mapping (|> total-environment + ## Give them names as "foreign" variables. + list.enumerate + (list@map (function (_ [id capture]) + [capture (#reference.Foreign id)])) + (dictionary.from-list reference.hash)) + normalized-methods (list@map (function (_ [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]]) + (let [local-mapping (|> environment + list.enumerate + (list@map (function (_ [foreign-id capture]) + [(#reference.Foreign foreign-id) + (|> global-mapping + (dictionary.get capture) + maybe.assume)])) + (dictionary.from-list reference.hash))] + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + (normalize-method-body local-mapping body)])) + overriden-methods)] + inputsTI (monad.map @ (generate-input generate) inputsTS) + method-definitions (|> normalized-methods + (monad.map @ (function (_ [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + bodyS]) + (do @ + [bodyG (generate bodyS)] + (wrap (_def.method #$.Public + (if strict-fp? + ($_ $.++M $.finalM $.strictM) + $.finalM) + name + (type.method [(list@map product.right arguments) + returnT + exceptionsT]) + (|>> bodyG (returnI returnT))))))) + (:: @ map _def.fuse)) + _ (generation.save! true ["" class-name] + [class-name + (_def.class #$.V1_6 #$.Public $.finalC + class-name (list) + super-class super-interfaces + (|>> (///function.with-environment total-environment) + (..with-anonymous-init class total-environment super-class inputsTI) + method-definitions))])] + (anonymous-instance class total-environment)))])) + +(def: bundle::class + Bundle + (<| (bundle.prefix "class") + (|> (: Bundle bundle.empty) + (bundle.install "anonymous" class::anonymous) + ))) + +(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-bundle) + (dictionary.merge ..member) + (dictionary.merge ..bundle::class) + ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux deleted file mode 100644 index a46813232..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux +++ /dev/null @@ -1,385 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["<>" parser - ["" synthesis (#+ Parser)]] - ["ex" exception (#+ exception:)]] - [data - ["." product] - [number - ["f" frac]] - [collection - ["." list ("#@." monad)] - ["." dictionary]]] - [target - [jvm - ["." type - ["." signature]]]] - [tool - [compiler - ["." synthesis (#+ 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 Def Handler Bundle Operation Phase) - ["_" inst]]]]] - ["." /// - ["." runtime]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase s (Operation Inst))] - Handler)) - (function (_ extension-name phase input) - (case (.run input parser) - (#try.Success input') - (handler extension-name phase input') - - (#try.Failure error) - (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) - -(import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(def: $String (type.class "java.lang.String" (list))) -(def: $CharSequence (type.class "java.lang.CharSequence" (list))) -(def: $System (type.class "java.lang.System" (list))) -(def: $Object (type.class "java.lang.Object" (list))) - -(def: lux-intI Inst (|>> _.I2L (_.wrap type.long))) -(def: jvm-intI Inst (|>> (_.unwrap type.long) _.L2I)) -(def: check-stringI Inst (_.CHECKCAST $String)) - -(def: (predicateI tester) - (-> (-> Label Inst) - Inst) - (let [$Boolean (type.class "java.lang.Boolean" (list))] - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> (tester @then) - (_.GETSTATIC $Boolean "FALSE" $Boolean) - (_.GOTO @end) - (_.label @then) - (_.GETSTATIC $Boolean "TRUE" $Boolean) - (_.label @end) - )))) - -(def: unitI Inst (_.string synthesis.unit)) - -## TODO: Get rid of this ASAP -(def: lux::syntax-char-case! - (..custom [($_ <>.and - .any - .any - (<>.some (.tuple ($_ <>.and - (.tuple (<>.many .i64)) - .any)))) - (function (_ extension-name phase [input else conditionals]) - (<| _.with-label (function (_ @end)) - _.with-label (function (_ @else)) - (do phase.monad - [inputG (phase input) - elseG (phase else) - conditionalsG+ (: (Operation (List [(List [Int Label]) - Inst])) - (monad.map @ (function (_ [chars branch]) - (do @ - [branchG (phase branch)] - (wrap (<| _.with-label (function (_ @branch)) - [(list@map (function (_ char) - [(.int char) @branch]) - chars) - (|>> (_.label @branch) - branchG - (_.GOTO @end))])))) - conditionals)) - #let [table (|> conditionalsG+ - (list@map product.left) - list@join) - conditionalsG (|> conditionalsG+ - (list@map product.right) - _.fuse)]] - (wrap (|>> inputG (_.unwrap type.long) _.L2I - (_.LOOKUPSWITCH @else table) - conditionalsG - (_.label @else) - elseG - (_.label @end) - )))))])) - -(def: (lux::is [referenceI sampleI]) - (Binary Inst) - (|>> referenceI - sampleI - (predicateI _.IF_ACMPEQ))) - -(def: (lux::try riskyI) - (Unary Inst) - (|>> riskyI - (_.CHECKCAST ///.$Function) - (_.INVOKESTATIC ///.$Runtime "try" runtime.try))) - -(template [ ] - [(def: ( [maskI inputI]) - (Binary Inst) - (|>> inputI (_.unwrap type.long) - maskI (_.unwrap type.long) - (_.wrap type.long)))] - - [i64::and _.LAND] - [i64::or _.LOR] - [i64::xor _.LXOR] - ) - -(template [ ] - [(def: ( [shiftI inputI]) - (Binary Inst) - (|>> inputI (_.unwrap type.long) - shiftI jvm-intI - - (_.wrap type.long)))] - - [i64::left-shift _.LSHL] - [i64::arithmetic-right-shift _.LSHR] - [i64::logical-right-shift _.LUSHR] - ) - -(template [ ] - [(def: ( _) - (Nullary Inst) - (|>> (_.wrap )))] - - [f64::smallest (_.double (Double::MIN_VALUE)) type.double] - [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) type.double] - [f64::max (_.double (Double::MAX_VALUE)) type.double] - ) - -(template [ ] - [(def: ( [paramI subjectI]) - (Binary Inst) - (|>> subjectI (_.unwrap ) - paramI (_.unwrap ) - - (_.wrap )))] - - [i64::+ type.long _.LADD] - [i64::- type.long _.LSUB] - [i64::* type.long _.LMUL] - [i64::/ type.long _.LDIV] - [i64::% type.long _.LREM] - - [f64::+ type.double _.DADD] - [f64::- type.double _.DSUB] - [f64::* type.double _.DMUL] - [f64::/ type.double _.DDIV] - [f64::% type.double _.DREM] - ) - -(template [ ] - [(template [ ] - [(def: ( [paramI subjectI]) - (Binary Inst) - (|>> subjectI (_.unwrap ) - paramI (_.unwrap ) - - (_.int ) - (predicateI _.IF_ICMPEQ)))] - - [ +0] - [ -1])] - - [i64::= i64::< type.long _.LCMP] - [f64::= f64::< type.double _.DCMPG] - ) - -(template [ ] - [(def: ( inputI) - (Unary Inst) - (|>> inputI ))] - - [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)] - [i64::char (_.unwrap type.long) - ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list type.char) $String (list)]))))] - - [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)] - [f64::encode (_.unwrap type.double) - (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list type.double) $String (list)]))] - [f64::decode ..check-stringI - (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]))] - ) - -(def: (text::size inputI) - (Unary Inst) - (|>> inputI - ..check-stringI - (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)])) - lux-intI)) - -(template [ ] - [(def: ( [paramI subjectI]) - (Binary Inst) - (|>> subjectI - paramI - ))] - - [text::= (<|) (<|) - (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)])) - (_.wrap type.boolean)] - [text::< ..check-stringI ..check-stringI - (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)])) - (predicateI _.IFLT)] - [text::char ..check-stringI jvm-intI - (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)])) - lux-intI] - ) - -(def: (text::concat [leftI rightI]) - (Binary Inst) - (|>> leftI ..check-stringI - rightI ..check-stringI - (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)])))) - -(def: (text::clip [startI endI subjectI]) - (Trinary Inst) - (|>> subjectI ..check-stringI - startI jvm-intI - endI jvm-intI - (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)])))) - -(def: index-method (type.method [(list $String type.int) type.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 $String "indexOf" index-method) - _.DUP - (_.int -1) - (_.IF_ICMPEQ @not-found) - lux-intI - runtime.someI - (_.GOTO @end) - (_.label @not-found) - _.POP - runtime.noneI - (_.label @end)))) - -(def: string-method (type.method [(list $String) type.void (list)])) -(def: (io::log messageI) - (Unary Inst) - (let [$PrintStream (type.class "java.io.PrintStream" (list))] - (|>> (_.GETSTATIC $System "out" $PrintStream) - messageI - ..check-stringI - (_.INVOKEVIRTUAL $PrintStream "println" string-method) - unitI))) - -(def: (io::error messageI) - (Unary Inst) - (let [$Error (type.class "java.lang.Error" (list))] - (|>> (_.NEW $Error) - _.DUP - messageI - ..check-stringI - (_.INVOKESPECIAL $Error "" string-method) - _.ATHROW))) - -(def: (io::exit codeI) - (Unary Inst) - (|>> codeI jvm-intI - (_.INVOKESTATIC $System "exit" (type.method [(list type.int) type.void (list)])) - _.NULL)) - -(def: (io::current-time _) - (Nullary Inst) - (|>> (_.INVOKESTATIC $System "currentTimeMillis" (type.method [(list) type.long (list)])) - (_.wrap type.long))) - -(def: bundle::lux - Bundle - (|> (: Bundle bundle.empty) - (bundle.install "syntax char case!" lux::syntax-char-case!) - (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 i64::and)) - (bundle.install "or" (binary i64::or)) - (bundle.install "xor" (binary i64::xor)) - (bundle.install "left-shift" (binary i64::left-shift)) - (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) - (bundle.install "=" (binary i64::=)) - (bundle.install "<" (binary i64::<)) - (bundle.install "+" (binary i64::+)) - (bundle.install "-" (binary i64::-)) - (bundle.install "*" (binary i64::*)) - (bundle.install "/" (binary i64::/)) - (bundle.install "%" (binary i64::%)) - (bundle.install "f64" (unary i64::f64)) - (bundle.install "char" (unary i64::char))))) - -(def: bundle::f64 - Bundle - (<| (bundle.prefix "f64") - (|> (: Bundle bundle.empty) - (bundle.install "+" (binary f64::+)) - (bundle.install "-" (binary f64::-)) - (bundle.install "*" (binary f64::*)) - (bundle.install "/" (binary f64::/)) - (bundle.install "%" (binary f64::%)) - (bundle.install "=" (binary f64::=)) - (bundle.install "<" (binary f64::<)) - (bundle.install "smallest" (nullary f64::smallest)) - (bundle.install "min" (nullary f64::min)) - (bundle.install "max" (nullary f64::max)) - (bundle.install "i64" (unary f64::i64)) - (bundle.install "encode" (unary f64::encode)) - (bundle.install "decode" (unary f64::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::f64) - (dictionary.merge bundle::text) - (dictionary.merge bundle::io)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux deleted file mode 100644 index ca6e31bfd..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ /dev/null @@ -1,1038 +0,0 @@ -(.module: - [lux (#- Type primitive int char type) - [abstract - ["." monad (#+ do)]] - [control - ["." exception (#+ exception:)] - ["." function] - ["<>" parser ("#@." monad) - ["" text] - ["" synthesis (#+ Parser)]]] - [data - ["." product] - ["." maybe] - [number - ["." nat]] - ["." text ("#@." equivalence)] - [collection - ["." list ("#@." monad)] - ["." dictionary (#+ Dictionary)] - ["." set]]] - [target - [jvm - ["." type (#+ Type Typed Argument) - ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] - ["." box] - ["." reflection] - ["." descriptor (#+ Descriptor)] - ["." signature (#+ Signature)] - ["." parser]]]] - [tool - [compiler - [analysis (#+ Environment)] - ["." reference (#+ Variable)] - ["." synthesis (#+ Synthesis Path %synthesis)] - ["." phase ("#@." monad) - ["." generation - [extension (#+ Nullary Unary Binary - nullary unary binary)]] - [analysis - [".A" reference]] - ["." extension - ["." bundle] - [analysis - ["/" jvm]]]]]] - [host (#+ import:)]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) - ["_" inst] - ["_." def]]]]] - ["." // #_ - [common (#+ custom)] - ["/#" // #_ - ["#." reference] - ["#." function]]]) - -(template [ ] - [(def: #export - (Parser (Type )) - (.embed .text))] - - [var Var parser.var] - [class Class parser.class] - [object Object parser.object] - [value Value parser.value] - [return Return parser.return] - ) - -(exception: #export (not-an-object-array {arrayJT (Type Array)}) - (exception.report - ["JVM Type" (|> arrayJT type.signature signature.signature)])) - -(def: #export object-array - (Parser (Type Object)) - (do <>.monad - [arrayJT (.embed parser.array .text)] - (case (parser.array? arrayJT) - (#.Some elementJT) - (case (parser.object? elementJT) - (#.Some elementJT) - (wrap elementJT) - - #.None - (<>.fail (exception.construct ..not-an-object-array arrayJT))) - - #.None - (undefined)))) - -(template [ ] - [(def: - Inst - )] - - [L2S (|>> _.L2I _.I2S)] - [L2B (|>> _.L2I _.I2B)] - [L2C (|>> _.L2I _.I2C)] - ) - -(template [ ] - [(def: ( inputI) - (Unary Inst) - (if (is? _.NOP ) - inputI - (|>> inputI - )))] - - [_.D2F conversion::double-to-float] - [_.D2I conversion::double-to-int] - [_.D2L conversion::double-to-long] - [_.F2D conversion::float-to-double] - [_.F2I conversion::float-to-int] - [_.F2L conversion::float-to-long] - [_.I2B conversion::int-to-byte] - [_.I2C conversion::int-to-char] - [_.I2D conversion::int-to-double] - [_.I2F conversion::int-to-float] - [_.I2L conversion::int-to-long] - [_.I2S conversion::int-to-short] - [_.L2D conversion::long-to-double] - [_.L2F conversion::long-to-float] - [_.L2I conversion::long-to-int] - [..L2S conversion::long-to-short] - [..L2B conversion::long-to-byte] - [..L2C conversion::long-to-char] - [_.I2B conversion::char-to-byte] - [_.I2S conversion::char-to-short] - [_.NOP conversion::char-to-int] - [_.I2L conversion::char-to-long] - [_.I2L conversion::byte-to-long] - [_.I2L conversion::short-to-long] - ) - -(def: conversion - Bundle - (<| (bundle.prefix "conversion") - (|> (: Bundle bundle.empty) - (bundle.install "double-to-float" (unary conversion::double-to-float)) - (bundle.install "double-to-int" (unary conversion::double-to-int)) - (bundle.install "double-to-long" (unary conversion::double-to-long)) - (bundle.install "float-to-double" (unary conversion::float-to-double)) - (bundle.install "float-to-int" (unary conversion::float-to-int)) - (bundle.install "float-to-long" (unary conversion::float-to-long)) - (bundle.install "int-to-byte" (unary conversion::int-to-byte)) - (bundle.install "int-to-char" (unary conversion::int-to-char)) - (bundle.install "int-to-double" (unary conversion::int-to-double)) - (bundle.install "int-to-float" (unary conversion::int-to-float)) - (bundle.install "int-to-long" (unary conversion::int-to-long)) - (bundle.install "int-to-short" (unary conversion::int-to-short)) - (bundle.install "long-to-double" (unary conversion::long-to-double)) - (bundle.install "long-to-float" (unary conversion::long-to-float)) - (bundle.install "long-to-int" (unary conversion::long-to-int)) - (bundle.install "long-to-short" (unary conversion::long-to-short)) - (bundle.install "long-to-byte" (unary conversion::long-to-byte)) - (bundle.install "long-to-char" (unary conversion::long-to-char)) - (bundle.install "char-to-byte" (unary conversion::char-to-byte)) - (bundle.install "char-to-short" (unary conversion::char-to-short)) - (bundle.install "char-to-int" (unary conversion::char-to-int)) - (bundle.install "char-to-long" (unary conversion::char-to-long)) - (bundle.install "byte-to-long" (unary conversion::byte-to-long)) - (bundle.install "short-to-long" (unary conversion::short-to-long)) - ))) - -(template [ ] - [(def: ( [xI yI]) - (Binary Inst) - (|>> xI - yI - ))] - - [int::+ _.IADD] - [int::- _.ISUB] - [int::* _.IMUL] - [int::/ _.IDIV] - [int::% _.IREM] - [int::and _.IAND] - [int::or _.IOR] - [int::xor _.IXOR] - [int::shl _.ISHL] - [int::shr _.ISHR] - [int::ushr _.IUSHR] - - [long::+ _.LADD] - [long::- _.LSUB] - [long::* _.LMUL] - [long::/ _.LDIV] - [long::% _.LREM] - [long::and _.LAND] - [long::or _.LOR] - [long::xor _.LXOR] - [long::shl _.LSHL] - [long::shr _.LSHR] - [long::ushr _.LUSHR] - - [float::+ _.FADD] - [float::- _.FSUB] - [float::* _.FMUL] - [float::/ _.FDIV] - [float::% _.FREM] - - [double::+ _.DADD] - [double::- _.DSUB] - [double::* _.DMUL] - [double::/ _.DDIV] - [double::% _.DREM] - ) - -(def: $Boolean (type.class box.boolean (list))) -(def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean)) -(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean)) - -(template [ ] - [(def: ( [xI yI]) - (Binary Inst) - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> xI - yI - ( @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [int::= _.IF_ICMPEQ] - [int::< _.IF_ICMPLT] - - [char::= _.IF_ICMPEQ] - [char::< _.IF_ICMPLT] - ) - -(template [ ] - [(def: ( [xI yI]) - (Binary Inst) - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> xI - yI - - (_.int ) - (_.IF_ICMPEQ @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [long::= _.LCMP +0] - [long::< _.LCMP -1] - - [float::= _.FCMPG +0] - [float::< _.FCMPG -1] - - [double::= _.DCMPG +0] - [double::< _.DCMPG -1] - ) - -(def: int - Bundle - (<| (bundle.prefix (reflection.reflection reflection.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 (reflection.reflection reflection.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 (reflection.reflection reflection.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 (reflection.reflection reflection.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 (reflection.reflection reflection.char)) - (|> (: Bundle bundle.empty) - (bundle.install "=" (binary char::=)) - (bundle.install "<" (binary char::<)) - ))) - -(def: (primitive-array-length-handler jvm-primitive) - (-> (Type Primitive) Handler) - (..custom - [.any - (function (_ extension-name generate arrayS) - (do phase.monad - [arrayI (generate arrayS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array jvm-primitive)) - _.ARRAYLENGTH))))])) - -(def: array::length::object - Handler - (..custom - [($_ <>.and ..object-array .any) - (function (_ extension-name generate [elementJT arrayS]) - (do phase.monad - [arrayI (generate arrayS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - _.ARRAYLENGTH))))])) - -(def: (new-primitive-array-handler jvm-primitive) - (-> (Type Primitive) Handler) - (function (_ extension-name generate inputs) - (case inputs - (^ (list lengthS)) - (do phase.monad - [lengthI (generate lengthS)] - (wrap (|>> lengthI - (_.array jvm-primitive)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) - -(def: array::new::object - Handler - (..custom - [($_ <>.and ..object .any) - (function (_ extension-name generate [objectJT lengthS]) - (do phase.monad - [lengthI (generate lengthS)] - (wrap (|>> lengthI - (_.ANEWARRAY objectJT)))))])) - -(def: (read-primitive-array-handler jvm-primitive loadI) - (-> (Type Primitive) Inst Handler) - (function (_ extension-name generate inputs) - (case inputs - (^ (list idxS arrayS)) - (do phase.monad - [arrayI (generate arrayS) - idxI (generate idxS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array jvm-primitive)) - idxI - loadI))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) - -(def: array::read::object - Handler - (..custom - [($_ <>.and ..object-array .any .any) - (function (_ extension-name generate [elementJT idxS arrayS]) - (do phase.monad - [arrayI (generate arrayS) - idxI (generate idxS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - idxI - _.AALOAD))))])) - -(def: (write-primitive-array-handler jvm-primitive storeI) - (-> (Type Primitive) Inst Handler) - (function (_ extension-name generate inputs) - (case inputs - (^ (list idxS valueS arrayS)) - (do phase.monad - [arrayI (generate arrayS) - idxI (generate idxS) - valueI (generate valueS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array jvm-primitive)) - _.DUP - idxI - valueI - storeI))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) - -(def: array::write::object - Handler - (..custom - [($_ <>.and ..object-array .any .any .any) - (function (_ extension-name generate [elementJT idxS valueS arrayS]) - (do phase.monad - [arrayI (generate arrayS) - idxI (generate idxS) - valueI (generate valueS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - _.DUP - idxI - valueI - _.AASTORE))))])) - -(def: array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (dictionary.merge (<| (bundle.prefix "length") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) - (bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) - (bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) - (bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) - (bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) - (bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) - (bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) - (bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) - (bundle.install "object" array::length::object)))) - (dictionary.merge (<| (bundle.prefix "new") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler type.boolean)) - (bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler type.byte)) - (bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler type.short)) - (bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler type.int)) - (bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler type.long)) - (bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler type.float)) - (bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler type.double)) - (bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler type.char)) - (bundle.install "object" array::new::object)))) - (dictionary.merge (<| (bundle.prefix "read") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.BALOAD)) - (bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.BALOAD)) - (bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.SALOAD)) - (bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.IALOAD)) - (bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.LALOAD)) - (bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.FALOAD)) - (bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.DALOAD)) - (bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.CALOAD)) - (bundle.install "object" array::read::object)))) - (dictionary.merge (<| (bundle.prefix "write") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.BASTORE)) - (bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.BASTORE)) - (bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.SASTORE)) - (bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.IASTORE)) - (bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.LASTORE)) - (bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.FASTORE)) - (bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.DASTORE)) - (bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.CASTORE)) - (bundle.install "object" array::write::object)))) - ))) - -(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: $Class (type.class "java.lang.Class" (list))) - -(def: (object::class extension-name generate inputs) - Handler - (case inputs - (^ (list (synthesis.text class))) - (do phase.monad - [] - (wrap (|>> (_.string class) - (_.INVOKESTATIC $Class "forName" (type.method [(list (type.class "java.lang.String" (list))) $Class (list)]))))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) - -(def: object::instance? - Handler - (..custom - [($_ <>.and .text .any) - (function (_ extension-name generate [class objectS]) - (do phase.monad - [objectI (generate objectS)] - (wrap (|>> objectI - (_.INSTANCEOF (type.class class (list))) - (_.wrap type.boolean)))))])) - -(def: (object::cast extension-name generate inputs) - Handler - (case inputs - (^ (list (synthesis.text from) (synthesis.text to) valueS)) - (do phase.monad - [valueI (generate valueS)] - (`` (cond (~~ (template [ ] - [(and (text@= (reflection.reflection (type.reflection )) - from) - (text@= - to)) - (wrap (|>> valueI (_.wrap ))) - - (and (text@= - from) - (text@= (reflection.reflection (type.reflection )) - to)) - (wrap (|>> valueI (_.unwrap )))] - - [box.boolean type.boolean] - [box.byte type.byte] - [box.short type.short] - [box.int type.int] - [box.long type.long] - [box.float type.float] - [box.double type.double] - [box.char type.char])) - ## else - (wrap valueI)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) - -(def: object-bundle - 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 (Type Primitive)) - (|> (list [(reflection.reflection reflection.boolean) type.boolean] - [(reflection.reflection reflection.byte) type.byte] - [(reflection.reflection reflection.short) type.short] - [(reflection.reflection reflection.int) type.int] - [(reflection.reflection reflection.long) type.long] - [(reflection.reflection reflection.float) type.float] - [(reflection.reflection reflection.double) type.double] - [(reflection.reflection reflection.char) type.char]) - (dictionary.from-list text.hash))) - -(def: get::static - Handler - (..custom - [($_ <>.and .text .text .text) - (function (_ extension-name generate [class field unboxed]) - (do phase.monad - [] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (_.GETSTATIC (type.class class (list)) field primitive)) - - #.None - (wrap (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))])) - -(def: put::static - Handler - (..custom - [($_ <>.and .text .text .text .any) - (function (_ extension-name generate [class field unboxed valueS]) - (do phase.monad - [valueI (generate valueS) - #let [$class (type.class class (list))]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (|>> valueI - (_.PUTSTATIC $class field primitive) - (_.string synthesis.unit))) - - #.None - (wrap (|>> valueI - (_.CHECKCAST $class) - (_.PUTSTATIC $class field $class) - (_.string synthesis.unit))))))])) - -(def: get::virtual - Handler - (..custom - [($_ <>.and .text .text .text .any) - (function (_ extension-name generate [class field unboxed objectS]) - (do phase.monad - [objectI (generate objectS) - #let [$class (type.class class (list)) - getI (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.GETFIELD $class field primitive) - - #.None - (_.GETFIELD $class field (type.class unboxed (list))))]] - (wrap (|>> objectI - (_.CHECKCAST $class) - getI))))])) - -(def: put::virtual - Handler - (..custom - [($_ <>.and .text .text .text .any .any) - (function (_ extension-name generate [class field unboxed valueS objectS]) - (do phase.monad - [valueI (generate valueS) - objectI (generate objectS) - #let [$class (type.class class (list)) - putI (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.PUTFIELD $class field primitive) - - #.None - (let [$unboxed (type.class unboxed (list))] - (|>> (_.CHECKCAST $unboxed) - (_.PUTFIELD $class field $unboxed))))]] - (wrap (|>> objectI - (_.CHECKCAST $class) - _.DUP - valueI - putI))))])) - -(type: Input (Typed Synthesis)) - -(def: input - (Parser Input) - (.tuple (<>.and ..value .any))) - -(def: (generate-input generate [valueT valueS]) - (-> (-> Synthesis (Operation Inst)) Input - (Operation (Typed Inst))) - (do phase.monad - [valueI (generate valueS)] - (case (type.primitive? valueT) - (#.Right valueT) - (wrap [valueT valueI]) - - (#.Left valueT) - (wrap [valueT (|>> valueI - (_.CHECKCAST valueT))])))) - -(def: voidI (_.string synthesis.unit)) - -(def: (prepare-output outputT) - (-> (Type Return) Inst) - (case (type.void? outputT) - (#.Right outputT) - ..voidI - - (#.Left outputT) - function.identity)) - -(def: invoke::static - Handler - (..custom - [($_ <>.and ..class .text ..return (<>.some ..input)) - (function (_ extension-name generate [class method outputT inputsTS]) - (do phase.monad - [inputsTI (monad.map @ (generate-input generate) inputsTS)] - (wrap (|>> (_.fuse (list@map product.right inputsTI)) - (_.INVOKESTATIC class method (type.method [(list@map product.left inputsTI) outputT (list)])) - (prepare-output outputT)))))])) - -(template [ ] - [(def: - Handler - (..custom - [($_ <>.and ..class .text ..return .any (<>.some ..input)) - (function (_ extension-name generate [class method outputT objectS inputsTS]) - (do phase.monad - [objectI (generate objectS) - inputsTI (monad.map @ (generate-input generate) inputsTS)] - (wrap (|>> objectI - (_.CHECKCAST class) - (_.fuse (list@map product.right inputsTI)) - ( class method - (type.method [(list@map product.left inputsTI) - outputT - (list)])) - (prepare-output outputT)))))]))] - - [invoke::virtual _.INVOKEVIRTUAL] - [invoke::special _.INVOKESPECIAL] - [invoke::interface _.INVOKEINTERFACE] - ) - -(def: invoke::constructor - Handler - (..custom - [($_ <>.and ..class (<>.some ..input)) - (function (_ extension-name generate [class inputsTS]) - (do phase.monad - [inputsTI (monad.map @ (generate-input generate) inputsTS)] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse (list@map product.right inputsTI)) - (_.INVOKESPECIAL class "" (type.method [(list@map product.left inputsTI) type.void (list)]))))))])) - -(def: member - Bundle - (<| (bundle.prefix "member") - (|> (: Bundle bundle.empty) - (dictionary.merge (<| (bundle.prefix "get") - (|> (: Bundle bundle.empty) - (bundle.install "static" get::static) - (bundle.install "virtual" get::virtual)))) - (dictionary.merge (<| (bundle.prefix "put") - (|> (: Bundle bundle.empty) - (bundle.install "static" put::static) - (bundle.install "virtual" put::virtual)))) - (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: annotation-parameter - (Parser (/.Annotation-Parameter Synthesis)) - (.tuple (<>.and .text .any))) - -(def: annotation - (Parser (/.Annotation Synthesis)) - (.tuple (<>.and .text (<>.some ..annotation-parameter)))) - -(def: argument - (Parser Argument) - (.tuple (<>.and .text ..value))) - -(def: overriden-method-definition - (Parser [Environment (/.Overriden-Method Synthesis)]) - (.tuple (do <>.monad - [_ (.text! /.overriden-tag) - ownerT ..class - name .text - strict-fp? .bit - annotations (.tuple (<>.some ..annotation)) - vars (.tuple (<>.some ..var)) - self-name .text - arguments (.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (.tuple (<>.some ..class)) - [environment body] (.function 1 - (.tuple .any))] - (wrap [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]])))) - -(def: (normalize-path normalize) - (-> (-> Synthesis Synthesis) - (-> Path Path)) - (function (recur path) - (case path - (^ (synthesis.path/then bodyS)) - (synthesis.path/then (normalize bodyS)) - - (^template [] - (^ ( leftP rightP)) - ( (recur leftP) (recur rightP))) - ([#synthesis.Alt] - [#synthesis.Seq]) - - (^template [] - (^ ( value)) - path) - ([#synthesis.Pop] - [#synthesis.Test] - [#synthesis.Bind] - [#synthesis.Access])))) - -(def: (normalize-method-body mapping) - (-> (Dictionary Variable Variable) Synthesis Synthesis) - (function (recur body) - (case body - (^template [] - (^ ( value)) - body) - ([#synthesis.Primitive] - [synthesis.constant]) - - (^ (synthesis.variant [lefts right? sub])) - (synthesis.variant [lefts right? (recur sub)]) - - (^ (synthesis.tuple members)) - (synthesis.tuple (list@map recur members)) - - (^ (synthesis.variable var)) - (|> mapping - (dictionary.get var) - (maybe.default var) - synthesis.variable) - - (^ (synthesis.branch/case [inputS pathS])) - (synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) - - (^ (synthesis.branch/let [inputS register outputS])) - (synthesis.branch/let [(recur inputS) register (recur outputS)]) - - (^ (synthesis.branch/if [testS thenS elseS])) - (synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) - - (^ (synthesis.loop/scope [offset initsS+ bodyS])) - (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) - - (^ (synthesis.loop/recur updatesS+)) - (synthesis.loop/recur (list@map recur updatesS+)) - - (^ (synthesis.function/abstraction [environment arity bodyS])) - (synthesis.function/abstraction [(|> environment (list@map (function (_ local) - (|> mapping - (dictionary.get local) - (maybe.default local))))) - arity - bodyS]) - - (^ (synthesis.function/apply [functionS inputsS+])) - (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) - - (#synthesis.Extension [name inputsS+]) - (#synthesis.Extension [name (list@map recur inputsS+)])))) - -(def: $Object (type.class "java.lang.Object" (list))) - -(def: (anonymous-init-method env) - (-> Environment [(Signature Method) (Descriptor Method)]) - (type.method [(list.repeat (list.size env) $Object) - type.void - (list)])) - -(def: (with-anonymous-init class env super-class inputsTI) - (-> (Type Class) Environment (Type Class) (List (Typed Inst)) Def) - (let [store-capturedI (|> env - list.size - list.indices - (list@map (.function (_ register) - (|>> (_.ALOAD 0) - (_.ALOAD (inc register)) - (_.PUTFIELD class (///reference.foreign-name register) $Object)))) - _.fuse)] - (_def.method #$.Public $.noneM "" (anonymous-init-method env) - (|>> (_.ALOAD 0) - ((_.fuse (list@map product.right inputsTI))) - (_.INVOKESPECIAL super-class "" (type.method [(list@map product.left inputsTI) type.void (list)])) - store-capturedI - _.RETURN)))) - -(def: (anonymous-instance class env) - (-> (Type Class) Environment (Operation Inst)) - (do phase.monad - [captureI+ (monad.map @ ///reference.variable env)] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse captureI+) - (_.INVOKESPECIAL class "" (anonymous-init-method env)))))) - -(def: (returnI returnT) - (-> (Type Return) Inst) - (case (type.void? returnT) - (#.Right returnT) - _.RETURN - - (#.Left returnT) - (case (type.primitive? returnT) - (#.Left returnT) - _.ARETURN - - (#.Right returnT) - (cond (or (:: type.equivalence = type.boolean returnT) - (:: type.equivalence = type.byte returnT) - (:: type.equivalence = type.short returnT) - (:: type.equivalence = type.int returnT) - (:: type.equivalence = type.char returnT)) - _.IRETURN - - (:: type.equivalence = type.long returnT) - _.LRETURN - - (:: type.equivalence = type.float returnT) - _.FRETURN - - ## (:: type.equivalence = type.double returnT) - _.DRETURN)))) - -(def: class::anonymous - Handler - (..custom - [($_ <>.and - .text - ..class - (.tuple (<>.some ..class)) - (.tuple (<>.some ..input)) - (.tuple (<>.some ..overriden-method-definition))) - (function (_ extension-name generate [class-name - super-class super-interfaces - inputsTS - overriden-methods]) - (do phase.monad - [#let [class (type.class class-name (list)) - total-environment (|> overriden-methods - ## Get all the environments. - (list@map product.left) - ## Combine them. - list@join - ## Remove duplicates. - (set.from-list reference.hash) - set.to-list) - global-mapping (|> total-environment - ## Give them names as "foreign" variables. - list.enumerate - (list@map (function (_ [id capture]) - [capture (#reference.Foreign id)])) - (dictionary.from-list reference.hash)) - normalized-methods (list@map (function (_ [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]]) - (let [local-mapping (|> environment - list.enumerate - (list@map (function (_ [foreign-id capture]) - [(#reference.Foreign foreign-id) - (|> global-mapping - (dictionary.get capture) - maybe.assume)])) - (dictionary.from-list reference.hash))] - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - (normalize-method-body local-mapping body)])) - overriden-methods)] - inputsTI (monad.map @ (generate-input generate) inputsTS) - method-definitions (|> normalized-methods - (monad.map @ (function (_ [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - bodyS]) - (do @ - [bodyG (generate bodyS)] - (wrap (_def.method #$.Public - (if strict-fp? - ($_ $.++M $.finalM $.strictM) - $.finalM) - name - (type.method [(list@map product.right arguments) - returnT - exceptionsT]) - (|>> bodyG (returnI returnT))))))) - (:: @ map _def.fuse)) - _ (generation.save! true ["" class-name] - [class-name - (_def.class #$.V1_6 #$.Public $.finalC - class-name (list) - super-class super-interfaces - (|>> (///function.with-environment total-environment) - (..with-anonymous-init class total-environment super-class inputsTI) - method-definitions))])] - (anonymous-instance class total-environment)))])) - -(def: bundle::class - Bundle - (<| (bundle.prefix "class") - (|> (: Bundle bundle.empty) - (bundle.install "anonymous" class::anonymous) - ))) - -(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-bundle) - (dictionary.merge ..member) - (dictionary.merge ..bundle::class) - ))) -- cgit v1.2.3