From a420abd8ef1d5a008a5a0b6f75590cab2a9baac5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 28 May 2019 18:43:43 -0400 Subject: Implemented machinery for "lux syntax char case!". --- .../luxc/lang/translation/jvm/procedure/common.lux | 65 ++++++++++++++++- .../luxc/lang/translation/jvm/procedure/host.lux | 84 ++++++++++------------ 2 files changed, 98 insertions(+), 51 deletions(-) (limited to 'new-luxc/source/luxc/lang/translation/jvm') diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux index ea67a0d4a..34462d9ba 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux @@ -3,19 +3,23 @@ [abstract ["." monad (#+ do)]] [control - ["p" parser] + ["<>" parser + ["" synthesis (#+ Parser)]] ["ex" exception (#+ exception:)]] [data + ["." product] + ["." error] ["." text format] [collection + ["." list ("#@." monad)] ["." dictionary]]] [target [jvm ["_t" type (#+ Type Method)]]] [tool [compiler - ["." synthesis (#+ Synthesis)] + ["." synthesis (#+ Synthesis %synthesis)] ["." phase [generation [extension (#+ Nullary Unary Binary Trinary Variadic @@ -26,11 +30,24 @@ [luxc [lang [host - ["$" jvm (#+ Label Inst Bundle) + ["$" 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) + (#error.Success input') + (handler extension-name phase input') + + (#error.Failure error) + (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) + (import: java/lang/Double (#static MIN_VALUE Double) (#static MAX_VALUE Double)) @@ -58,6 +75,47 @@ (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 #_t.Long) _.L2I + (_.LOOKUPSWITCH @else table) + conditionalsG + (_.label @else) + elseG + (_.label @end) + )))))])) + (def: (lux::is [referenceI sampleI]) (Binary Inst) (|>> referenceI @@ -251,6 +309,7 @@ (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)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index e57101660..83cbd017b 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -6,7 +6,7 @@ ["." exception (#+ exception:)] ["<>" parser ("#@." monad) ["" text] - ["" synthesis]]] + ["" synthesis (#+ Parser)]]] [data ["." product] ["." maybe] @@ -46,25 +46,14 @@ ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) ["_" inst] ["_." def]]]]] - ["." /// #_ - ["#." reference] - ["#." function]]) + ["." // #_ + [common (#+ custom)] + ["/#" // #_ + ["#." reference] + ["#." function]]]) (exception: #export invalid-syntax-for-argument-generation) -(def: (custom [parser handler]) - (All [s] - (-> [(.Parser s) - (-> Text Phase s (Operation Inst))] - Handler)) - (function (_ extension-name phase input) - (case (.run input parser) - (#error.Success input') - (handler extension-name phase input') - - (#error.Failure error) - (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) - (template [ ] [(def: Inst @@ -322,13 +311,14 @@ (def: (primitive-array-length-handler jvm-primitive) (-> Type Handler) - (..custom [.any - (function (_ extension-name generate arrayS) - (do phase.monad - [arrayI (generate arrayS)] - (wrap (|>> arrayI - (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive))) - _.ARRAYLENGTH))))])) + (..custom + [.any + (function (_ extension-name generate arrayS) + (do phase.monad + [arrayI (generate arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive))) + _.ARRAYLENGTH))))])) (def: (array::length::object extension-name generate inputs) Handler @@ -543,18 +533,16 @@ _ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) -(def: (object::instance? extension-name generate inputs) +(def: object::instance? Handler - (case inputs - (^ (list (synthesis.text class) objectS)) - (do phase.monad - [objectI (generate objectS)] - (wrap (|>> objectI - (_.INSTANCEOF class) - (_.wrap #jvm.Boolean)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + (..custom + [($_ <>.and .text .any) + (function (_ extension-name generate [class objectS]) + (do phase.monad + [objectI (generate objectS)] + (wrap (|>> objectI + (_.INSTANCEOF class) + (_.wrap #jvm.Boolean)))))])) (def: (object::cast extension-name generate inputs) Handler @@ -813,20 +801,20 @@ ))) (def: var - (.Parser Var) + (Parser Var) .text) (def: bound - (.Parser Bound) + (Parser Bound) (<>.or (.constant! ["" ">"]) (.constant! ["" "<"]))) (def: (class' generic) - (-> (.Parser Generic) (.Parser Class)) + (-> (Parser Generic) (Parser Class)) (.tuple (<>.and .text (<>.some generic)))) (def: generic - (.Parser Generic) + (Parser Generic) (<>.rec (function (_ generic) (let [wildcard (<>.or (.constant! ["" "?"]) @@ -837,11 +825,11 @@ (class' generic)))))) (def: class - (.Parser Class) + (Parser Class) (class' ..generic)) (def: primitive - (.Parser Primitive) + (Parser Primitive) ($_ <>.or (.constant! ["" reflection.boolean]) (.constant! ["" reflection.byte]) @@ -854,7 +842,7 @@ )) (def: jvm-type - (.Parser Type) + (Parser Type) (<>.rec (function (_ jvm-type) ($_ <>.or @@ -863,28 +851,28 @@ (.tuple jvm-type))))) (def: constructor-arg - (.Parser (Typed Synthesis)) + (Parser (Typed Synthesis)) (.tuple (<>.and ..jvm-type .any))) (def: annotation-parameter - (.Parser (/.Annotation-Parameter Synthesis)) + (Parser (/.Annotation-Parameter Synthesis)) (.tuple (<>.and .text .any))) (def: annotation - (.Parser (/.Annotation Synthesis)) + (Parser (/.Annotation Synthesis)) (.tuple (<>.and .text (<>.some ..annotation-parameter)))) (def: argument - (.Parser Argument) + (Parser Argument) (.tuple (<>.and .text ..jvm-type))) (def: return - (.Parser Return) + (Parser Return) (<>.or (.constant! ["" jvm.void-descriptor]) ..jvm-type)) (def: overriden-method-definition - (.Parser [Environment (/.Overriden-Method Synthesis)]) + (Parser [Environment (/.Overriden-Method Synthesis)]) (.tuple (do <>.monad [ownerT ..class name .text -- cgit v1.2.3