diff options
Diffstat (limited to 'stdlib')
9 files changed, 472 insertions, 323 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 1bb7efa07..b2deead45 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1559,7 +1559,7 @@ ({(#Left msg) (#Left msg) - (#Right state' a) + (#Right [state' a]) (f a state')} (ma state))))}) @@ -2205,7 +2205,7 @@ 1 "1" 2 "2" 3 "3" 4 "4" 5 "5" 6 "6" 7 "7" 8 "8" 9 "9" - _ ("lux io error" "undefined")} + _ ("lux io error" "@digit::format Undefined behavior.")} digit)) (def:''' (nat\encode value) @@ -2700,7 +2700,7 @@ (int\encode value) [_ (#Rev value)] - ("lux io error" "Undefined behavior.") + ("lux io error" "@code\encode Undefined behavior.") [_ (#Frac value)] (frac\encode value) @@ -4943,7 +4943,7 @@ [#Record "{" "}" rejoin_all_pairs]) [new_location (#Rev value)] - ("lux io error" "Undefined behavior.") + ("lux io error" "@doc_example->Text Undefined behavior.") )) (def: (with_baseline baseline [file line column]) @@ -5510,6 +5510,12 @@ _ (fail (..wrong_syntax_error (name_of ..:assume))))) +(def: location + {#.doc "The location of the current expression being analyzed."} + (Meta Location) + (function (_ compiler) + (#Right [compiler (get@ #location compiler)]))) + (macro: #export (undefined tokens) {#.doc (doc "Meant to be used as a stand-in for functions with undefined implementations." "Undefined expressions will type-check against everything, so they make good dummy implementations." @@ -5519,7 +5525,12 @@ (undefined)))} (case tokens #Nil - (return (list (` (..error! "Undefined behavior.")))) + (do meta_monad + [location ..location + #let [[module line column] location + location ($_ "lux text concat" (text\encode module) "," (nat\encode line) "," (nat\encode column)) + message ($_ "lux text concat" "Undefined behavior @ " location)]] + (wrap (list (` (..error! (~ (text$ message))))))) _ (fail (..wrong_syntax_error (name_of ..undefined))))) diff --git a/stdlib/source/lux/target/php.lux b/stdlib/source/lux/target/php.lux index 4cb2f0602..1b1b91e88 100644 --- a/stdlib/source/lux/target/php.lux +++ b/stdlib/source/lux/target/php.lux @@ -2,17 +2,26 @@ [lux (#- Location Code Global static int if cond or and not comment for) ["@" target] ["." host] + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + ["." enum]] [control - [pipe (#+ case> cond> new>)]] + [pipe (#+ case> cond> new>)] + [parser + ["<.>" code]]] [data ["." text ["%" format (#+ format)]] [collection ["." list ("#\." functor fold)]]] [macro - ["." template]] + [syntax (#+ syntax:)] + ["." template] + ["." code]] [math [number + ["n" nat] ["f" frac]]] [type abstract]]) @@ -47,6 +56,18 @@ (abstract: #export (Code brand) Text + (structure: #export equivalence + (All [brand] (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (structure: #export hash + (All [brand] (Hash (Code brand))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + (def: #export manual (-> Text Code) (|>> :abstraction)) @@ -154,8 +175,13 @@ (def: #export (apply/* args func) (-> (List Expression) Expression Computation) - (:abstraction - (format (:representation func) (..arguments args)))) + (|> (format (:representation func) (..arguments args)) + :abstraction)) + + ## TODO: Remove when no longer using JPHP. + (def: #export (apply/*' args func) + (-> (List Expression) Expression Computation) + (apply/* (list& func args) (..constant "call_user_func"))) (def: parameters (-> (List Argument) Text) @@ -189,47 +215,72 @@ ..group :abstraction))) - (template [<apply> <input_var>+ <input_type>+ <function>+] - [(`` (def: #export (<apply> [(~~ (template.splice <input_var>+))] function) - (-> [(~~ (template.splice <input_type>+))] Expression Computation) - (..apply/* (list (~~ (template.splice <input_var>+))) function))) - - (`` (template [<lux_name> <php_name>] - [(def: #export (<lux_name> args) - (-> [(~~ (template.splice <input_type>+))] Computation) - (<apply> args (..constant <php_name>)))] - - (~~ (template.splice <function>+))))] - - [apply/0 [] [] - [[func_num_args/0 "func_num_args"] - [func_get_args/0 "func_get_args"] - [time/0 "time"]]] - [apply/1 [in0] [Expression] - [[is_null/1 "is_null"] - [empty/1 "empty"] - [count/1 "count"] - [strlen/1 "strlen"] - [array_pop/1 "array_pop"] - [array_reverse/1 "array_reverse"] - [intval/1 "intval"] - [floatval/1 "floatval"] - [strval/1 "strval"] - [ord/1 "ord"] - [chr/1 "chr"] - [print/1 "print"] - [exit/1 "exit"]]] - [apply/2 [in0 in1] [Expression Expression] - [[call_user_func_array/2 "call_user_func_array"] - [array_slice/2 "array_slice"] - [array_push/2 "array_push"]]] - [apply/3 [in0 in1 in2] [Expression Expression Expression] - [[array_slice/3 "array_slice"] - [array_splice/3 "array_splice"] - [strpos/3 "strpos"] - [substr/3 "substr"]]] + (syntax: (arity_inputs {arity <code>.nat}) + (wrap (case arity + 0 (.list) + _ (|> (dec arity) + (enum.range n.enum 0) + (list\map (|>> %.nat code.local_identifier)))))) + + (syntax: (arity_types {arity <code>.nat}) + (wrap (list.repeat arity (` ..Expression)))) + + (template [<arity> <function>+] + [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) + <inputs> (arity_inputs <arity>) + <types> (arity_types <arity>) + <definitions> (template.splice <function>+)] + (def: #export (<apply> function [<inputs>]) + (-> Expression [<types>] Computation) + (..apply/* (.list <inputs>) function)) + + (template [<function>] + [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) + (<apply> (..constant <function>))))] + + <definitions>))] + + [0 + [["func_num_args"] + ["func_get_args"] + ["time"] + ["phpversion"]]] + + [1 + [["is_null"] + ["empty"] + ["count"] + ["array_pop"] + ["array_reverse"] + ["intval"] + ["floatval"] + ["strval"] + ["ord"] + ["chr"] + ["print"] + ["exit"] + ["iconv_strlen"] ["strlen"]]] + + [2 + [["call_user_func_array"] + ["array_slice"] + ["array_push"] + ["pack"] + ["unpack"] + ["iconv_strpos"] ["strpos"]]] + + [3 + [["array_slice"] + ["array_splice"] + ["iconv"] + ["iconv_strpos"] ["strpos"] + ["iconv_substr"] ["substr"]]] ) + (def: #export (key_value key value) + (-> Expression Expression Expression) + (:abstraction (format (:representation key) " => " (:representation value)))) + (def: #export (array/* values) (-> (List Expression) Literal) (|> values @@ -274,9 +325,9 @@ (def: #export (? test then else) (-> Expression Expression Expression Computation) - (|> (format (:representation test) " ? " - (:representation then) " : " - (:representation else)) + (|> (format (..group (:representation test)) " ? " + (..group (:representation then)) " : " + (..group (:representation else))) ..group :abstraction)) @@ -343,7 +394,7 @@ (def: #export (if test then! else!) (-> Expression Statement Statement Statement) (:abstraction - (format "if " (..group (:representation test)) " " + (format "if" (..group (:representation test)) " " (..block (:representation then!)) " else " (..block (:representation else!))))) @@ -351,7 +402,7 @@ (def: #export (when test then!) (-> Expression Statement Statement) (:abstraction - (format "if " (..group (:representation test)) " " + (format "if" (..group (:representation test)) " " (..block (:representation then!))))) (def: #export (then pre! post!) @@ -364,14 +415,14 @@ (def: #export (while test body!) (-> Expression Statement Statement) (:abstraction - (format "while " (..group (:representation test)) " " + (format "while" (..group (:representation test)) " " (..block (:representation body!))))) (def: #export (do_while test body!) (-> Expression Statement Statement) (:abstraction (format "do " (..block (:representation body!)) - " while " (..group (:representation test)) + " while" (..group (:representation test)) ..statement_suffix))) (def: #export (for_each array value body!) @@ -414,15 +465,15 @@ (def: #export (define name value) (-> Constant Expression Expression) - (..apply/2 [(|> name :representation ..string) - value] - (..constant "define"))) + (..apply/2 (..constant "define") + [(|> name :representation ..string) + value])) (def: #export (define_function name arguments body!) (-> Constant (List Argument) Statement Statement) (:abstraction (format "function " (:representation name) - " " (..parameters arguments) + (..parameters arguments) " " (..block (:representation body!))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux index ab2f480fe..572f1f2a8 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux @@ -47,8 +47,8 @@ (#try.Failure error) (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) -## (template: (!unary function) -## (|>> list _.apply/* (|> (_.var function)))) +(template: (!unary function) + (|>> list _.apply/* (|> (_.constant function)))) ## ## TODO: Get rid of this ASAP ## (def: lux::syntax_char_case! @@ -83,103 +83,98 @@ ## conditionalsG))]] ## (wrap (_.apply/1 closure inputG))))])) -## (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: lux_procs + Bundle + (|> /.empty + ## (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurry _.=))) + ## (/.install "try" (unary //runtime.lux//try)) + )) -## (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 (product.uncurry //runtime.i64//left_shift))) -## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) -## (/.install "=" (binary (product.uncurry _.=))) -## (/.install "+" (binary (product.uncurry _.+))) -## (/.install "-" (binary (product.uncurry _.-))) -## (/.install "<" (binary (product.uncurry _.<))) -## (/.install "*" (binary (product.uncurry _.*))) -## (/.install "/" (binary (product.uncurry //runtime.i64//division))) -## (/.install "%" (binary (product.uncurry //runtime.i64//remainder))) -## (/.install "f64" (unary (_./ (_.float +1.0)))) -## (/.install "char" (unary (_.apply/1 (_.var "utf8.char")))) -## ))) +(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 (product.uncurry _.bit_shl))) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + (/.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 (product.uncurry _.%))) + (/.install "f64" (unary (_./ (_.float +1.0)))) + (/.install "char" (unary //runtime.i64//char)) + ))) -## (def: f64//decode -## (Unary Expression) -## (|>> list _.apply/* (|> (_.var "tonumber")) _.return (_.closure (list)) //runtime.lux//try)) +(def: (f64//% [parameter subject]) + (Binary Expression) + (_./ (_.float +1.0) (_.% parameter subject))) -## (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 (function.flip (_.apply/2 (_.var "math.fmod")))))) -## (/.install "=" (binary (product.uncurry _.=))) -## (/.install "<" (binary (product.uncurry _.<))) -## (/.install "i64" (unary (!unary "math.floor"))) -## (/.install "encode" (unary (_.apply/2 (_.var "string.format") (_.string "%.17g")))) -## (/.install "decode" (unary ..f64//decode))))) +(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 ..f64//%)) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "i64" (unary _.intval/1)) + (/.install "encode" (unary _.strval/1)) + (/.install "decode" (unary //runtime.f64//decode))))) -## (def: (text//char [paramO subjectO]) -## (Binary Expression) -## (//runtime.text//char (_.+ (_.int +1) paramO) subjectO)) +(def: (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip paramO extraO subjectO)) -## (def: (text//clip [paramO extraO subjectO]) -## (Trinary Expression) -## (//runtime.text//clip subjectO paramO extraO)) +(def: (text//index [startO partO textO]) + (Trinary Expression) + (//runtime.text//index textO partO startO)) -## (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: 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)) -## ## TODO: Use version below once the Lua compiler becomes self-hosted. -## ## (/.install "size" (unary (for {@.lua (!unary "utf8.len")} -## ## (!unary "string.len")))) -## (/.install "char" (binary ..text//char)) -## (/.install "clip" (trinary ..text//clip)) -## ))) +(def: io//log! + (Unary Expression) + (|>> _.print/1 + (_.or //runtime.unit))) -## (def: (io//log! messageO) -## (Unary Expression) -## (|> (_.apply/* (list messageO) (_.var "print")) -## (_.or //runtime.unit))) +(def: io//current-time + (Nullary Expression) + (|>> _.time/0 + (_.* (_.int +1,000)))) -## (def: io_procs -## Bundle -## (<| (/.prefix "io") -## (|> /.empty -## (/.install "log" (unary ..io//log!)) -## (/.install "error" (unary (!unary "error"))) -## (/.install "current-time" (nullary (function.constant (|> (_.var "os.time") -## (_.apply/* (list)) -## (_.* (_.int +1,000))))))))) +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary //runtime.io//throw!)) + (/.install "current-time" (nullary ..io//current-time))))) (def: #export bundle Bundle (<| (/.prefix "lux") - /.empty - ## (|> lux_procs - ## (dictionary.merge i64_procs) - ## (dictionary.merge f64_procs) - ## (dictionary.merge text_procs) - ## (dictionary.merge io_procs) - ## ) - )) + (|> /.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/ruby/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux index 50eddb998..39ba71730 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux @@ -159,8 +159,8 @@ (def: (io//log! messageG) (Unary Expression) - (_.or //runtime.unit - (_.print/2 messageG (_.string text.new_line)))) + (|> (_.print/2 messageG (_.string text.new_line)) + (_.or //runtime.unit))) (def: io//error! (Unary Expression) 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 e129af245..b04d8e766 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 @@ -231,46 +231,43 @@ (def: (pattern_matching generate archive pathP) (-> Phase Archive Path (Operation Statement)) (do ///////phase.monad - [pattern_matching! (pattern_matching' generate archive pathP)] + [iteration! (pattern_matching' generate archive pathP)] (wrap ($_ _.then (_.do_while (_.bool false) - pattern_matching!) + iteration!) (_.throw (_.new (_.constant "Exception") (list (_.string ////synthesis/case.pattern_matching_error)))))))) (def: (gensym prefix) (-> Text (Operation Text)) (\ ///////phase.monad map (|>> %.nat (format prefix)) /////generation.next)) +(def: #export dependencies + (-> Path (List Var)) + (|>> ////synthesis/case.storage + (get@ #////synthesis/case.dependencies) + set.to_list + (list\map (function (_ variable) + (.case variable + (#///////variable.Local register) + (..register register) + + (#///////variable.Foreign register) + (..capture register)))))) + (def: #export (case generate archive [valueS pathP]) (Generator [Synthesis Path]) (do {! ///////phase.monad} [initG (generate archive valueS) - pattern_matching! (pattern_matching generate archive pathP) - @case (..gensym "case") - #let [@caseG (_.global @case) - @caseL (_.var @case)] - @init (\ ! map _.var (..gensym "init")) - #let [@dependencies+ (|> (////synthesis/case.storage pathP) - (get@ #////synthesis/case.dependencies) - set.to_list - (list\map (function (_ variable) - [false (.case variable - (#///////variable.Local register) - (..register register) - - (#///////variable.Foreign register) - (..capture register))])))] - #let [directive ($_ _.then - (<| _.; - (_.set @caseL) - (_.closure (list (_.reference @caseL)) (list& [#0 @init] - @dependencies+)) - ($_ _.then - (_.; (_.set @cursor (_.array/* (list @init)))) - (_.; (_.set @savepoint (_.array/* (list)))) - pattern_matching!)) - (_.; (_.set @caseG @caseL)))] + [[case_module case_artifact] pattern_matching!] (/////generation.with_new_context archive + (pattern_matching generate archive pathP)) + #let [@case (_.constant (///reference.artifact [case_module case_artifact])) + @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) + pathP)) + directive (<| (_.define_function @case (list\map _.parameter @dependencies+)) + ($_ _.then + (_.; (_.set @cursor (_.array/* (list initG)))) + (_.; (_.set @savepoint (_.array/* (list)))) + pattern_matching!))] _ (/////generation.execute! directive) - _ (/////generation.save! @case directive)] - (wrap (_.apply/* (list& initG (list\map product.right @dependencies+)) - @caseG)))) + _ (/////generation.save! (%.nat case_artifact) directive)] + (wrap (_.apply/* @dependencies+ @case)))) 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 718ee1e79..66d9eb37d 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 @@ -33,7 +33,7 @@ (do {! ///////phase.monad} [functionG (expression archive functionS) argsG+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* argsG+ functionG)))) + (wrap (_.apply/*' argsG+ functionG)))) (def: capture (-> Register Var) @@ -69,7 +69,7 @@ (do ! [function_name (\ ! map ///reference.artifact (/////generation.context archive))] - (/////generation.with_anchor (_.var function_name) + (/////generation.with_anchor (_.global function_name) (expression archive bodyS)))) closureG+ (monad.map ! (expression archive) environment) #let [@curried (_.var "curried") @@ -86,10 +86,7 @@ (list.indices arity))] #let [[definition instantiation] (..with_closure closureG+ @selfG @selfL ($_ _.then - (_.echo (_.string "'ello, world! ")) (_.; (_.set @num_args (_.func_num_args/0 []))) - (_.echo @num_args) (_.echo (_.string " ~ ")) (_.echo arityG) - (_.echo (_.string text.new_line)) (_.; (_.set @curried (_.func_get_args/0 []))) (_.cond (list [(|> @num_args (_.= arityG)) ($_ _.then @@ -98,25 +95,13 @@ [(|> @num_args (_.> arityG)) (let [arity_inputs (_.array_slice/3 [@curried (_.int +0) arityG]) extra_inputs (_.array_slice/2 [@curried arityG]) - next (_.call_user_func_array/2 [@selfL arity_inputs]) - done (_.call_user_func_array/2 [next extra_inputs])] - ($_ _.then - (_.echo (_.string "STAGED ")) (_.echo (_.count/1 arity_inputs)) - (_.echo (_.string " + ")) (_.echo (_.count/1 extra_inputs)) - (_.echo (_.string text.new_line)) - (_.echo (_.string "@selfL ")) (_.echo @selfL) (_.echo (_.string text.new_line)) - (_.echo (_.string " next ")) (_.echo next) (_.echo (_.string text.new_line)) - (_.echo (_.string " done ")) (_.echo done) (_.echo (_.string text.new_line)) - (_.return done)))]) + next (_.call_user_func_array/2 [@selfL arity_inputs])] + (_.return (_.call_user_func_array/2 [next extra_inputs])))]) ## (|> @num_args (_.< arityG)) (let [@missing (_.var "missing")] (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list)) ($_ _.then (_.; (_.set @missing (_.func_get_args/0 []))) - (_.echo (_.string "NEXT ")) (_.echo (_.count/1 @curried)) - (_.echo (_.string " ")) (_.echo (_.count/1 @missing)) - (_.echo (_.string " ")) (_.echo (_.count/1 (_.array_merge/+ @curried (list @missing)))) - (_.echo (_.string text.new_line)) (_.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 1bc853e64..cdac65275 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 @@ -19,41 +19,69 @@ ["#." case] ["/#" // #_ ["#." reference] - ["//#" /// #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]) + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) -(def: #export (scope generate archive [start initsS+ bodyS]) +(def: #export (scope expression archive [start initsS+ bodyS]) (Generator (Scope Synthesis)) - (do {! ///////phase.monad} - [@loop (\ ! map (|>> %.nat (format "loop")) /////generation.next) - #let [@loopG (_.global @loop) - @loopL (_.var @loop)] - initsO+ (monad.map ! (generate archive) initsS+) - bodyO (/////generation.with_anchor @loopL - (generate archive bodyS)) - #let [directive ($_ _.then - (<| _.; - (_.set @loopL) - (_.closure (list (_.reference @loopL)) - (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register [#0]))) - (_.return bodyO))) - (_.; (_.set @loopG @loopL)))] - _ (/////generation.execute! directive) - _ (/////generation.save! @loop directive)] - (wrap (_.apply/* initsO+ @loopG)))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [initsO+ (monad.map ! (expression archive) initsS+) + [[loop_module loop_artifact] bodyO] (/////generation.with_new_context archive + (do ! + [loop_context (/////generation.context archive)] + (/////generation.with_anchor (_.var (///reference.artifact loop_context)) + (expression archive bodyS)))) + #let [locals (|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register _.parameter))) + [directive instantiation] (: [Statement Expression] + (case (|> (synthesis.path/then bodyS) + //case.dependencies + (set.from_list _.hash) + (set.difference (set.from_list _.hash (list\map product.right locals))) + set.to_list) + #.Nil + (let [@loop (_.var (///reference.artifact [loop_module loop_artifact]))] + [(_.; (_.set @loop + (_.closure (list (_.reference @loop)) + locals + (_.return bodyO)))) + @loop]) + + foreigns + (let [@loop (_.constant (///reference.artifact [loop_module loop_artifact]))] + [(<| (_.define_function @loop (list\map _.parameter foreigns)) + (let [@loop (_.var (///reference.artifact [loop_module loop_artifact]))] + (_.return (_.set @loop + (_.closure (list& (_.reference @loop) + (list\map _.reference foreigns)) + locals + (_.return bodyO)))))) + (_.apply/* foreigns @loop)])))] + _ (/////generation.execute! directive) + _ (/////generation.save! (%.nat loop_artifact) directive)] + (wrap (_.apply/* initsO+ instantiation))))) -(def: #export (recur generate archive argsS+) +(def: #export (recur expression archive argsS+) (Generator (List Synthesis)) (do {! ///////phase.monad} [@scope /////generation.anchor - argsO+ (monad.map ! (generate archive) argsS+)] + argsO+ (monad.map ! (expression archive) argsS+)] (wrap (_.apply/* argsO+ @scope)))) 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 3a50bba43..7b3e55481 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 @@ -38,7 +38,7 @@ (template [<name> <base>] [(type: #export <name> - (<base> Var Expression Statement))] + (<base> Location Expression Statement))] [Operation /////generation.Operation] [Phase /////generation.Phase] @@ -67,38 +67,6 @@ ..unit _.null)) -(def: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export variant_value_field "_lux_value") - -(def: (variant' tag last? value) - (-> Expression Expression Expression Literal) - (_.array/** (list [(_.string ..variant_tag_field) tag] - [(_.string ..variant_flag_field) last?] - [(_.string ..variant_value_field) value]))) - -(def: #export (variant tag last? value) - (-> Nat Bit Expression Literal) - (variant' (_.int (.int tag)) - (..flag last?) - value)) - -(def: #export none - Literal - (..variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Literal) - (..variant 1 #1)) - -(def: #export left - (-> Expression Literal) - (..variant 0 #0)) - -(def: #export right - (-> Expression Literal) - (..variant 1 #1)) - (def: (feature name definition) (-> Constant (-> Constant Statement) Statement) (definition name)) @@ -158,32 +126,7 @@ (..with_vars [(~+ inputsC)] (_.define_function (~ g!_) (list (~+ (list\map (|>> (~) [false] (`)) inputsC))) - (~ code)))))))))))))))) - -(runtime: (lux//try op) - (with_vars [value] - (_.try ($_ _.then - (_.; (_.set value (_.apply/1 [..unit] op))) - (_.return (..right value))) - (list (with_vars [error] - {#_.class (_.constant "Exception") - #_.exception error - #_.handler (_.return (..left (_.do "getMessage" (list) error)))}))))) - -(runtime: (lux//program_args inputs) - (with_vars [head tail] - ($_ _.then - (_.; (_.set tail ..none)) - (<| (_.for_each (_.array_reverse/1 inputs) head) - (_.; (_.set tail (..some (_.array/* (list head tail)))))) - (_.return tail)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program_args - )) + (~ code)))))))))))))))) (runtime: (io//throw! message) ($_ _.then @@ -196,8 +139,11 @@ @io//throw! )) +(def: #export tuple_size_field + "_lux_size") + (def: tuple_size - _.count/1) + (_.nth (_.string ..tuple_size_field))) (def: last_index (|>> ..tuple_size (_.- (_.int +1)))) @@ -205,6 +151,11 @@ (with_expansions [<recur> (as_is ($_ _.then (_.; (_.set lefts (_.- last_index_right lefts))) (_.; (_.set tuple (_.nth last_index_right tuple)))))] + (runtime: (tuple//make size values) + ($_ _.then + (_.; (_.set (..tuple_size values) size)) + (_.return values))) + (runtime: (tuple//left lefts tuple) (with_vars [last_index_right] (<| (_.while (_.bool true)) @@ -227,9 +178,42 @@ [(_.> last_index_right right_index) ## Needs recursion. <recur>]) - (_.return (_.array_slice/2 [tuple right_index]))) + ($_ _.then + (_.echo (_.string (format "[tuple//right] _.array_slice/2" text.new_line))) + (_.return (_.array_slice/2 [tuple right_index])))) ))))) +(def: #export variant_tag_field "_lux_tag") +(def: #export variant_flag_field "_lux_flag") +(def: #export variant_value_field "_lux_value") + +(runtime: (sum//make tag last? value) + (_.return (_.array/** (list [(_.string ..variant_tag_field) tag] + [(_.string ..variant_flag_field) last?] + [(_.string ..variant_value_field) value])))) + +(def: #export (variant tag last? value) + (-> Nat Bit Expression Computation) + (sum//make (_.int (.int tag)) + (..flag last?) + value)) + +(def: #export none + Computation + (..variant 0 #0 ..unit)) + +(def: #export some + (-> Expression Computation) + (..variant 1 #1)) + +(def: #export left + (-> Expression Computation) + (..variant 0 #0)) + +(def: #export right + (-> Expression Computation) + (..variant 1 #1)) + (runtime: (sum//get sum wantsLast wantedTag) (let [no_match! (_.return _.null) sum_tag (_.nth (_.string ..variant_tag_field) sum) @@ -238,83 +222,178 @@ ## sum_flag (_.nth (_.int +1) sum) sum_value (_.nth (_.string ..variant_value_field) sum) ## sum_value (_.nth (_.int +2) sum) - is_last? (_.= (_.string "") sum_flag) + is_last? (_.= ..unit sum_flag) test_recursion! (_.if is_last? ## Must recurse. - (_.return (sum//get sum_value wantsLast (_.- sum_tag wantedTag))) + ($_ _.then + (_.; (_.set wantedTag (_.- sum_tag wantedTag))) + (_.; (_.set sum sum_value))) no_match!)] - ($_ _.then - (_.echo (_.string "sum//get ")) (_.echo (_.count/1 sum)) - (_.echo (_.string " ")) (_.echo (_.apply/1 [sum] (_.constant "gettype"))) - (_.echo (_.string " ")) (_.echo sum_tag) - (_.echo (_.string " ")) (_.echo wantedTag) - (_.echo (_.string text.new_line)) + (<| (_.while (_.bool true)) (_.cond (list [(_.= sum_tag wantedTag) (_.if (_.= wantsLast sum_flag) (_.return sum_value) test_recursion!)] - [(_.> sum_tag wantedTag) + [(_.< wantedTag sum_tag) test_recursion!] - [(_.and (_.< sum_tag wantedTag) - (_.= (_.string "") wantsLast)) - (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) - no_match!) - ))) + [(_.= ..unit wantsLast) + (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))]) + no_match!)))) (def: runtime//adt Statement ($_ _.then + @tuple//make @tuple//left @tuple//right + @sum//make @sum//get )) -(runtime: (i64//logic_right_shift param subject) +(runtime: (lux//try op) + (with_vars [value] + (_.try ($_ _.then + (_.; (_.set value (_.apply/1 op [..unit]))) + (_.return (..right value))) + (list (with_vars [error] + {#_.class (_.constant "Exception") + #_.exception error + #_.handler (_.return (..left (_.do "getMessage" (list) error)))}))))) + +(runtime: (lux//program_args inputs) + (with_vars [head tail] + ($_ _.then + (_.; (_.set tail ..none)) + (<| (_.for_each (_.array_reverse/1 inputs) head) + (_.; (_.set tail (..some (_.array/* (list head tail)))))) + (_.return tail)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program_args + )) + +(runtime: (i64//right_shift param subject) (let [mask (|> (_.int +1) (_.bit_shl (_.- param (_.int +64))) (_.- (_.int +1)))] (_.return (|> subject - (_.bit_shr param) - (_.bit_and mask))))) + (_.bit_and mask) + (_.bit_shr param))))) + +(def: jphp? + (_.= (_.string "5.6.99") (_.phpversion/0 []))) + +(runtime: (i64//char code) + (_.if ..jphp? + (_.return (_.chr/1 [code])) + (_.return (|> code + [(_.string "V")] + _.pack/2 + [(_.string "UTF-32LE") (_.string "UTF-8")] + _.iconv/3)))) (def: runtime//i64 Statement ($_ _.then - @i64//logic_right_shift + @i64//right_shift + @i64//char )) +(runtime: (text//size value) + (_.if ..jphp? + (_.return (_.strlen/1 [value])) + (_.return (_.iconv_strlen/1 [value])))) + (runtime: (text//index subject param start) (with_vars [idx] - ($_ _.then - (_.; (_.set idx (_.strpos/3 [subject param start]))) - (_.if (_.= (_.bool false) idx) - (_.return ..none) - (_.return (..some idx)))))) + (_.if ..jphp? + ($_ _.then + (_.; (_.set idx (_.strpos/3 [subject param start]))) + (_.if (_.= (_.bool false) idx) + (_.return ..none) + (_.return (..some idx)))) + ($_ _.then + (_.; (_.set idx (_.iconv_strpos/3 [subject param start]))) + (_.if (_.= (_.bool false) idx) + (_.return ..none) + (_.return (..some idx))))))) + +(def: (within? top value) + (-> Expression Expression Computation) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) + +(runtime: (text//clip offset length text) + (_.if ..jphp? + (_.return (_.substr/3 [text offset length])) + (_.return (_.iconv_substr/3 [text offset length])))) + +(runtime: (text//char idx text) + (_.if (|> idx (within? (text//size text))) + (let [code_point (: (-> Expression Computation) + (|>> [(_.string "UTF-8") (_.string "UTF-32LE")] + _.iconv/3 + [(_.string "V")] + _.unpack/2 + (_.nth (_.int +1))))] + (_.if ..jphp? + (_.return (code_point (_.substr/3 [text idx (_.int +1)]))) + (_.return (code_point (_.iconv_substr/3 [text idx (_.int +1)]))))) + (_.throw (_.new (_.constant "Exception") (list (_.string "[Lux Error] Cannot get char from text.")))))) (def: runtime//text Statement ($_ _.then + @text//size @text//index + @text//clip + @text//char + )) + +(runtime: (f64//decode value) + (with_vars [output] + ($_ _.then + (_.; (_.set output (_.floatval/1 value))) + (_.if (_.= (_.float +0.0) output) + (_.if ($_ _.or + (_.= (_.string "0.0") output) + (_.= (_.string "+0.0") output) + (_.= (_.string "-0.0") output) + (_.= (_.string "0") output) + (_.= (_.string "+0") output) + (_.= (_.string "-0") output)) + (_.return (..some output)) + (_.return ..none)) + (_.return (..some output))) + ))) + +(def: runtime//f64 + Statement + ($_ _.then + @f64//decode )) (def: check_necessary_conditions! Statement - (let [condition (_.= (_.int +8) - (_.constant "PHP_INT_SIZE")) - error_message (_.string (format "Cannot run program!" text.new_line - "Lux/PHP programs require 64-bit PHP builds!"))] - (_.when (_.not condition) - (_.throw (_.new (_.constant "Exception") (list error_message)))))) + (let [i64_support? (_.= (_.int +8) (_.constant "PHP_INT_SIZE")) + i64_error (_.string (format "Cannot run program!" text.new_line + "Lux/PHP programs require 64-bit PHP builds!"))] + (_.when (_.not i64_support?) + (_.throw (_.new (_.constant "Exception") (list i64_error)))))) (def: runtime Statement ($_ _.then check_necessary_conditions! - runtime//lux runtime//adt + runtime//lux runtime//i64 + runtime//f64 runtime//text runtime//io )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux index 5f4d3fbd1..bd1db66bf 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux @@ -20,14 +20,17 @@ (for {## In the case of Lua, there is a limit of 200 locals in a function's scope. @.lua (not ("lua script universe")) ## Cannot make all definitions be local variables because of limitations with JRuby. - @.ruby (not ("ruby script universe"))} + @.ruby (not ("ruby script universe")) + ## Cannot make all definitions be local variables because of limitations with PHP itself. + @.php (not ("php script universe"))} #0)) (def: universe_label Text (with_expansions [<label> (format "u" (%.nat (if ..universe 1 0)))] (for {@.lua <label> - @.ruby <label>} + @.ruby <label> + @.php <label>} ""))) (def: #export (artifact [module artifact]) |