diff options
Diffstat (limited to '')
18 files changed, 911 insertions, 531 deletions
diff --git a/stdlib/source/lux/target/scheme.lux b/stdlib/source/lux/target/scheme.lux index b5cf7c76d..ecdaa7324 100644 --- a/stdlib/source/lux/target/scheme.lux +++ b/stdlib/source/lux/target/scheme.lux @@ -1,16 +1,17 @@ (.module: - [lux (#- Code Global int or and if function cond let) + [lux (#- Code int or and if function cond let) [control [pipe (#+ new> cond> case>)]] [data - [number - ["f" frac]] ["." text ["%" format (#+ format)]] [collection ["." list ("#\." functor fold)]]] [macro ["." template]] + [math + [number + ["f" frac]]] [type abstract]]) @@ -28,7 +29,6 @@ [(abstract: #export <brand> Any) (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+)))))] - [Global Global' [Expression' Code]] [Var Var' [Expression' Code]] [Computation Computation' [Expression' Code]] ) @@ -37,9 +37,17 @@ {#mandatory (List Var) #rest (Maybe Var)}) - (def: #export code (-> (Code Any) Text) (|>> :representation)) + (def: #export manual + (-> Text Code) + (|>> :abstraction)) - (def: #export var (-> Text Var) (|>> :abstraction)) + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (def: #export var + (-> Text Var) + (|>> :abstraction)) (def: (arguments [mandatory rest]) (-> Arguments (Code Any)) @@ -53,14 +61,14 @@ (|> (format " . " (:representation rest)) (format (|> mandatory (list\map ..code) - (text.join-with " "))) + (text.join_with " "))) (text.enclose ["(" ")"]) :abstraction)) #.None (|> mandatory (list\map ..code) - (text.join-with " ") + (text.join_with " ") (text.enclose ["(" ")"]) :abstraction))) @@ -80,34 +88,34 @@ (def: #export float (-> Frac Computation) - (|>> (cond> [(f.= f.positive-infinity)] + (|>> (cond> [(f.= f.positive_infinity)] [(new> "+inf.0" [])] - [(f.= f.negative-infinity)] + [(f.= f.negative_infinity)] [(new> "-inf.0" [])] - [f.not-a-number?] + [f.not_a_number?] [(new> "+nan.0" [])] ## else [%.frac]) :abstraction)) - (def: #export positive-infinity Computation (..float f.positive-infinity)) - (def: #export negative-infinity Computation (..float f.negative-infinity)) - (def: #export not-a-number Computation (..float f.not-a-number)) + (def: #export positive_infinity Computation (..float f.positive_infinity)) + (def: #export negative_infinity Computation (..float f.negative_infinity)) + (def: #export not_a_number Computation (..float f.not_a_number)) (def: sanitize (-> Text Text) (`` (|>> (~~ (template [<find> <replace>] - [(text.replace-all <find> <replace>)] + [(text.replace_all <find> <replace>)] [text.alarm "\a"] - [text.back-space "\b"] + [text.back_space "\b"] [text.tab "\t"] - [text.new-line "\n"] - [text.carriage-return "\r"] - [text.double-quote (format "\" text.double-quote)] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] ["\" "\\"] ["|" "\|"] )) @@ -121,36 +129,32 @@ (-> Text Computation) (|>> (format "'") :abstraction)) - (def: #export global - (-> Text Global) - (|>> :abstraction)) - (def: form (-> (List (Code Any)) Code) (|>> (list\map ..code) - (text.join-with " ") + (text.join_with " ") (text.enclose ["(" ")"]) :abstraction)) - (def: #export (apply/* func args) - (-> Expression (List Expression) Computation) + (def: #export (apply/* args func) + (-> (List Expression) Expression Computation) (..form (#.Cons func args))) (template [<name> <function>] - [(def: #export <name> + [(def: #export (<name> members) (-> (List Expression) Computation) - (apply/* (..global <function>)))] + (..apply/* members (..var <function>)))] [vector/* "vector"] [list/* "list"] ) - (def: #export (apply/0 func) + (def: #export apply/0 (-> Expression Computation) - (..apply/* func (list))) + (..apply/* (list))) - (template [<lux-name> <scheme-name>] - [(def: #export <lux-name> (apply/0 (..global <scheme-name>)))] + (template [<lux_name> <scheme_name>] + [(def: #export <lux_name> (apply/0 (..var <scheme_name>)))] [newline/0 "newline"] ) @@ -159,10 +163,10 @@ [(`` (def: #export (<apply> function) (-> Expression (~~ (template.splice <type>+)) Computation) (.function (_ (~~ (template.splice <arg>+))) - (..apply/* function (list (~~ (template.splice <arg>+))))))) + (..apply/* (list (~~ (template.splice <arg>+))) function)))) (`` (template [<definition> <function>] - [(def: #export <definition> (<apply> (..global <function>)))] + [(def: #export <definition> (<apply> (..var <function>)))] (~~ (template.splice <function>+))))] @@ -177,12 +181,12 @@ [car/1 "car"] [cdr/1 "cdr"] [raise/1 "raise"] - [error-object-message/1 "error-object-message"] - [make-vector/1 "make-vector"] - [vector-length/1 "vector-length"] + [error_object_message/1 "error-object-message"] + [make_vector/1 "make-vector"] + [vector_length/1 "vector-length"] [not/1 "not"] - [string-length/1 "string-length"] - [string-hash/1 "string-hash"] + [string_length/1 "string-length"] + [string_hash/1 "string-hash"] [reverse/1 "reverse"] [display/1 "display"] [exit/1 "exit"]]] @@ -190,19 +194,19 @@ [apply/2 [_0 _1] [Expression Expression] [[append/2 "append"] [cons/2 "cons"] - [make-vector/2 "make-vector"] - ## [vector-ref/2 "vector-ref"] - [list-tail/2 "list-tail"] + [make_vector/2 "make-vector"] + ## [vector_ref/2 "vector-ref"] + [list_tail/2 "list-tail"] [map/2 "map"] - [string-ref/2 "string-ref"] - [string-append/2 "string-append"]]] + [string_ref/2 "string-ref"] + [string_append/2 "string-append"]]] [apply/3 [_0 _1 _2] [Expression Expression Expression] [[substring/3 "substring"] - [vector-set!/3 "vector-set!"]]] + [vector_set!/3 "vector-set!"]]] [apply/5 [_0 _1 _2 _3 _4] [Expression Expression Expression Expression Expression] - [[vector-copy!/5 "vector-copy!"]]] + [[vector_copy!/5 "vector-copy!"]]] ) ## TODO: define "vector-ref/2" like a normal apply/2 function. @@ -218,14 +222,14 @@ ## 1. To carry on, and then, when it's time to compile the compiler ## itself into Scheme, switch from 'invoke' to normal 'vector-ref'. ## Either way, the 'invoke' needs to go away. - (def: #export (vector-ref/2 vector index) + (def: #export (vector_ref/2 vector index) (-> Expression Expression Computation) (..form (list (..var "invoke") vector (..symbol "getRaw") index))) - (template [<lux-name> <scheme-name>] - [(def: #export (<lux-name> param subject) + (template [<lux_name> <scheme_name>] + [(def: #export (<lux_name> param subject) (-> Expression Expression Computation) - (..apply/2 (..global <scheme-name>) subject param))] + (..apply/2 (..var <scheme_name>) subject param))] [=/2 "="] [eq?/2 "eq?"] @@ -244,25 +248,25 @@ [remainder/2 "remainder"] [quotient/2 "quotient"] [mod/2 "mod"] - [arithmetic-shift/2 "arithmetic-shift"] - [bit-and/2 "bitwise-and"] - [bit-or/2 "bitwise-ior"] - [bit-xor/2 "bitwise-xor"] + [arithmetic_shift/2 "arithmetic-shift"] + [bit_and/2 "bitwise-and"] + [bit_or/2 "bitwise-ior"] + [bit_xor/2 "bitwise-xor"] ) - (template [<lux-name> <scheme-name>] - [(def: #export <lux-name> + (template [<lux_name> <scheme_name>] + [(def: #export <lux_name> (-> (List Expression) Computation) - (|>> (list& (..global <scheme-name>)) ..form))] + (|>> (list& (..var <scheme_name>)) ..form))] [or "or"] [and "and"] ) - (template [<lux-name> <scheme-name> <var> <pre>] - [(def: #export (<lux-name> bindings body) + (template [<lux_name> <scheme_name> <var> <pre>] + [(def: #export (<lux_name> bindings body) (-> (List [<var> Expression]) Expression Computation) - (..form (list (..global <scheme-name>) + (..form (list (..var <scheme_name>) (|> bindings (list\map (.function (_ [binding/name binding/value]) (..form (list (|> binding/name <pre>) @@ -273,18 +277,18 @@ [let "let" Var (<|)] [let* "let*" Var (<|)] [letrec "letrec" Var (<|)] - [let-values "let-values" Arguments ..arguments] - [let*-values "let*-values" Arguments ..arguments] - [letrec-values "letrec-values" Arguments ..arguments] + [let_values "let-values" Arguments ..arguments] + [let*_values "let*-values" Arguments ..arguments] + [letrec_values "letrec-values" Arguments ..arguments] ) (def: #export (if test then else) (-> Expression Expression Expression Computation) - (..form (list (..global "if") test then else))) + (..form (list (..var "if") test then else))) (def: #export (when test then) (-> Expression Expression Computation) - (..form (list (..global "when") test then))) + (..form (list (..var "when") test then))) (def: #export (cond clauses else) (-> (List [Expression Expression]) Expression Computation) @@ -297,31 +301,31 @@ (def: #export (lambda arguments body) (-> Arguments Expression Computation) - (..form (list (..global "lambda") + (..form (list (..var "lambda") (..arguments arguments) body))) - (def: #export (define-function name arguments body) + (def: #export (define_function name arguments body) (-> Var Arguments Expression Computation) - (..form (list (..global "define") + (..form (list (..var "define") (|> arguments (update@ #mandatory (|>> (#.Cons name))) ..arguments) body))) - (def: #export (define-constant name value) + (def: #export (define_constant name value) (-> Var Expression Computation) - (..form (list (..global "define") name value))) + (..form (list (..var "define") name value))) (def: #export begin (-> (List Expression) Computation) - (|>> (#.Cons (..global "begin")) ..form)) + (|>> (#.Cons (..var "begin")) ..form)) (def: #export (set! name value) (-> Var Expression Computation) - (..form (list (..global "set!") name value))) + (..form (list (..var "set!") name value))) - (def: #export (with-exception-handler handler body) + (def: #export (with_exception_handler handler body) (-> Expression Expression Computation) - (..form (list (..global "with-exception-handler") handler body))) + (..form (list (..var "with-exception-handler") handler body))) ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux new file mode 100644 index 000000000..1c0a89df5 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux @@ -0,0 +1,34 @@ +(.module: + [lux #* + ["." host] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" scheme]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "scheme") + (|> bundle.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux new file mode 100644 index 000000000..945e90e57 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [scheme + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux new file mode 100644 index 000000000..6a13e29bb --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux @@ -0,0 +1,198 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." set] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" scheme (#+ Expression)]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" scheme #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." case]]] + [// + ["." synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +(template: (!unary function) + (|>> list _.apply/* (|> (_.constant function)))) + +## TODO: Get rid of this ASAP +## (def: lux::syntax_char_case! +## (..custom [($_ <>.and +## <s>.any +## <s>.any +## (<>.some (<s>.tuple ($_ <>.and +## (<s>.tuple (<>.many <s>.i64)) +## <s>.any)))) +## (function (_ extension_name phase archive [input else conditionals]) +## (do {! /////.monad} +## [inputG (phase archive input) +## [[context_module context_artifact] elseG] (generation.with_new_context archive +## (phase archive else)) +## @input (\ ! map _.var (generation.gensym "input")) +## conditionalsG (: (Operation (List [Expression Expression])) +## (monad.map ! (function (_ [chars branch]) +## (do ! +## [branchG (phase archive branch)] +## (wrap [(|> chars +## (list\map (|>> .int _.int (_.=== @input))) +## (list\fold (function (_ clause total) +## (if (is? _.null total) +## clause +## (_.or clause total))) +## _.null)) +## branchG]))) +## conditionals)) +## #let [foreigns (|> conditionals +## (list\map (|>> product.right synthesis.path/then //case.dependencies)) +## (list& (//case.dependencies (synthesis.path/then else))) +## list.concat +## (set.from_list _.hash) +## set.to_list) +## @expression (_.constant (reference.artifact [context_module context_artifact])) +## directive (_.define_function @expression (list& (_.parameter @input) (list\map _.reference foreigns)) +## (list\fold (function (_ [test then] else) +## (_.if test (_.return then) else)) +## (_.return elseG) +## conditionalsG))] +## _ (generation.execute! directive) +## _ (generation.save! (%.nat context_artifact) directive)] +## (wrap (_.apply/* (list& inputG foreigns) @expression))))])) + +## (def: lux_procs +## Bundle +## (|> /.empty +## (/.install "syntax char case!" lux::syntax_char_case!) +## (/.install "is" (binary (product.uncurry _.===))) +## (/.install "try" (unary //runtime.lux//try)) +## )) + +## (def: (left_shift [parameter subject]) +## (Binary Expression) +## (_.bit_shl (_.% (_.int +64) parameter) subject)) + +## (def: i64_procs +## Bundle +## (<| (/.prefix "i64") +## (|> /.empty +## (/.install "and" (binary (product.uncurry _.bit_and))) +## (/.install "or" (binary (product.uncurry _.bit_or))) +## (/.install "xor" (binary (product.uncurry _.bit_xor))) +## (/.install "left-shift" (binary ..left_shift)) +## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) +## (/.install "=" (binary (product.uncurry _.==))) +## (/.install "<" (binary (product.uncurry _.<))) +## (/.install "+" (binary (product.uncurry //runtime.i64//+))) +## (/.install "-" (binary (product.uncurry //runtime.i64//-))) +## (/.install "*" (binary (product.uncurry //runtime.i64//*))) +## (/.install "/" (binary (function (_ [parameter subject]) +## (_.intdiv/2 [subject parameter])))) +## (/.install "%" (binary (product.uncurry _.%))) +## (/.install "f64" (unary (_./ (_.float +1.0)))) +## (/.install "char" (unary //runtime.i64//char)) +## ))) + +## (def: (f64//% [parameter subject]) +## (Binary Expression) +## (_.fmod/2 [subject parameter])) + +## (def: (f64//encode subject) +## (Unary Expression) +## (_.number_format/2 [subject (_.int +17)])) + +## (def: f64_procs +## Bundle +## (<| (/.prefix "f64") +## (|> /.empty +## (/.install "=" (binary (product.uncurry _.==))) +## (/.install "<" (binary (product.uncurry _.<))) +## (/.install "+" (binary (product.uncurry _.+))) +## (/.install "-" (binary (product.uncurry _.-))) +## (/.install "*" (binary (product.uncurry _.*))) +## (/.install "/" (binary (product.uncurry _./))) +## (/.install "%" (binary ..f64//%)) +## (/.install "i64" (unary _.intval/1)) +## (/.install "encode" (unary ..f64//encode)) +## (/.install "decode" (unary //runtime.f64//decode))))) + +## (def: (text//clip [paramO extraO subjectO]) +## (Trinary Expression) +## (//runtime.text//clip paramO extraO subjectO)) + +## (def: (text//index [startO partO textO]) +## (Trinary Expression) +## (//runtime.text//index textO partO startO)) + +## (def: text_procs +## Bundle +## (<| (/.prefix "text") +## (|> /.empty +## (/.install "=" (binary (product.uncurry _.==))) +## (/.install "<" (binary (product.uncurry _.<))) +## (/.install "concat" (binary (product.uncurry (function.flip _.concat)))) +## (/.install "index" (trinary ..text//index)) +## (/.install "size" (unary //runtime.text//size)) +## (/.install "char" (binary (product.uncurry //runtime.text//char))) +## (/.install "clip" (trinary ..text//clip)) +## ))) + +## (def: io//current-time +## (Nullary Expression) +## (|>> _.time/0 +## (_.* (_.int +1,000)))) + +## (def: io_procs +## Bundle +## (<| (/.prefix "io") +## (|> /.empty +## (/.install "log" (unary //runtime.io//log!)) +## (/.install "error" (unary //runtime.io//throw!)) +## (/.install "current-time" (nullary ..io//current-time))))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + ## (dictionary.merge lux_procs) + ## (dictionary.merge i64_procs) + ## (dictionary.merge f64_procs) + ## (dictionary.merge text_procs) + ## (dictionary.merge io_procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux new file mode 100644 index 000000000..0a05436c2 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux @@ -0,0 +1,39 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" scheme (#+ Var Expression)]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" scheme #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (/.prefix "scheme") + (|> /.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux index 419c0ed2f..137c72c71 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux @@ -57,7 +57,7 @@ [valueO (expression archive valueS) body! (statement expression archive bodyS)] (wrap ($_ _.then - (_.; (_.set (..register register) valueO)) + (_.set! (..register register) valueO) body!)))) (def: #export (if expression archive [testS thenS elseS]) @@ -121,7 +121,7 @@ (def: restore! Statement - (_.; (_.set @cursor (_.array_pop/1 @savepoint)))) + (_.set! @cursor (_.array_pop/1 @savepoint))) (def: fail! _.break) @@ -135,7 +135,7 @@ [(def: (<name> simple? idx) (-> Bit Nat Statement) ($_ _.then - (_.; (_.set @temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>)))) + (_.set! @temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) (.if simple? (_.when (_.is_null/1 @temp) fail!) @@ -169,7 +169,7 @@ (///////phase\wrap ..pop!) (#/////synthesis.Bind register) - (///////phase\wrap (_.; (_.set (..register register) ..peek))) + (///////phase\wrap (_.set! (..register register) ..peek)) (#/////synthesis.Bit_Fork when thenP elseP) (do {! ///////phase.monad} @@ -227,7 +227,7 @@ (do ///////phase.monad [then! (recur thenP)] (///////phase\wrap ($_ _.then - (_.; (_.set (..register register) ..peek_and_pop)) + (_.set! (..register register) ..peek_and_pop) then!))) ## (^ (/////synthesis.!multi_pop nextP)) @@ -279,8 +279,8 @@ [stack_init (expression archive valueS) pattern_matching! (pattern_matching statement expression archive pathP)] (wrap ($_ _.then - (_.; (_.set @cursor (_.array/* (list stack_init)))) - (_.; (_.set @savepoint (_.array/* (list)))) + (_.set! @cursor (_.array/* (list stack_init))) + (_.set! @savepoint (_.array/* (list))) pattern_matching!)))) (def: #export (case statement expression archive [valueS pathP]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux index c6fa5687c..8dad09d37 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux @@ -51,19 +51,19 @@ (case inits #.Nil [($_ _.then - (_.; (_.set @selfL (_.closure (list (_.reference @selfL)) (list) body!))) - (_.; (_.set @selfG @selfL))) + (_.set! @selfL (_.closure (list (_.reference @selfL)) (list) body!)) + (_.set! @selfG @selfL)) @selfG] _ (let [@inits (|> (list.enumeration inits) (list\map (|>> product.left ..capture)))] - [(_.; (_.set @selfG (_.closure (list) (list\map _.parameter @inits) - ($_ _.then - (_.; (_.set @selfL (_.closure (list& (_.reference @selfL) (list\map _.reference @inits)) - (list) - body!))) - (_.return @selfL))))) + [(_.set! @selfG (_.closure (list) (list\map _.parameter @inits) + ($_ _.then + (_.set! @selfL (_.closure (list& (_.reference @selfL) (list\map _.reference @inits)) + (list) + body!)) + (_.return @selfL)))) (_.apply/* inits @selfG)]))) (def: #export (function statement expression archive [environment arity bodyS]) @@ -82,17 +82,17 @@ @scope (..@scope function_name) @selfG (_.global (///reference.artifact function_name)) @selfL (_.var (///reference.artifact function_name)) - initialize_self! (_.; (_.set (//case.register 0) @selfL)) + initialize_self! (_.set! (//case.register 0) @selfL) initialize! (list\fold (.function (_ post pre!) ($_ _.then pre! - (_.; (_.set (..input post) (_.nth (|> post .int _.int) @curried))))) + (_.set! (..input post) (_.nth (|> post .int _.int) @curried)))) initialize_self! (list.indices arity))] #let [[definition instantiation] (..with_closure closureG+ @selfG @selfL ($_ _.then - (_.; (_.set @num_args (_.func_num_args/0 []))) - (_.; (_.set @curried (_.func_get_args/0 []))) + (_.set! @num_args (_.func_num_args/0 [])) + (_.set! @curried (_.func_get_args/0 [])) (_.cond (list [(|> @num_args (_.=== arityG)) ($_ _.then initialize! @@ -107,7 +107,7 @@ (let [@missing (_.var "missing")] (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list)) ($_ _.then - (_.; (_.set @missing (_.func_get_args/0 []))) + (_.set! @missing (_.func_get_args/0 [])) (_.return (_.call_user_func_array/2 [@selfL (_.array_merge/+ @curried (list @missing))]))))))) ))] _ (/////generation.execute! definition) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux index d3e91b925..41289ed58 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux @@ -42,7 +42,7 @@ list.enumeration (list\map (function (_ [register value]) (let [variable (//case.register (n.+ offset register))] - (_.; (_.set variable value))))) + (_.set! variable value)))) list.reverse (list\fold _.then body))) @@ -112,7 +112,7 @@ [[offset @scope] /////generation.anchor argsO+ (monad.map ! (expression archive) argsS+)] (wrap ($_ _.then - (_.; (_.set @temp (_.array/* argsO+))) + (_.set! @temp (_.array/* argsO+)) (..setup offset (|> argsO+ list.enumeration diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux index 651e3854f..d5e831e09 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux @@ -55,9 +55,6 @@ (type: #export (Generator! i) (-> Phase! Phase Archive i (Operation Statement))) -(def: prefix - "LuxRuntime") - (def: #export unit (_.string /////synthesis.unit)) @@ -597,8 +594,6 @@ runtime//io )) -(def: #export artifact ..prefix) - (def: #export generate (Operation [Registry Output]) (do ///////phase.monad diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux index ed4fe4ae1..5f7a4e358 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux @@ -16,28 +16,26 @@ ["//#" /// #_ ["#." phase ("#\." monad)]]]]) -(def: #export (tuple generate archive elemsS+) +(def: #export (tuple expression archive elemsS+) (Generator (Tuple Synthesis)) (case elemsS+ #.Nil (///////phase\wrap (//primitive.text /////synthesis.unit)) (#.Cons singletonS #.Nil) - (generate archive singletonS) + (expression archive singletonS) _ (let [size (_.int (.int (list.size elemsS+)))] (|> elemsS+ - (monad.map ///////phase.monad (generate archive)) - ## (///////phase\map (|>> (list& (_.key_value (_.string //runtime.tuple_size_field) size)) - ## _.array/*)) + (monad.map ///////phase.monad (expression archive)) (///////phase\map (|>> _.array/* (//runtime.tuple//make size))))))) -(def: #export (variant generate archive [lefts right? valueS]) +(def: #export (variant expression archive [lefts right? valueS]) (Generator (Variant Synthesis)) (let [tag (if right? (inc lefts) lefts)] (///////phase\map (//runtime.variant tag right?) - (generate archive valueS)))) + (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux index a6e03cfd4..be476cf74 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux @@ -1,60 +1,60 @@ (.module: [lux #* [abstract - [monad (#+ do)]]] - [/ + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [target + ["_" scheme]]] + ["." / #_ [runtime (#+ Phase)] - ["." primitive] - ["." structure] - ["." reference ("#\." system)] - ["." function] - ["." case] - ["." loop] - ["." /// - ["." extension] - [// - ["." synthesis]]]]) - -(def: #export (generate synthesis) + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: #export (generate archive synthesis) Phase (case synthesis (^template [<tag> <generator>] [(^ (<tag> value)) - (\ ///.monad wrap (<generator> value))]) - ([synthesis.bit primitive.bit] - [synthesis.i64 primitive.i64] - [synthesis.f64 primitive.f64] - [synthesis.text primitive.text]) - - (^ (synthesis.variant variantS)) - (structure.variant generate variantS) - - (^ (synthesis.tuple members)) - (structure.tuple generate members) - - (#synthesis.Reference value) - (reference\reference value) - - (^ (synthesis.branch/case case)) - (case.case generate case) - - (^ (synthesis.branch/let let)) - (case.let generate let) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) - (^ (synthesis.branch/if if)) - (case.if generate if) + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) - (^ (synthesis.loop/scope scope)) - (loop.scope generate scope) - - (^ (synthesis.loop/recur updates)) - (loop.recur generate updates) - - (^ (synthesis.function/abstraction abstraction)) - (function.function generate abstraction) - - (^ (synthesis.function/apply application)) - (function.apply generate application) - - (#synthesis.Extension extension) - (extension.apply generate extension))) + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/recur /loop.recur] + [////synthesis.function/abstraction /function.function]) + + (#////synthesis.Extension extension) + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux index 5f460b749..8f7d8a8b1 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux @@ -1,43 +1,66 @@ (.module: [lux (#- case let if) [abstract - [monad (#+ do)]] - [control - ["ex" exception (#+ exception:)]] + ["." monad (#+ do)]] [data - ["." number] - ["." text] + ["." product] + ["." text + ["%" format (#+ format)]] [collection - ["." list ("#\." functor fold)]]] + ["." list ("#\." functor fold)] + ["." set]]] + [math + [number + ["i" int]]] [target ["_" scheme (#+ Expression Computation Var)]]] ["." // #_ - ["#." runtime (#+ Operation Phase)] + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] ["#." primitive] - ["#/" // #_ + ["/#" // #_ ["#." reference] - ["#/" // ("#\." monad) - ["#/" // #_ - [reference (#+ Register)] - ["#." synthesis (#+ Synthesis Path)]]]]]) + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) (def: #export register - (///reference.local _.var)) - -(def: #export (let generate [valueS register bodyS]) - (-> Phase [Synthesis Register Synthesis] - (Operation Computation)) - (do ////.monad - [valueO (generate valueS) - bodyO (generate bodyS)] + (-> Register Var) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] (wrap (_.let (list [(..register register) valueO]) bodyO)))) -(def: #export (record-get generate valueS pathP) - (-> Phase Synthesis (List (Either Nat Nat)) - (Operation Expression)) - (do ////.monad - [valueO (generate valueS)] +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] (wrap (list\fold (function (_ side source) (.let [method (.case side (^template [<side> <accessor>] @@ -47,27 +70,18 @@ [#.Right //runtime.tuple//right]))] (method source))) valueO - pathP)))) - -(def: #export (if generate [testS thenS elseS]) - (-> Phase [Synthesis Synthesis Synthesis] - (Operation Computation)) - (do ////.monad - [testO (generate testS) - thenO (generate thenS) - elseO (generate elseS)] - (wrap (_.if testO thenO elseO)))) + (list.reverse pathP))))) (def: @savepoint (_.var "lux_pm_cursor_savepoint")) (def: @cursor (_.var "lux_pm_cursor")) (def: @temp (_.var "lux_pm_temp")) -(def: @alt-error (_.var "alt_error")) +(def: @alt_error (_.var "alt_error")) (def: (push! value var) (-> Expression Var Computation) (_.set! var (_.cons/2 value var))) -(def: (push-cursor! value) +(def: (push_cursor! value) (-> Expression Computation) (push! value @cursor)) @@ -75,97 +89,123 @@ (-> Var Computation) (_.set! var var)) -(def: save-cursor! +(def: save_cursor! Computation (push! @cursor @savepoint)) -(def: restore-cursor! +(def: restore_cursor! Computation (_.set! @cursor (_.car/1 @savepoint))) -(def: cursor-top +(def: peek Computation (_.car/1 @cursor)) -(def: pop-cursor! +(def: pop_cursor! Computation (pop! @cursor)) -(def: pm-error (_.string "PM-ERROR")) +(def: pm_error + (_.string "PM-ERROR")) -(def: fail-pm! (_.raise/1 pm-error)) +(def: fail! + (_.raise/1 pm_error)) -(def: (pm-catch handler) +(def: (pm_catch handler) (-> Expression Computation) - (_.lambda [(list @alt-error) #.None] - (_.if (|> @alt-error (_.eqv?/2 pm-error)) + (_.lambda [(list @alt_error) #.None] + (_.if (|> @alt_error (_.eqv?/2 pm_error)) handler - (_.raise/1 @alt-error)))) - -(def: (pattern-matching' generate pathP) - (-> Phase Path (Operation Expression)) - (.case pathP - (^ (/////synthesis.path/then bodyS)) - (generate bodyS) - - #/////synthesis.Pop - (////\wrap pop-cursor!) - - (#/////synthesis.Bind register) - (////\wrap (_.define-constant (..register register) ..cursor-top)) - - (^template [<tag> <format> <=>] - [(^ (<tag> value)) - (////\wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) - fail-pm!))]) - ([/////synthesis.path/bit //primitive.bit _.eqv?/2] - [/////synthesis.path/i64 (<| //primitive.i64 .int) _.=/2] - [/////synthesis.path/f64 //primitive.f64 _.=/2] - [/////synthesis.path/text //primitive.text _.eqv?/2]) - - (^template [<pm> <flag> <prep>] - [(^ (<pm> idx)) - (////\wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))]) - (_.if (_.null?/1 @temp) - fail-pm! - (push-cursor! @temp))))]) - ([/////synthesis.side/left _.nil (<|)] - [/////synthesis.side/right (_.string "") inc]) - - (^template [<pm> <getter>] - [(^ (<pm> idx)) - (////\wrap (push-cursor! (<getter> (_.int (.int idx)) cursor-top)))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^template [<tag> <computation>] - [(^ (<tag> leftP rightP)) - (do ////.monad - [leftO (pattern-matching' generate leftP) - rightO (pattern-matching' generate rightP)] - (wrap <computation>))]) - ([/////synthesis.path/seq (_.begin (list leftO - rightO))] - [/////synthesis.path/alt (_.with-exception-handler - (pm-catch (_.begin (list restore-cursor! - rightO))) - (_.lambda [(list) #.None] - (_.begin (list save-cursor! - leftO))))]))) - -(def: (pattern-matching generate pathP) - (-> Phase Path (Operation Computation)) - (do ////.monad - [pattern-matching! (pattern-matching' generate pathP)] - (wrap (_.with-exception-handler - (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (_.raise/1 @alt_error)))) + +(def: (pattern_matching' expression archive) + (Generator Path) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap pop_cursor!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.define_constant (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format> <=>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(<=> (|> match <format>) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (_.cond clauses ..fail!)))]) + ([#/////synthesis.I64_Fork //primitive.i64 _.=/2] + [#/////synthesis.F64_Fork //primitive.f64 _.=/2] + [#/////synthesis.Text_Fork //primitive.text _.eqv?/2]) + + (^template [<pm> <flag> <prep>] + [(^ (<pm> idx)) + (///////phase\wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))]) + (_.if (_.null?/1 @temp) + ..fail! + (push_cursor! @temp))))]) + ([/////synthesis.side/left _.nil (<|)] + [/////synthesis.side/right (_.string "") inc]) + + (^template [<pm> <getter>] + [(^ (<pm> idx)) + (///////phase\wrap (push_cursor! (<getter> (_.int (.int idx)) ..peek)))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^template [<tag> <computation>] + [(^ (<tag> leftP rightP)) + (do ///////phase.monad + [leftO (recur leftP) + rightO (recur rightP)] + (wrap <computation>))]) + ([/////synthesis.path/seq (_.begin (list leftO + rightO))] + [/////synthesis.path/alt (_.with_exception_handler + (pm_catch (_.begin (list restore_cursor! + rightO))) + (_.lambda [(list) #.None] + (_.begin (list save_cursor! + leftO))))])))) + +(def: (pattern_matching expression archive pathP) + (Generator Path) + (do ///////phase.monad + [pattern_matching! (pattern_matching' expression archive pathP)] + (wrap (_.with_exception_handler + (pm_catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) (_.lambda [(list) #.None] - pattern-matching!))))) + pattern_matching!))))) -(def: #export (case generate [valueS pathP]) - (-> Phase [Synthesis Path] (Operation Computation)) - (do {! ////.monad} - [valueO (generate valueS)] +(def: #export (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do {! ///////phase.monad} + [valueO (expression archive valueS)] (<| (\ ! map (_.let (list [@cursor (_.list/* (list valueO))] [@savepoint (_.list/* (list))]))) - (pattern-matching generate pathP)))) + (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux index 97725a8f2..edcdb89b4 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux @@ -6,50 +6,52 @@ pipe] [data ["." product] - [text + ["." text ["%" format (#+ format)]] [collection - ["." list ("#\." functor)]]] + ["." list ("#\." functor fold)]]] [target ["_" scheme (#+ Expression Computation Var)]]] ["." // #_ - ["#." runtime (#+ Operation Phase)] + ["#." runtime (#+ Operation Phase Generator)] ["#." reference] ["#." case] - ["#/" // + ["/#" // #_ ["#." reference] - ["#/" // ("#\." monad) - ["#/" // #_ - [reference (#+ Register Variable)] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ [arity (#+ Arity)] - [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] - [synthesis (#+ Synthesis)]]]]]) + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]]]]]]) -(def: #export (apply generate [functionS argsS+]) - (-> Phase (Application Synthesis) (Operation Computation)) - (do {! ////.monad} - [functionO (generate functionS) - argsO+ (monad.map ! generate argsS+)] - (wrap (_.apply/* functionO argsO+)))) +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply/* argsO+ functionO)))) -(def: #export capture - (///reference.foreign _.var)) +(def: capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) -(def: (with-closure function-name inits function-definition) - (-> Text (List Expression) Computation (Operation Computation)) - (////\wrap +(def: (with_closure inits function_definition) + (-> (List Expression) Computation (Operation Computation)) + (///////phase\wrap (case inits #.Nil - function-definition + function_definition _ - (let [@closure (_.var (format function-name "___CLOSURE"))] - (_.letrec (list [@closure - (_.lambda [(|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - #.None] - function-definition)]) - (_.apply/* @closure inits)))))) + (|> function_definition + (_.lambda [(|> (list.enumeration inits) + (list\map (|>> product.left ..capture))) + #.None]) + (_.apply/* inits))))) (def: @curried (_.var "curried")) (def: @missing (_.var "missing")) @@ -57,42 +59,42 @@ (def: input (|>> inc //case.register)) -(def: #export (function generate [environment arity bodyS]) - (-> Phase (Abstraction Synthesis) (Operation Computation)) - (do {! ////.monad} - [[function-name bodyO] (///.with-context +(def: #export (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do {! ///////phase.monad} + [[function_name bodyO] (/////generation.with_new_context archive (do ! - [function-name ///.context] - (///.with-anchor (_.var function-name) - (generate bodyS)))) - closureO+ (: (Operation (List Expression)) - (monad.map ! (\ //reference.system variable) environment)) + [@self (\ ! map (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor @self + (expression archive bodyS)))) + closureO+ (monad.map ! (expression archive) environment) #let [arityO (|> arity .int _.int) - apply-poly (.function (_ args func) - (_.apply/2 (_.global "apply") func args)) - @num-args (_.var "num_args") - @function (_.var function-name)]] - (with-closure function-name closureO+ - (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] - (_.let (list [@num-args (_.length/1 @curried)]) - (<| (_.if (|> @num-args (_.=/2 arityO)) - (<| (_.let (list [(//case.register 0) @function])) - (_.let-values (list [[(|> (list.indices arity) - (list\map ..input)) - #.None] - (_.apply/2 (_.global "apply") (_.global "values") @curried)])) - bodyO)) - (_.if (|> @num-args (_.>/2 arityO)) - (let [arity-args (//runtime.slice (_.int +0) arityO @curried) - output-func-args (//runtime.slice arityO - (|> @num-args (_.-/2 arityO)) - @curried)] - (|> @function - (apply-poly arity-args) - (apply-poly output-func-args)))) - ## (|> @num-args (_.</2 arityO)) - (_.lambda [(list) (#.Some @missing)] - (|> @function - (apply-poly (_.append/2 @curried @missing))))) - ))]) - @function)))) + apply_poly (.function (_ args func) + (_.apply/2 (_.var "apply") func args)) + @num_args (_.var "num_args") + @self (_.var (///reference.artifact function_name))]] + (with_closure closureO+ + (_.letrec (list [@self (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num_args (_.length/1 @curried)]) + (<| (_.if (|> @num_args (_.=/2 arityO)) + (<| (_.let (list [(//case.register 0) @self])) + (_.let_values (list [[(|> (list.indices arity) + (list\map ..input)) + #.None] + (_.apply/2 (_.var "apply") (_.var "values") @curried)])) + bodyO)) + (_.if (|> @num_args (_.>/2 arityO)) + (let [arity_args (//runtime.slice (_.int +0) arityO @curried) + output_func_args (//runtime.slice arityO + (|> @num_args (_.-/2 arityO)) + @curried)] + (|> @self + (apply_poly arity_args) + (apply_poly output_func_args)))) + ## (|> @num_args (_.</2 arityO)) + (_.lambda [(list) (#.Some @missing)] + (|> @self + (apply_poly (_.append/2 @curried @missing))))) + ))]) + @self)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux index 053a32c15..633b0da5a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux @@ -4,39 +4,60 @@ ["." monad (#+ do)]] [data ["." product] - ["." text] - [number - ["n" nat]] + ["." text + ["%" format (#+ format)]] [collection - ["." list ("#\." functor)]]] + ["." list ("#\." functor fold)] + ["." set (#+ Set)]]] + [math + [number + ["n" nat]]] [target ["_" scheme (#+ Computation Var)]]] ["." // #_ - [runtime (#+ Operation Phase)] + [runtime (#+ Operation Phase Generator)] ["#." case] - ["#/" // - ["#/" // - [// - [synthesis (#+ Scope Synthesis)]]]]]) + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) + +(def: @scope + (_.var "scope")) -(def: @scope (_.var "scope")) +(def: #export (scope expression archive [start initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) -(def: #export (scope generate [start initsS+ bodyS]) - (-> Phase (Scope Synthesis) (Operation Computation)) - (do {! ////.monad} - [initsO+ (monad.map ! generate initsS+) - bodyO (///.with-anchor @scope - (generate bodyS))] - (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register))) - #.None] - bodyO)]) - (_.apply/* @scope initsO+))))) + ## true loop + _ + (do {! ///////phase.monad} + [initsO+ (monad.map ! (expression archive) initsS+) + bodyO (/////generation.with_anchor @scope + (expression archive bodyS))] + (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register))) + #.None] + bodyO)]) + (_.apply/* initsO+ @scope)))))) -(def: #export (recur generate argsS+) - (-> Phase (List Synthesis) (Operation Computation)) - (do {! ////.monad} - [@scope ///.anchor - argsO+ (monad.map ! generate argsS+)] - (wrap (_.apply/* @scope argsO+)))) +(def: #export (recur expression archive argsS+) + (Generator (List Synthesis)) + (do {! ///////phase.monad} + [@scope /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply/* argsO+ @scope)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux index b9add2e48..4e8ae26cf 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux @@ -3,8 +3,10 @@ [target ["_" scheme (#+ Expression)]]] [/// - ["." reference]]) + [reference (#+ System)]]) -(def: #export system - (reference.system (: (-> Text Expression) _.global) - (: (-> Text Expression) _.var))) +(structure: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux index 45dcd3eb2..d6ae1cffd 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux @@ -1,47 +1,65 @@ (.module: - [lux #* + [lux (#- Location inc) + ["." meta] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control ["." function] - ["p" parser ("#\." monad) - ["s" code (#+ Parser)]]] + ["<>" parser + ["<.>" code]]] [data - [number (#+ hex)] - [text - ["%" format (#+ format)]] + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + ["." encoding]] [collection - ["." list ("#\." monad)]]] - [macro - ["." code] - [syntax (#+ syntax:)]] - [target + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] + ["@" target ["_" scheme (#+ Expression Computation Var)]]] - ["." /// - ["#/" // - ["#/" // #_ - [analysis (#+ Variant)] - ["#." name] - ["#." synthesis]]]]) + ["." /// #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant)] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(def: module_id + 0) (template [<name> <base>] [(type: #export <name> (<base> Var Expression Expression))] - [Operation ///.Operation] - [Phase ///.Phase] - [Handler ///.Handler] - [Bundle ///.Bundle] + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] ) -(def: prefix Text "LuxRuntime") +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) -(def: unit (_.string /////synthesis.unit)) +(def: unit + (_.string /////synthesis.unit)) (def: (flag value) (-> Bit Computation) (if value - (_.string "") + ..unit _.nil)) (def: (variant' tag last? value) @@ -70,44 +88,54 @@ (-> Expression Computation) (|>> [0 #1] ..variant)) -(def: declaration - (Parser [Text (List Text)]) - (p.either (p.and s.local-identifier (p\wrap (list))) - (s.form (p.and s.local-identifier (p.some s.local-identifier))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-identifier (format "@@" name)) - runtime (format prefix "__" (/////name.normalize name)) - @runtime (` (_.var (~ (code.text runtime)))) - argsC+ (list\map code.local-identifier args) - argsLC+ (list\map (|>> /////name.normalize (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-identifier name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) - _.Computation))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) - (` (def: (~ implementation) - _.Computation - (~ (case argsC+ - #.Nil - (` (_.define-constant (~ @runtime) [(list) #.None] (~ definition))) - - _ - (` (let [(~+ (|> (list.zip/2 argsC+ argsLC+) - (list\map (function (_ [left right]) - (list left right))) - list\join))] - (_.define-function (~ @runtime) [(list (~+ argsLC+)) #.None] - (~ definition)))))))))))) +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + Var + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Computation + (_.define_constant (~ runtime_name) (~ code)))))))) + + (#.Right [name inputs]) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) _.Computation) + (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Computation + (..with_vars [(~+ inputsC)] + (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None] + (~ code)))))))))))))) (runtime: (slice offset length list) (<| (_.if (_.null?/1 list) @@ -123,113 +151,104 @@ (_.cdr/1 list)))) _.nil)) -(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list\map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (format "LRV__" (/////name.normalize var))))))))) - list\join))] - (~ body)))))) - (runtime: (lux//try op) - (with-vars [error] - (_.with-exception-handler + (with_vars [error] + (_.with_exception_handler (_.lambda [(list error) #.None] (..left error)) (_.lambda [(list) #.None] - (..right (_.apply/* op (list ..unit))))))) + (..right (_.apply/* (list ..unit) op)))))) -(runtime: (lux//program-args program-args) - (with-vars [@loop @input @output] +(runtime: (lux//program_args program_args) + (with_vars [@loop @input @output] (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] (_.if (_.eqv?/2 _.nil @input) @output (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) - (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + (_.apply/2 @loop (_.reverse/1 program_args) ..none)))) (def: runtime//lux Computation - (_.begin (list @@lux//try - @@lux//program-args))) + (_.begin (list @lux//try + @lux//program_args))) -(def: last-index +(def: last_index (-> Expression Computation) (|>> _.length/1 (_.-/2 (_.int +1)))) (runtime: (tuple//left lefts tuple) - (with-vars [last-index-right] + (with_vars [last_index_right] (_.begin - (list (_.define-constant last-index-right (..last-index tuple)) - (_.if (_.>/2 lefts last-index-right) + (list (_.define_constant last_index_right (..last_index tuple)) + (_.if (_.>/2 lefts last_index_right) ## No need for recursion - (_.vector-ref/2 tuple lefts) + (_.vector_ref/2 tuple lefts) ## Needs recursion - (tuple//left (_.-/2 last-index-right lefts) - (_.vector-ref/2 tuple last-index-right))))))) + (tuple//left (_.-/2 last_index_right lefts) + (_.vector_ref/2 tuple last_index_right))))))) (runtime: (tuple//right lefts tuple) - (with-vars [last-index-right right-index @slice] + (with_vars [last_index_right right_index @slice] (_.begin - (list (_.define-constant last-index-right (..last-index tuple)) - (_.define-constant right-index (_.+/2 (_.int +1) lefts)) - (_.cond (list [(_.=/2 last-index-right right-index) - (_.vector-ref/2 tuple right-index)] - [(_.>/2 last-index-right right-index) + (list (_.define_constant last_index_right (..last_index tuple)) + (_.define_constant right_index (_.+/2 (_.int +1) lefts)) + (_.cond (list [(_.=/2 last_index_right right_index) + (_.vector_ref/2 tuple right_index)] + [(_.>/2 last_index_right right_index) ## Needs recursion. - (tuple//right (_.-/2 last-index-right lefts) - (_.vector-ref/2 tuple last-index-right))]) + (tuple//right (_.-/2 last_index_right lefts) + (_.vector_ref/2 tuple last_index_right))]) (_.begin - (list (_.define-constant @slice (_.make-vector/1 (_.-/2 right-index (_.length/1 tuple)))) - (_.vector-copy!/5 @slice (_.int +0) tuple right-index (_.length/1 tuple)) + (list (_.define_constant @slice (_.make_vector/1 (_.-/2 right_index (_.length/1 tuple)))) + (_.vector_copy!/5 @slice (_.int +0) tuple right_index (_.length/1 tuple)) @slice)))) ))) -(runtime: (sum//get sum last? wanted-tag) - (with-vars [sum-tag sum-flag sum-value] - (let [no-match _.nil - is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) - test-recursion (_.if is-last? +(runtime: (sum//get sum last? wanted_tag) + (with_vars [sum_tag sum_flag sum_value] + (let [no_match _.nil + is_last? (|> sum_flag (_.eqv?/2 ..unit)) + test_recursion (_.if is_last? ## Must recurse. - (sum//get sum-value + (sum//get sum_value last? - (|> wanted-tag (_.-/2 sum-tag))) - no-match)] - (<| (_.let (list [sum-tag (_.car/1 sum)] - [sum-value (_.cdr/1 sum)])) - (_.let (list [sum-flag (_.car/1 sum-value)] - [sum-value (_.cdr/1 sum-value)])) - (_.if (|> wanted-tag (_.=/2 sum-tag)) - (_.if (|> sum-flag (_.eqv?/2 last?)) - sum-value - test-recursion)) - (_.if (|> wanted-tag (_.>/2 sum-tag)) - test-recursion) - (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) - (|> wanted-tag (_.</2 sum-tag)))) - (variant' (|> sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) - no-match)))) + (|> wanted_tag (_.-/2 sum_tag))) + no_match)] + (<| (_.let (list [sum_tag (_.car/1 sum)] + [sum_value (_.cdr/1 sum)])) + (_.let (list [sum_flag (_.car/1 sum_value)] + [sum_value (_.cdr/1 sum_value)])) + (_.if (|> wanted_tag (_.=/2 sum_tag)) + (_.if (|> sum_flag (_.eqv?/2 last?)) + sum_value + test_recursion)) + (_.if (|> wanted_tag (_.>/2 sum_tag)) + test_recursion) + (_.if (_.and (list (|> last? (_.eqv?/2 ..unit)) + (|> wanted_tag (_.</2 sum_tag)))) + (variant' (|> sum_tag (_.-/2 wanted_tag)) sum_flag sum_value)) + no_match)))) (def: runtime//adt Computation - (_.begin (list @@tuple//left - @@tuple//right - @@sum//get))) + (_.begin (list @tuple//left + @tuple//right + @sum//get))) -(runtime: (i64//logical-right-shift shift input) +(runtime: (i64//logical_right_shift shift input) (_.if (_.=/2 (_.int +0) shift) input (|> input - (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) - (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) + (_.arithmetic_shift/2 (_.*/2 (_.int -1) shift)) + (_.bit_and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) (def: runtime//bit Computation - (_.begin (list @@i64//logical-right-shift))) + (_.begin (list @i64//logical_right_shift))) (runtime: (frac//decode input) - (with-vars [@output] - (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) + (with_vars [@output] + (_.let (list [@output ((_.apply/1 (_.var "string->number")) input)]) (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) ..none @@ -238,19 +257,19 @@ (def: runtime//frac Computation (_.begin - (list @@frac//decode))) + (list @frac//decode))) -(runtime: (io//current-time _) - (|> (_.apply/* (_.global "current-second") (list)) +(runtime: (io//current_time _) + (|> (_.apply/0 (_.var "current-second")) (_.*/2 (_.int +1,000)) _.exact/1)) (def: runtime//io - (_.begin (list @@io//current-time))) + (_.begin (list @io//current_time))) (def: runtime Computation - (_.begin (list @@slice + (_.begin (list @slice runtime//lux runtime//bit runtime//adt @@ -259,9 +278,14 @@ ))) (def: #export generate - (Operation Any) - (///.with-buffer - (do ////.monad - [_ (///.execute! ..runtime) - _ (///.save! ..prefix ..runtime)] - (///.save-buffer! "")))) + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [(%.nat ..module_id) + (|> ..runtime + _.code + (\ encoding.utf8 encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux index bb11d2e1f..951fa494d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux @@ -2,36 +2,38 @@ [lux #* [abstract ["." monad (#+ do)]] + [data + [collection + ["." list]]] [target ["_" scheme (#+ Expression)]]] - [// - ["." runtime (#+ Operation Phase)] - ["." primitive] - ["." /// - [// - [analysis (#+ Variant Tuple)] - ["." synthesis (#+ Synthesis)]]]]) + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) -(def: #export (tuple generate elemsS+) - (-> Phase (Tuple Synthesis) (Operation Expression)) +(def: #export (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) (case elemsS+ #.Nil - (\ ///.monad wrap (primitive.text synthesis.unit)) + (///////phase\wrap (//primitive.text /////synthesis.unit)) (#.Cons singletonS #.Nil) - (generate singletonS) + (expression archive singletonS) _ - (do {! ///.monad} - [elemsT+ (monad.map ! generate elemsS+)] - (wrap (_.vector/* elemsT+))))) + (|> elemsS+ + (monad.map ///////phase.monad (expression archive)) + (///////phase\map _.vector/*)))) -(def: #export (variant generate [lefts right? valueS]) - (-> Phase (Variant Synthesis) (Operation Expression)) - (do ///.monad - [valueT (generate valueS)] - (wrap (runtime.variant [(if right? - (inc lefts) - lefts) - right? - valueT])))) +(def: #export (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (|>> [tag right?] //runtime.variant) + (expression archive valueS)))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 8d9f68922..8532b3e12 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -11,7 +11,9 @@ [monad (#+ do)] [predicate (#+ Predicate)]] [control - ["." io (#+ io)]] + ["." io (#+ io)] + [concurrency + ["." atom (#+ Atom)]]] [data ["." name] [text @@ -52,12 +54,14 @@ (def: identity Test (do {! random.monad} - [self (random.unicode 1)] + [#let [object (: (Random (Atom Text)) + (\ ! map atom.atom (random.unicode 1)))] + self object] ($_ _.and (_.test "Every value is identical to itself." (is? self self)) (do ! - [other (random.unicode 1)] + [other object] (_.test "Values created separately can't be identical." (not (is? self other)))) ))) |