aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
authorEduardo Julian2021-03-10 10:32:30 -0400
committerEduardo Julian2021-03-10 10:32:30 -0400
commit0c75fd67e3fcfbfb09d8c11b6cf396084ce40a15 (patch)
treeaa95b07ad0a18e0b1dd92657330c7ccaa6202245 /stdlib
parentcbc41f10fb3e0e776767d2266b22068172b0f69a (diff)
Wrestling with JPHP.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux.lux21
-rw-r--r--stdlib/source/lux/target/php.lux159
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux173
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux57
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux23
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux90
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux261
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux7
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])