From be3e93a0688d1fee7fcb6ee464642451b0e43fe0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 20 Feb 2019 00:00:57 -0400 Subject: Moved function machinery over. --- .../luxc/lang/translation/js/function.jvm.lux | 77 ---- .../compiler/phase/translation/js/function.lux | 109 ++++++ .../phase/translation/scheme/function.jvm.lux | 48 +-- stdlib/source/test/lux.lux | 400 ++++++++++----------- 4 files changed, 335 insertions(+), 299 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/translation/js/function.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/function.lux diff --git a/new-luxc/source/luxc/lang/translation/js/function.jvm.lux b/new-luxc/source/luxc/lang/translation/js/function.jvm.lux deleted file mode 100644 index ef5ea668e..000000000 --- a/new-luxc/source/luxc/lang/translation/js/function.jvm.lux +++ /dev/null @@ -1,77 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor])) - [macro]) - (luxc ["&" lang] - (lang ["ls" synthesis] - [".L" variable #+ Variable] - (host [js #+ JS Expression Statement]))) - [//] - (// [".T" reference] - [".T" loop])) - -(def: #export (translate-apply translate functionS argsS+) - (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression)) - (do macro.Monad - [functionJS (translate functionS) - argsJS+ (monad.map @ translate argsS+)] - (wrap (format functionJS "(" (text.join-with "," argsJS+) ")")))) - -(def: (input-declaration register) - (format "var " (referenceT.variable (inc register)) " = arguments[" (|> register .int %i) "];")) - -(def: (with-closure inits function) - (-> (List Expression) Expression Expression) - (let [closure (case inits - #.Nil - (list) - - _ - (|> (list.n/range +0 (dec (list.size inits))) - (list/map referenceT.closure)))] - (format "(function(" (text.join-with "," closure) ") {" - "return " function - ";})(" (text.join-with "," inits) ")"))) - -(def: #export (translate-function translate env arity bodyS) - (-> (-> ls.Synthesis (Meta Expression)) - (List Variable) ls.Arity ls.Synthesis - (Meta Expression)) - (do macro.Monad - [[function-name bodyJS] (//.with-sub-context - (do @ - [function-name //.context] - (//.with-anchor [function-name +1] - (translate bodyS)))) - closureJS+ (monad.map @ referenceT.translate-variable env) - #let [args-initsJS+ (|> (list.n/range +0 (dec arity)) - (list/map input-declaration) - (text.join-with "")) - selfJS (format "var " (referenceT.variable +0) " = " function-name ";") - arityJS (|> arity .int %i)]] - (wrap (<| (with-closure closureJS+) - (format "(function " function-name "() {" - "\"use strict\";" - "var num_args = arguments.length;" - "if(num_args == " arityJS ") {" - selfJS - args-initsJS+ - (format "while(true) {" - "return " bodyJS ";" - "}") - "}" - "else if(num_args > " arityJS ") {" - "return " function-name ".apply(null, [].slice.call(arguments,0," arityJS "))" - ".apply(null, [].slice.call(arguments," arityJS "));" - "}" - ## Less than arity - "else {" - "var curried = [].slice.call(arguments);" - "return function() { " - "return " function-name ".apply(null, curried.concat([].slice.call(arguments)));" - " };" - "}" - "})"))))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux new file mode 100644 index 000000000..741e66573 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux @@ -0,0 +1,109 @@ +(.module: + [lux (#- function) + [control + ["." monad (#+ do)] + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#/." functor fold)]]] + [host + ["_" js (#+ Expression Computation Var)]]] + [// + ["." runtime (#+ Operation Phase)] + ["." reference] + ["//." case] + ["/." // + [common + ["common-." reference]] + ["//." // ("#/." monad) + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + [// + [reference (#+ Register Variable)] + ["." name]]]]]) + +(def: #export (apply translate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation Computation)) + (do ////.monad + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: #export capture + (common-reference.foreign _.var)) + +(def: (with-closure inits function-definition) + (-> (List Expression) Computation (Operation Computation)) + (/////wrap + (case inits + #.Nil + function-definition + + _ + (let [closure (_.closure (|> (list.enumerate inits) + (list/map (|>> product.left ..capture))) + (_.return function-definition))] + (_.apply/* closure inits))))) + +(def: @curried (_.var "curried")) + +(def: input + (|>> inc //case.register)) + +(def: @@arguments (_.var "arguments")) + +(def: #export (function translate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation Computation)) + (do ////.monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (translate bodyS)))) + closureO+ (: (Operation (List Expression)) + (monad.map @ (:: reference.system variable) environment)) + #let [arityO (|> arity .int _.i32) + @num-args (_.var "num_args") + @self (_.var function-name) + apply-poly (.function (_ args func) + (|> func (_.do "apply" (list _.null args)))) + initialize-self! (_.define (//case.register 0) @self) + initialize! (list/fold (.function (_ post pre!) + ($_ _.then + pre! + (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments)))) + initialize-self! + (list.indices arity))]] + (with-closure closureO+ + (_.function @self (list) + ($_ _.then + (_.define @num-args (_.the "length" @@arguments)) + (_.cond (list [(|> @num-args (_.= arityO)) + ($_ _.then + initialize! + (_.return bodyO))] + [(|> @num-args (_.> arityO)) + (let [arity-inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments (_.i32 +0) arityO))) + extra-inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments arityO)))] + (_.return (|> @self + (apply-poly arity-inputs) + (apply-poly extra-inputs))))]) + ## (|> @num-args (_.< arityO)) + (let [all-inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments)))] + ($_ _.then + (_.define @curried all-inputs) + (_.return (_.closure (list) + (let [@missing all-inputs] + (_.return (apply-poly (_.do ".concat" (list @missing) @curried) + @self)))))))) + ))) + )) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux index fe08b6a50..cc2caf056 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux @@ -8,20 +8,22 @@ [text format] [collection - ["." list ("#/." functor)]]]] + ["." list ("#/." functor)]]] + [host + ["_" scheme (#+ Expression Computation Var)]]] [// ["." runtime (#+ Operation Phase)] ["." reference] + ["//." case] ["/." // + [common + ["common-." reference]] ["//." // ("#/." monad) [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] [synthesis (#+ Synthesis)] [// [reference (#+ Register Variable)] - ["." name] - [// - [host - ["_" scheme (#+ Expression Computation Var)]]]]]]]) + ["." name]]]]]) (def: #export (apply translate [functionS argsS+]) (-> Phase (Application Synthesis) (Operation Computation)) @@ -30,18 +32,21 @@ argsO+ (monad.map @ translate argsS+)] (wrap (_.apply/* functionO argsO+)))) +(def: #export capture + (common-reference.foreign _.var)) + (def: (with-closure function-name inits function-definition) (-> Text (List Expression) Computation (Operation Computation)) - (let [@closure (_.var (format function-name "___CLOSURE"))] - (/////wrap - (case inits - #.Nil - function-definition + (/////wrap + (case inits + #.Nil + function-definition - _ + _ + (let [@closure (_.var (format function-name "___CLOSURE"))] (_.letrec (list [@closure (_.lambda [(|> (list.enumerate inits) - (list/map (|>> product.left reference.foreign'))) + (list/map (|>> product.left ..capture))) #.None] function-definition)]) (_.apply/* @closure inits)))))) @@ -50,7 +55,7 @@ (def: @missing (_.var "missing")) (def: input - (|>> inc reference.local')) + (|>> inc //case.register)) (def: #export (function translate [environment arity bodyS]) (-> Phase (Abstraction Synthesis) (Operation Computation)) @@ -60,17 +65,18 @@ [function-name ///.context] (///.with-anchor (_.var function-name) (translate bodyS)))) - closureO+ (monad.map @ reference.variable environment) + closureO+ (: (Operation (List Expression)) + (monad.map @ (:: reference.system variable) environment)) #let [arityO (|> arity .int _.int) - @num-args (_.var "num_args") - @function (_.var function-name) apply-poly (.function (_ args func) - (_.apply/2 (_.global "apply") func args))]] + (_.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 [(reference.local' 0) @function])) + (<| (_.let (list [(//case.register 0) @function])) (_.let-values (list [[(|> (list.indices arity) (list/map ..input)) #.None] @@ -87,6 +93,6 @@ ## (|> @num-args (_. @function - (apply-poly (_.append/2 @curried @missing)))))))]) - @function)) - )) + (apply-poly (_.append/2 @curried @missing))))) + ))]) + @function)))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 89136bb50..4ed7ce96e 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -1,204 +1,202 @@ -(.module: - [lux #* - [cli (#+ program:)] - ["." io (#+ io)] - [control - [monad (#+ do)] - [predicate (#+ Predicate)]] - [data - [number - ["." i64]]] - ["." function] - ["." math - ["r" random (#+ Random) ("#/." functor)]] - ["_" test (#+ Test)] - ## These modules do not need to be tested. - [type - [variance (#+)]] - [locale (#+) - [language (#+)] - [territory (#+)]] - ## TODO: Test these modules - [data - [format - [css (#+)] - [markdown (#+)]]] - [host - [js (#+)] - [scheme (#+)]] - [tool - [compiler - [phase - ## [translation - ## [scheme - ## [runtime (#+)] - ## [primitive (#+)] - ## [structure (#+)] - ## [reference (#+)] - ## [case (#+)]] - ## [js - ## [runtime (#+)] - ## [primitive (#+)] - ## [structure (#+)] - ## [reference (#+)] - ## [case (#+)]]] - ]]] - ## [control - ## ["._" contract] - ## ["._" concatenative] - ## ["._" predicate] - ## [monad - ## ["._" free]]] - ## [data - ## ["._" env] - ## ["._" trace] - ## ["._" store] - ## [format - ## ["._" context] - ## ["._" html] - ## ["._" css] - ## ["._" binary]] - ## [collection - ## [tree - ## [rose - ## ["._" parser]]] - ## [dictionary - ## ["._" plist]] - ## [set - ## ["._" multi]]] - ## [text - ## ["._" buffer]]] - ## ["._" macro - ## [poly - ## ["._" json]]] - ## [type - ## ["._" unit] - ## ["._" refinement] - ## ["._" quotient]] - ## [world - ## ["._" environment] - ## ["._" console]] - ## [compiler - ## ["._" cli] - ## ["._" default - ## ["._" evaluation] - ## [phase - ## ["._" translation - ## [scheme - ## ["._scheme" function] - ## ["._scheme" loop] - ## ["._scheme" case] - ## ["._scheme" extension] - ## ["._scheme" extension/common] - ## ["._scheme" expression]]] - ## [extension - ## ["._" statement]]] - ## ["._default" cache]] - ## [meta - ## ["._meta" io - ## ["._meta_io" context] - ## ["._meta_io" archive]] - ## ["._meta" archive] - ## ["._meta" cache]]] - ## ["._" interpreter - ## ["._interpreter" type]] - ] - ## TODO: Must have 100% coverage on tests. - [/ - ["/." cli] - ["/." io] - ["/." host - ["/." jvm]] - ["/." control]] - ## [control - ## [concurrency - ## [promise (#+)] - ## [stm (#+)] - ## ## [semaphore (#+)] - ## ]] - ## [data - ## [bit (#+)] - ## [color (#+)] - ## [error (#+)] - ## [name (#+)] - ## [identity (#+)] - ## [lazy (#+)] - ## [maybe (#+)] - ## [product (#+)] - ## [sum (#+)] - ## [number (#+) ## TODO: FIX Specially troublesome... - ## [i64 (#+)] - ## [ratio (#+)] - ## [complex (#+)]] - ## [text (#+) - ## ## [format (#+)] - ## [lexer (#+)] - ## [regex (#+)]] - ## [format - ## ## [json (#+)] - ## [xml (#+)]] - ## ## [collection - ## ## [array (#+)] - ## ## [bits (#+)] - ## ## [list (#+)] - ## ## [stack (#+)] - ## ## [row (#+)] - ## ## [sequence (#+)] - ## ## [dictionary (#+) - ## ## ["dictionary_." ordered]] - ## ## [set (#+) - ## ## ["set_." ordered]] - ## ## [queue (#+) - ## ## [priority (#+)]] - ## ## [tree - ## ## [rose (#+) - ## ## [zipper (#+)]]]] - ## ] - ## [math (#+) - ## [random (#+)] - ## [modular (#+)] - ## [logic - ## [continuous (#+)] - ## [fuzzy (#+)]]] - ## [macro - ## [code (#+)] - ## [syntax (#+)] - ## [poly - ## ["poly_." equivalence] - ## ["poly_." functor]]] - ## [type ## (#+) - ## ## [check (#+)] - ## ## [implicit (#+)] ## TODO: FIX Specially troublesome... - ## ## [resource (#+)] - ## [dynamic (#+)]] - ## [time - ## [instant (#+)] - ## [duration (#+)] - ## [date (#+)]] - ## [compiler - ## [default - ## ["_default/." syntax] - ## [phase - ## [analysis - ## ["_.A" primitive] - ## ["_.A" structure] - ## ["_.A" reference] - ## ["_.A" case] - ## ["_.A" function] - ## [procedure - ## ["_.A" common]]] - ## [synthesis - ## ["_.S" primitive] - ## ["_.S" structure] - ## ["_.S" case] - ## ["_.S" function]]]]] - ## [world - ## [binary (#+)] - ## [file (#+)] - ## [net - ## [tcp (#+)] - ## [udp (#+)]]] - ) +(.with-expansions [ (.as-is [runtime (#+)] + [primitive (#+)] + [structure (#+)] + [reference (#+)] + [case (#+)] + [loop (#+)] + [function (#+)])] + (.module: + [lux #* + [cli (#+ program:)] + ["." io (#+ io)] + [control + [monad (#+ do)] + [predicate (#+ Predicate)]] + [data + [number + ["." i64]]] + ["." function] + ["." math + ["r" random (#+ Random) ("#/." functor)]] + ["_" test (#+ Test)] + ## These modules do not need to be tested. + [type + [variance (#+)]] + [locale (#+) + [language (#+)] + [territory (#+)]] + ## TODO: Test these modules + [data + [format + [css (#+)] + [markdown (#+)]]] + [host + [js (#+)] + [scheme (#+)]] + [tool + [compiler + [phase + [translation + [scheme + ] + [js + ]]]]] + ## [control + ## ["._" contract] + ## ["._" concatenative] + ## ["._" predicate] + ## [monad + ## ["._" free]]] + ## [data + ## ["._" env] + ## ["._" trace] + ## ["._" store] + ## [format + ## ["._" context] + ## ["._" html] + ## ["._" css] + ## ["._" binary]] + ## [collection + ## [tree + ## [rose + ## ["._" parser]]] + ## [dictionary + ## ["._" plist]] + ## [set + ## ["._" multi]]] + ## [text + ## ["._" buffer]]] + ## ["._" macro + ## [poly + ## ["._" json]]] + ## [type + ## ["._" unit] + ## ["._" refinement] + ## ["._" quotient]] + ## [world + ## ["._" environment] + ## ["._" console]] + ## [compiler + ## ["._" cli] + ## ["._" default + ## ["._" evaluation] + ## [phase + ## ["._" translation + ## [scheme + ## ["._scheme" function] + ## ["._scheme" loop] + ## ["._scheme" case] + ## ["._scheme" extension] + ## ["._scheme" extension/common] + ## ["._scheme" expression]]] + ## [extension + ## ["._" statement]]] + ## ["._default" cache]] + ## [meta + ## ["._meta" io + ## ["._meta_io" context] + ## ["._meta_io" archive]] + ## ["._meta" archive] + ## ["._meta" cache]]] + ## ["._" interpreter + ## ["._interpreter" type]] + ] + ## TODO: Must have 100% coverage on tests. + [/ + ["/." cli] + ["/." io] + ["/." host + ["/." jvm]] + ["/." control]] + ## [control + ## [concurrency + ## [promise (#+)] + ## [stm (#+)] + ## ## [semaphore (#+)] + ## ]] + ## [data + ## [bit (#+)] + ## [color (#+)] + ## [error (#+)] + ## [name (#+)] + ## [identity (#+)] + ## [lazy (#+)] + ## [maybe (#+)] + ## [product (#+)] + ## [sum (#+)] + ## [number (#+) ## TODO: FIX Specially troublesome... + ## [i64 (#+)] + ## [ratio (#+)] + ## [complex (#+)]] + ## [text (#+) + ## ## [format (#+)] + ## [lexer (#+)] + ## [regex (#+)]] + ## [format + ## ## [json (#+)] + ## [xml (#+)]] + ## ## [collection + ## ## [array (#+)] + ## ## [bits (#+)] + ## ## [list (#+)] + ## ## [stack (#+)] + ## ## [row (#+)] + ## ## [sequence (#+)] + ## ## [dictionary (#+) + ## ## ["dictionary_." ordered]] + ## ## [set (#+) + ## ## ["set_." ordered]] + ## ## [queue (#+) + ## ## [priority (#+)]] + ## ## [tree + ## ## [rose (#+) + ## ## [zipper (#+)]]]] + ## ] + ## [math (#+) + ## [random (#+)] + ## [modular (#+)] + ## [logic + ## [continuous (#+)] + ## [fuzzy (#+)]]] + ## [macro + ## [code (#+)] + ## [syntax (#+)] + ## [poly + ## ["poly_." equivalence] + ## ["poly_." functor]]] + ## [type ## (#+) + ## ## [check (#+)] + ## ## [implicit (#+)] ## TODO: FIX Specially troublesome... + ## ## [resource (#+)] + ## [dynamic (#+)]] + ## [time + ## [instant (#+)] + ## [duration (#+)] + ## [date (#+)]] + ## [compiler + ## [default + ## ["_default/." syntax] + ## [phase + ## [analysis + ## ["_.A" primitive] + ## ["_.A" structure] + ## ["_.A" reference] + ## ["_.A" case] + ## ["_.A" function] + ## [procedure + ## ["_.A" common]]] + ## [synthesis + ## ["_.S" primitive] + ## ["_.S" structure] + ## ["_.S" case] + ## ["_.S" function]]]]] + ## [world + ## [binary (#+)] + ## [file (#+)] + ## [net + ## [tcp (#+)] + ## [udp (#+)]]] + )) (def: identity Test -- cgit v1.2.3