aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2021-05-30 00:23:22 -0400
committerEduardo Julian2021-05-30 00:23:39 -0400
commitef3a84b05c924ae5978bdc7336120a5adb9713b4 (patch)
tree46d478091deeefd22f2b1f15c9857e205bd06e48
parent2466d4983c2d5ca46822f45cca863d07ce2b1ee0 (diff)
More adjustments for Common Lisp.
Diffstat (limited to '')
-rw-r--r--lux-cl/source/program.lux23
-rw-r--r--stdlib/source/lux.lux514
-rw-r--r--stdlib/source/lux/target/common_lisp.lux73
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux55
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux85
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux45
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux31
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux135
8 files changed, 510 insertions, 451 deletions
diff --git a/lux-cl/source/program.lux b/lux-cl/source/program.lux
index 89b2b937c..1a3b767a4 100644
--- a/lux-cl/source/program.lux
+++ b/lux-cl/source/program.lux
@@ -334,7 +334,7 @@
)))))
(def: platform
- (IO (Platform _.Var/1 (_.Expression Any) (_.Expression Any)))
+ (IO (Platform [_.Tag Register] (_.Expression Any) (_.Expression Any)))
(do io.monad
[host ..host]
(wrap {#platform.&file_system (file.async file.default)
@@ -353,16 +353,15 @@
(def: (program context program)
(Program (_.Expression Any) (_.Expression Any))
- (let [raw_inputs ($_ _.progn
- (_.conditional+ (list "clisp") (_.var "ext:*args*"))
- (_.conditional+ (list "sbcl") (_.var "sb-ext:*posix-argv*"))
- (_.conditional+ (list "clozure") (_.call/* (_.var "ccl::command-line-arguments") (list)))
- (_.conditional+ (list "gcl") (_.var "si:*command-args*"))
- (_.conditional+ (list "ecl") ..get_ecl_cli_inputs)
- (_.conditional+ (list "cmu") (_.var "extensions:*command-line-strings*"))
- (_.conditional+ (list "allegro") (_.call/* (_.var "sys:command-line-arguments") (list)))
- (_.conditional+ (list "lispworks") (_.var "sys:*line-arguments-list*"))
- (_.list/* (list)))]
+ (let [raw_inputs (_.progn (list (_.conditional+ (list "clisp") (_.var "ext:*args*"))
+ (_.conditional+ (list "sbcl") (_.var "sb-ext:*posix-argv*"))
+ (_.conditional+ (list "clozure") (_.call/* (_.var "ccl::command-line-arguments") (list)))
+ (_.conditional+ (list "gcl") (_.var "si:*command-args*"))
+ (_.conditional+ (list "ecl") ..get_ecl_cli_inputs)
+ (_.conditional+ (list "cmu") (_.var "extensions:*command-line-strings*"))
+ (_.conditional+ (list "allegro") (_.call/* (_.var "sys:command-line-arguments") (list)))
+ (_.conditional+ (list "lispworks") (_.var "sys:*line-arguments-list*"))
+ (_.list/* (list))))]
(_.call/2 [(runtime.lux//program_args raw_inputs) _.nil] program)))
(for {@.old
@@ -422,7 +421,7 @@
generation.bundle
extension/bundle.empty
..program
- [_.Var _.Expression _.Expression]
+ [(& _.Tag Register) (type (_.Expression Any)) (type (_.Expression Any))]
..extender
service
[(packager.package (_.manual "")
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 0b8941ba7..276a8e6e7 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -8,13 +8,13 @@
[dummy_location (9 #1 (0 #0))]
#0)
-("lux def" new_line
+("lux def" \n
("lux i64 char" +10)
[dummy_location (9 #1 (0 #0))]
#0)
("lux def" __paragraph
- ("lux text concat" new_line new_line)
+ ("lux text concat" \n \n)
[dummy_location (9 #1 (0 #0))]
#0)
@@ -1476,11 +1476,11 @@
(macro:' #export (_$ tokens)
(#Cons [(tag$ ["lux" "doc"])
(text$ ("lux text concat"
- ("lux text concat" "## Left-association for the application of binary functions over variadic arguments." ..new_line)
+ ("lux text concat" "## Left-association for the application of binary functions over variadic arguments." ..\n)
("lux text concat"
- ("lux text concat" "(_$ text\compose ''Hello, '' name ''. How are you?'')" ..new_line)
+ ("lux text concat" "(_$ text\compose ''Hello, '' name ''. How are you?'')" ..\n)
("lux text concat"
- ("lux text concat" "## =>" ..new_line)
+ ("lux text concat" "## =>" ..\n)
"(text\compose (text\compose ''Hello, '' name) ''. How are you?'')"))))]
#Nil)
({(#Cons op tokens')
@@ -1498,11 +1498,11 @@
(macro:' #export ($_ tokens)
(#Cons [(tag$ ["lux" "doc"])
(text$ ("lux text concat"
- ("lux text concat" "## Right-association for the application of binary functions over variadic arguments." ..new_line)
+ ("lux text concat" "## Right-association for the application of binary functions over variadic arguments." ..\n)
("lux text concat"
- ("lux text concat" "($_ text\compose ''Hello, '' name ''. How are you?'')" ..new_line)
+ ("lux text concat" "($_ text\compose ''Hello, '' name ''. How are you?'')" ..\n)
("lux text concat"
- ("lux text concat" "## =>" ..new_line)
+ ("lux text concat" "## =>" ..\n)
"(text\compose ''Hello, '' (text\compose name ''. How are you?''))"))))]
#Nil)
({(#Cons op tokens')
@@ -2133,9 +2133,9 @@
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
"## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary." __paragraph
- "(template [<name> <diff>]" ..new_line
+ "(template [<name> <diff>]" ..\n
" " "[(def: #export <name> (-> Int Int) (+ <diff>))]" __paragraph
- " " "[inc +1]" ..new_line
+ " " "[inc +1]" ..\n
" " "[dec -1]"))])
({(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] data])])
({[(#Some bindings') (#Some data')]
@@ -2616,10 +2616,10 @@
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
"## Sequential execution of expressions (great for side-effects)." __paragraph
- "(exec" ..new_line
- " " "(log! ''#1'')" ..new_line
- " " "(log! ''#2'')" ..new_line
- " " "(log! ''#3'')" ..new_line
+ "(exec" ..\n
+ " " "(log! ''#1'')" ..\n
+ " " "(log! ''#2'')" ..\n
+ " " "(log! ''#3'')" ..\n
"''YOLO'')"))])
({(#Cons value actions)
(let' [dummy (local_identifier$ "")]
@@ -2777,12 +2777,12 @@
(macro:' #export (case tokens)
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
- "## The pattern-matching macro." ..new_line
- "## Allows the usage of macros within the patterns to provide custom syntax." ..new_line
- "(case (: (List Int) (list +1 +2 +3))" ..new_line
- " " "(#Cons x (#Cons y (#Cons z #Nil)))" ..new_line
+ "## The pattern-matching macro." ..\n
+ "## Allows the usage of macros within the patterns to provide custom syntax." ..\n
+ "(case (: (List Int) (list +1 +2 +3))" ..\n
+ " " "(#Cons x (#Cons y (#Cons z #Nil)))" ..\n
" " "(#Some ($_ * x y z))" __paragraph
- " " "_" ..new_line
+ " " "_" ..\n
" " "#None)"))])
({(#Cons value branches)
(do meta_monad
@@ -2796,13 +2796,13 @@
(macro:' #export (^ tokens)
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
- "## Macro-expanding patterns." ..new_line
- "## It's a special macro meant to be used with 'case'." ..new_line
- "(case (: (List Int) (list +1 +2 +3))" ..new_line
- " (^ (list x y z))" ..new_line
+ "## Macro-expanding patterns." ..\n
+ "## It's a special macro meant to be used with 'case'." ..\n
+ "(case (: (List Int) (list +1 +2 +3))" ..\n
+ " (^ (list x y z))" ..\n
" (#Some ($_ * x y z))"
__paragraph
- " _" ..new_line
+ " _" ..\n
" #None)"))])
(case tokens
(#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches))
@@ -2821,17 +2821,17 @@
(macro:' #export (^or tokens)
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
- "## Or-patterns." ..new_line
- "## It's a special macro meant to be used with 'case'." ..new_line
+ "## Or-patterns." ..\n
+ "## It's a special macro meant to be used with 'case'." ..\n
"(type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday)"
__paragraph
- "(def: (weekend? day)" ..new_line
- " (-> Weekday Bit)" ..new_line
- " (case day" ..new_line
- " (^or #Saturday #Sunday)" ..new_line
+ "(def: (weekend? day)" ..\n
+ " (-> Weekday Bit)" ..\n
+ " (case day" ..\n
+ " (^or #Saturday #Sunday)" ..\n
" #1"
__paragraph
- " _" ..new_line
+ " _" ..\n
" #0))"))])
(case tokens
(^ (list& [_ (#Form patterns)] body branches))
@@ -2859,10 +2859,10 @@
(macro:' #export (let tokens)
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
- "## Creates local bindings." ..new_line
- "## Can (optionally) use pattern-matching macros when binding." ..new_line
- "(let [x (foo bar)" ..new_line
- " y (baz quux)]" ..new_line
+ "## Creates local bindings." ..\n
+ "## Can (optionally) use pattern-matching macros when binding." ..\n
+ "(let [x (foo bar)" ..\n
+ " y (baz quux)]" ..\n
" (op x y))"))])
(case tokens
(^ (list [_ (#Tuple bindings)] body))
@@ -2885,12 +2885,12 @@
(macro:' #export (function tokens)
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
- "## Syntax for creating functions." ..new_line
- "## Allows for giving the function itself a name, for the sake of recursion." ..new_line
- "(: (All [a b] (-> a b a))" ..new_line
+ "## Syntax for creating functions." ..\n
+ "## Allows for giving the function itself a name, for the sake of recursion." ..\n
+ "(: (All [a b] (-> a b a))" ..\n
" (function (_ x y) x))"
__paragraph
- "(: (All [a b] (-> a b a))" ..new_line
+ "(: (All [a b] (-> a b a))" ..\n
" (function (const x y) x))"))])
(case (: (Maybe [Text Code (List Code) Code])
(case tokens
@@ -3001,14 +3001,14 @@
(macro:' #export (def: tokens)
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
- "## Defines global constants/functions." ..new_line
- "(def: (rejoin_pair pair)" ..new_line
- " (-> [Code Code] (List Code))" ..new_line
- " (let [[left right] pair]" ..new_line
+ "## Defines global constants/functions." ..\n
+ "(def: (rejoin_pair pair)" ..\n
+ " (-> [Code Code] (List Code))" ..\n
+ " (let [[left right] pair]" ..\n
" (list left right)))"
__paragraph
- "(def: branching_exponent" ..new_line
- " Int" ..new_line
+ "(def: branching_exponent" ..\n
+ " Int" ..\n
" +5)"))])
(let [[exported? tokens'] (export^ tokens)
parts (: (Maybe [Code (List Code) (Maybe Code) Code (List [Code Code])])
@@ -3084,15 +3084,15 @@
(macro:' #export (macro: tokens)
(list [(tag$ ["lux" "doc"])
(text$ ($_ "lux text concat"
- "## Macro-definition macro." ..new_line
- "(macro: #export (name_of tokens)" ..new_line
- " (case tokens" ..new_line
- " (^template [<tag>]" ..new_line
- " [(^ (list [_ (<tag> [prefix name])]))" ..new_line
- " (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])" ..new_line
+ "## Macro-definition macro." ..\n
+ "(macro: #export (name_of tokens)" ..\n
+ " (case tokens" ..\n
+ " (^template [<tag>]" ..\n
+ " [(^ (list [_ (<tag> [prefix name])]))" ..\n
+ " (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])" ..\n
" ([#Identifier] [#Tag])"
__paragraph
- " _" ..new_line
+ " _" ..\n
" (fail ''Wrong syntax for name_of'')))"))])
(let [[exported? tokens] (export^ tokens)
name+args+meta+body?? (: (Maybe [Name (List Code) (List [Code Code]) Code])
@@ -3133,17 +3133,17 @@
(macro: #export (signature: tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Definition of signatures ala ML." ..new_line
- "(signature: #export (Ord a)" ..new_line
- " (: (Equivalence a)" ..new_line
- " eq)" ..new_line
- " (: (-> a a Bit)" ..new_line
- " <)" ..new_line
- " (: (-> a a Bit)" ..new_line
- " <=)" ..new_line
- " (: (-> a a Bit)" ..new_line
- " >)" ..new_line
- " (: (-> a a Bit)" ..new_line
+ "## Definition of signatures ala ML." ..\n
+ "(signature: #export (Ord a)" ..\n
+ " (: (Equivalence a)" ..\n
+ " eq)" ..\n
+ " (: (-> a a Bit)" ..\n
+ " <)" ..\n
+ " (: (-> a a Bit)" ..\n
+ " <=)" ..\n
+ " (: (-> a a Bit)" ..\n
+ " >)" ..\n
+ " (: (-> a a Bit)" ..\n
" >=))"))}
(let [[exported? tokens'] (export^ tokens)
?parts (: (Maybe [Name (List Code) Code (List Code)])
@@ -3234,14 +3234,14 @@
(def: #export (error! message)
{#.doc (text$ ($_ "lux text concat"
- "## Causes an error, with the given error message." ..new_line
+ "## Causes an error, with the given error message." ..\n
"(error! ''OH NO!'')"))}
(-> Text Nothing)
("lux io error" message))
(macro: (default tokens state)
{#.doc (text$ ($_ "lux text concat"
- "## Allows you to provide a default value that will be used" ..new_line
+ "## Allows you to provide a default value that will be used" ..\n
"## if a (Maybe x) value turns out to be #.None."
__paragraph
"(default +20 (#.Some +10)) ## => +10"
@@ -3530,18 +3530,18 @@
(macro: #export (structure: tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Definition of structures ala ML." ..new_line
- "(structure: #export order (Order Int)" ..new_line
- " (def: &equivalence equivalence)" ..new_line
- " (def: (< test subject)" ..new_line
- " (< test subject))" ..new_line
- " (def: (<= test subject)" ..new_line
- " (or (< test subject)" ..new_line
- " (= test subject)))" ..new_line
- " (def: (> test subject)" ..new_line
- " (> test subject))" ..new_line
- " (def: (>= test subject)" ..new_line
- " (or (> test subject)" ..new_line
+ "## Definition of structures ala ML." ..\n
+ "(structure: #export order (Order Int)" ..\n
+ " (def: &equivalence equivalence)" ..\n
+ " (def: (< test subject)" ..\n
+ " (< test subject))" ..\n
+ " (def: (<= test subject)" ..\n
+ " (or (< test subject)" ..\n
+ " (= test subject)))" ..\n
+ " (def: (> test subject)" ..\n
+ " (> test subject))" ..\n
+ " (def: (>= test subject)" ..\n
+ " (or (> test subject)" ..\n
" (= test subject))))"))}
(let [[exported? tokens'] (export^ tokens)
?parts (: (Maybe [Code (List Code) Code Code (List Code)])
@@ -3581,7 +3581,7 @@
(macro: #export (type: tokens)
{#.doc (text$ ($_ "lux text concat"
- "## The type-definition macro." ..new_line
+ "## The type-definition macro." ..\n
"(type: (List a) #Nil (#Cons a (List a)))"))}
(let [[exported? tokens'] (export^ tokens)
[rec? tokens'] (case tokens'
@@ -3707,7 +3707,7 @@
(return name)
_
- (fail "only/exclude requires identifiers."))))
+ (fail "#only/#+ and #exclude/#- require identifiers."))))
defs))
(def: (parse_referrals tokens)
@@ -3850,9 +3850,9 @@
_ ($_ text\compose prefix ..module_separator clean))]
(return output))
(fail ($_ "lux text concat"
- "Cannot climb the module hierarchy..." ..new_line
- "Importing module: " module ..new_line
- " Relative Root: " relative_root ..new_line))))))
+ "Cannot climb the module hierarchy..." ..\n
+ "Importing module: " module ..\n
+ " Relative Root: " relative_root ..\n))))))
(def: (alter_domain alteration domain import)
(-> Nat Text Importation Importation)
@@ -3945,7 +3945,7 @@
[current_module current_module_name]
(fail ($_ text\compose
"Wrong syntax for import @ " current_module
- ..new_line (code\encode token)))))))
+ ..\n (code\encode token)))))))
imports)]
(wrap (list\join imports'))))
@@ -3976,13 +3976,13 @@
#None
(#Left ($_ text\compose
- "Unknown module: " (text\encode module) ..new_line
+ "Unknown module: " (text\encode module) ..\n
"Current module: " (case current_module
(#Some current_module)
(text\encode current_module)
#None
- "???") ..new_line
+ "???") ..\n
"Known modules: " (|> modules
(list\map (function (_ [name module])
(text$ name)))
@@ -4203,10 +4203,10 @@
(macro: #export (^open tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Same as the 'open' macro, but meant to be used as a pattern-matching macro for generating local bindings." ..new_line
- "## Takes an 'alias' text for the generated local bindings." ..new_line
- "(def: #export (range (^open ''.'') from to)" ..new_line
- " (All [a] (-> (Enum a) a a (List a)))" ..new_line
+ "## Same as the 'open' macro, but meant to be used as a pattern-matching macro for generating local bindings." ..\n
+ "## Takes an 'alias' text for the generated local bindings." ..\n
+ "(def: #export (range (^open ''.'') from to)" ..\n
+ " (All [a] (-> (Enum a) a a (List a)))" ..\n
" (range' <= succ from to))"))}
(case tokens
(^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches))
@@ -4254,11 +4254,11 @@
(macro: #export (cond tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Branching structures with multiple test conditions." ..new_line
- "(cond (even? num) ''even''" ..new_line
+ "## Branching structures with multiple test conditions." ..\n
+ "(cond (even? num) ''even''" ..\n
" (odd? num) ''odd''"
__paragraph
- " ## else_branch" ..new_line
+ " ## else_branch" ..\n
" ''???'')"))}
(if ("lux i64 =" 0 (n/% 2 (list\size tokens)))
(fail "cond requires an uneven number of arguments.")
@@ -4289,14 +4289,14 @@
(macro: #export (get@ tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Accesses the value of a record at a given tag." ..new_line
+ "## Accesses the value of a record at a given tag." ..\n
"(get@ #field my_record)"
__paragraph
- "## Can also work with multiple levels of nesting:" ..new_line
+ "## Can also work with multiple levels of nesting:" ..\n
"(get@ [#foo #bar #baz] my_record)"
__paragraph
- "## And, if only the slot/path is given, generates an accessor function:" ..new_line
- "(let [getter (get@ [#foo #bar #baz])]" ..new_line
+ "## And, if only the slot/path is given, generates an accessor function:" ..\n
+ "(let [getter (get@ [#foo #bar #baz])]" ..\n
" (getter my_record))"))}
(case tokens
(^ (list [_ (#Tag slot')] record))
@@ -4370,13 +4370,13 @@
{#.doc (text$ ($_ "lux text concat"
"## Opens a structure and generates a definition for each of its members (including nested members)."
__paragraph
- "## For example:" ..new_line
+ "## For example:" ..\n
"(open: ''i:.'' number)"
__paragraph
- "## Will generate:" ..new_line
- "(def: i:+ (\ number +))" ..new_line
- "(def: i:- (\ number -))" ..new_line
- "(def: i:* (\ number *))" ..new_line
+ "## Will generate:" ..\n
+ "(def: i:+ (\ number +))" ..\n
+ "(def: i:- (\ number -))" ..\n
+ "(def: i:* (\ number *))" ..\n
"..."))}
(case tokens
(^ (list [_ (#Text alias)] struct))
@@ -4411,9 +4411,9 @@
(macro: #export (|>> tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..new_line
- "(|>> (list\map int\encode) (interpose '' '') (fold text\compose ''''))" ..new_line
- "## =>" ..new_line
+ "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n
+ "(|>> (list\map int\encode) (interpose '' '') (fold text\compose ''''))" ..\n
+ "## =>" ..\n
"(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))}
(do meta_monad
[g!_ (gensym "_")
@@ -4422,9 +4422,9 @@
(macro: #export (<<| tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..new_line
- "(<<| (fold text\compose '''') (interpose '' '') (list\map int\encode))" ..new_line
- "## =>" ..new_line
+ "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n
+ "(<<| (fold text\compose '''') (interpose '' '') (list\map int\encode))" ..\n
+ "## =>" ..\n
"(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))}
(do meta_monad
[g!_ (gensym "_")
@@ -4453,10 +4453,10 @@
_
(fail ($_ text\compose "Wrong syntax for refer @ " current_module
- ..new_line (|> options
- (list\map code\encode)
- (interpose " ")
- (list\fold text\compose "")))))))
+ ..\n (|> options
+ (list\map code\encode)
+ (interpose " ")
+ (list\fold text\compose "")))))))
(def: (write_refer module_name [r_defs r_opens])
(-> Text Refer (Meta (List Code)))
@@ -4549,17 +4549,17 @@
__paragraph
"## Can take optional annotations and allows the specification of modules to import."
__paragraph
- "## Example" ..new_line
- "(.module: {#.doc ''Some documentation...''}" ..new_line
- " [lux #*" ..new_line
- " [control" ..new_line
- " [''M'' monad #*]]" ..new_line
- " [data" ..new_line
- " maybe" ..new_line
- " [''.'' name (''#/.'' codec)]]" ..new_line
- " [macro" ..new_line
- " code]]" ..new_line
- " [//" ..new_line
+ "## Example" ..\n
+ "(.module: {#.doc ''Some documentation...''}" ..\n
+ " [lux #*" ..\n
+ " [control" ..\n
+ " [''M'' monad #*]]" ..\n
+ " [data" ..\n
+ " maybe" ..\n
+ " [''.'' name (''#/.'' codec)]]" ..\n
+ " [macro" ..\n
+ " code]]" ..\n
+ " [//" ..\n
" [type (''.'' equivalence)]])"))}
(do meta_monad
[#let [[_meta _imports] (: [(List [Code Code]) (List Code)]
@@ -4587,31 +4587,31 @@
(macro: #export (\ tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Allows accessing the value of a structure's member." ..new_line
+ "## Allows accessing the value of a structure's member." ..\n
"(\ codec encode)"
__paragraph
- "## Also allows using that value as a function." ..new_line
+ "## Also allows using that value as a function." ..\n
"(\ codec encode +123)"))}
(case tokens
(^ (list struct [_ (#Identifier member)]))
- (return (list (` (let [(^open ".") (~ struct)] (~ (identifier$ member))))))
+ (return (list (` (let [(^open (~ (text$ ..self_reference))) (~ struct)] (~ (identifier$ member))))))
- (^ (list& struct [_ (#Identifier member)] args))
- (return (list (` ((let [(^open ".") (~ struct)] (~ (identifier$ member))) (~+ args)))))
+ (^ (list& struct member args))
+ (return (list (` ((..\ (~ struct) (~ member)) (~+ args)))))
_
(fail "Wrong syntax for \")))
(macro: #export (set@ tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Sets the value of a record at a given tag." ..new_line
+ "## Sets the value of a record at a given tag." ..\n
"(set@ #name ''Lux'' lang)"
__paragraph
- "## Can also work with multiple levels of nesting:" ..new_line
+ "## Can also work with multiple levels of nesting:" ..\n
"(set@ [#foo #bar #baz] value my_record)"
__paragraph
- "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..new_line
- "(let [setter (set@ [#foo #bar #baz] value)] (setter my_record))" ..new_line
+ "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n
+ "(let [setter (set@ [#foo #bar #baz] value)] (setter my_record))" ..\n
"(let [setter (set@ [#foo #bar #baz])] (setter value my_record))"))}
(case tokens
(^ (list [_ (#Tag slot')] value record))
@@ -4677,28 +4677,30 @@
(do meta_monad
[g!_ (gensym "_")
g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!record)) (..set@ (~ selector) (~ value) (~ g!record)))))))
+ (wrap (list (` (function ((~ g!_) (~ g!record))
+ (..set@ (~ selector) (~ value) (~ g!record)))))))
(^ (list selector))
(do meta_monad
[g!_ (gensym "_")
g!value (gensym "value")
g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!value) (~ g!record)) (..set@ (~ selector) (~ g!value) (~ g!record)))))))
+ (wrap (list (` (function ((~ g!_) (~ g!value) (~ g!record))
+ (..set@ (~ selector) (~ g!value) (~ g!record)))))))
_
(fail "Wrong syntax for set@")))
(macro: #export (update@ tokens)
{#.doc (text$ ($_ "lux text concat"
- "## Modifies the value of a record at a given tag, based on some function." ..new_line
+ "## Modifies the value of a record at a given tag, based on some function." ..\n
"(update@ #age inc person)"
__paragraph
- "## Can also work with multiple levels of nesting:" ..new_line
+ "## Can also work with multiple levels of nesting:" ..\n
"(update@ [#foo #bar #baz] func my_record)"
__paragraph
- "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..new_line
- "(let [updater (update@ [#foo #bar #baz] func)] (updater my_record))" ..new_line
+ "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n
+ "(let [updater (update@ [#foo #bar #baz] func)] (updater my_record))" ..\n
"(let [updater (update@ [#foo #bar #baz])] (updater func my_record))"))}
(case tokens
(^ (list [_ (#Tag slot')] fun record))
@@ -4750,52 +4752,54 @@
(do meta_monad
[g!_ (gensym "_")
g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!record)) (..update@ (~ selector) (~ fun) (~ g!record)))))))
+ (wrap (list (` (function ((~ g!_) (~ g!record))
+ (..update@ (~ selector) (~ fun) (~ g!record)))))))
(^ (list selector))
(do meta_monad
[g!_ (gensym "_")
g!fun (gensym "fun")
g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!fun) (~ g!record)) (..update@ (~ selector) (~ g!fun) (~ g!record)))))))
+ (wrap (list (` (function ((~ g!_) (~ g!fun) (~ g!record))
+ (..update@ (~ selector) (~ g!fun) (~ g!record)))))))
_
(fail "Wrong syntax for update@")))
(macro: #export (^template tokens)
{#.doc (text$ ($_ "lux text concat"
- "## It's similar to template, but meant to be used during pattern-matching." ..new_line
- "(def: (beta_reduce env type)" ..new_line
- " (-> (List Type) Type Type)" ..new_line
- " (case type" ..new_line
- " (#.Primitive name params)" ..new_line
+ "## It's similar to template, but meant to be used during pattern-matching." ..\n
+ "(def: (beta_reduce env type)" ..\n
+ " (-> (List Type) Type Type)" ..\n
+ " (case type" ..\n
+ " (#.Primitive name params)" ..\n
" (#.Primitive name (list\map (beta_reduce env) params))"
__paragraph
- " (^template [<tag>]" ..new_line
- " [(<tag> left right)" ..new_line
- " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..new_line
+ " (^template [<tag>]" ..\n
+ " [(<tag> left right)" ..\n
+ " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n
" ([#.Sum] [#.Product])"
__paragraph
- " (^template [<tag>]" ..new_line
- " [(<tag> left right)" ..new_line
- " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..new_line
+ " (^template [<tag>]" ..\n
+ " [(<tag> left right)" ..\n
+ " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n
" ([#.Function] [#.Apply])"
__paragraph
- " (^template [<tag>]" ..new_line
- " [(<tag> old_env def)" ..new_line
- " (case old_env" ..new_line
- " #.Nil" ..new_line
+ " (^template [<tag>]" ..\n
+ " [(<tag> old_env def)" ..\n
+ " (case old_env" ..\n
+ " #.Nil" ..\n
" (<tag> env def)"
__paragraph
- " _" ..new_line
- " type)])" ..new_line
+ " _" ..\n
+ " type)])" ..\n
" ([#.UnivQ] [#.ExQ])"
__paragraph
- " (#.Parameter idx)" ..new_line
+ " (#.Parameter idx)" ..\n
" (default type (list.nth idx env))"
__paragraph
- " _" ..new_line
- " type" ..new_line
+ " _" ..\n
+ " type" ..\n
" ))"))}
(case tokens
(^ (list& [_ (#Form (list [_ (#Tuple bindings)]
@@ -4889,7 +4893,7 @@
(-> Nat Location Location Text)
(if ("lux i64 =" old_line new_line)
(text\join_with "" (repeat (.int ("lux i64 -" old_column new_column)) " "))
- (let [extra_lines (text\join_with "" (repeat (.int ("lux i64 -" old_line new_line)) ..new_line))
+ (let [extra_lines (text\join_with "" (repeat (.int ("lux i64 -" old_line new_line)) ..\n))
space_padding (text\join_with "" (repeat (.int ("lux i64 -" baseline new_column)) " "))]
(text\compose extra_lines space_padding))))
@@ -4955,8 +4959,8 @@
(case fragment
(#Doc_Comment comment)
(|> comment
- (text\split_all_with ..new_line)
- (list\map (function (_ line) ($_ text\compose "## " line ..new_line)))
+ (text\split_all_with ..\n)
+ (list\map (function (_ line) ($_ text\compose "## " line ..\n)))
(text\join_with ""))
(#Doc_Example example)
@@ -4969,13 +4973,13 @@
{#.doc (text$ ($_ "lux text concat"
"## Creates code documentation, embedding text as comments and properly formatting the forms it's being given."
__paragraph
- "## For Example:" ..new_line
- "(doc ''Allows arbitrary looping, using the 'recur' form to re-start the loop.''" ..new_line
- " ''Can be used in monadic code to create monadic loops.''" ..new_line
- " (loop [count +0" ..new_line
- " x init]" ..new_line
- " (if (< +10 count)" ..new_line
- " (recur (inc count) (f x))" ..new_line
+ "## For Example:" ..\n
+ "(doc ''Allows arbitrary looping, using the 'recur' form to re-start the loop.''" ..\n
+ " ''Can be used in monadic code to create monadic loops.''" ..\n
+ " (loop [count +0" ..\n
+ " x init]" ..\n
+ " (if (< +10 count)" ..\n
+ " (recur (inc count) (f x))" ..\n
" x)))"))}
(return (list (` [(~ location_code)
(#.Text (~ (|> tokens
@@ -5165,8 +5169,8 @@
(macro: #export (with_expansions tokens)
{#.doc (doc "Controlled macro-expansion."
- "Bind an arbitraty number of Codes resulting from macro-expansion to local bindings."
- "Wherever a binding appears, the bound codes will be spliced in there."
+ "Bind an arbitraty number of Code nodes resulting from macro-expansion to local bindings."
+ "Wherever a binding appears, the bound Code nodes will be spliced in there."
(test: "Code operations & structures"
(with_expansions
[<tests> (template [<expr> <text> <pattern>]
@@ -5677,6 +5681,32 @@
(function (_ compiler)
(#Right [compiler (get@ [#info #target] compiler)])))
+(def: (resolve_target choice)
+ (-> Code (Meta Text))
+ (case choice
+ [_ (#Text platform)]
+ (..return platform)
+
+ [_ (#Identifier identifier)]
+ (do meta_monad
+ [identifier (..resolve_global_identifier identifier)
+ type+value (..find_def_value identifier)
+ #let [[type value] type+value]]
+ (case (..flatten_alias type)
+ (^or (#Primitive "#Text" #Nil)
+ (#Named ["lux" "Text"] (#Primitive "#Text" #Nil)))
+ (wrap (:coerce ..Text value))
+
+ _
+ (fail ($_ text\compose
+ "Invalid target platform (must be a value of type Text): " (name\encode identifier)
+ " : " (..code\encode (..type_to_code type))))))
+
+ _
+ (fail ($_ text\compose
+ "Invalid target platform syntax: " (..code\encode choice)
+ ..\n "Must be either a text literal or an identifier."))))
+
(def: (target_pick target options default)
(-> Text (List [Code Code]) (Maybe Code) (Meta (List Code)))
(case options
@@ -5689,32 +5719,11 @@
(return (list default)))
(#Cons [key pick] options')
- (with_expansions [<try_again> (target_pick target options' default)]
- (case key
- [_ (#Text platform)]
- (if (text\= target platform)
- (return (list pick))
- <try_again>)
-
- [_ (#Identifier identifier)]
- (do meta_monad
- [identifier (..resolve_global_identifier identifier)
- type+value (..find_def_value identifier)
- #let [[type value] type+value]]
- (case (..flatten_alias type)
- (#Named ["lux" "Text"] (#Primitive "#Text" #Nil))
- (if (text\= target (:coerce ..Text value))
- (wrap (list pick))
- <try_again>)
-
- _
- (fail ($_ text\compose
- "Invalid target platform (must be a value of type Text): " (name\encode identifier)
- " : " (..code\encode (..type_to_code type))))))
-
- _
- <try_again>))
- ))
+ (do meta_monad
+ [platform (..resolve_target key)]
+ (if (text\= target platform)
+ (return (list pick))
+ (target_pick target options' default)))))
(macro: #export (for tokens)
(do meta_monad
@@ -5799,58 +5808,71 @@
(#Cons [init inits'])
(` (#.Cons (~ init) (~ (untemplate_list& last inits'))))))
-(def: (untemplate_pattern pattern)
- (-> Code (Meta Code))
- (case pattern
- (^template [<tag> <name> <gen>]
- [[_ (<tag> value)]
+(def: (untemplate_record g!meta untemplate_pattern fields)
+ (-> Code (-> Code (Meta Code))
+ (-> (List [Code Code]) (Meta Code)))
+ (do meta_monad
+ [=fields (monad\map meta_monad
+ (function (_ [key value])
+ (do meta_monad
+ [=key (untemplate_pattern key)
+ =value (untemplate_pattern value)]
+ (wrap (` [(~ =key) (~ =value)]))))
+ fields)]
+ (wrap (` [(~ g!meta) (#.Record (~ (untemplate_list =fields)))]))))
+
+(template [<tag> <name>]
+ [(def: (<name> g!meta untemplate_pattern elems)
+ (-> Code (-> Code (Meta Code))
+ (-> (List Code) (Meta Code)))
+ (case (list\reverse elems)
+ (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
+ inits)
(do meta_monad
- [g!meta (gensym "g!meta")]
- (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))])))])
- ([#Bit "Bit" bit$]
- [#Nat "Nat" nat$]
- [#Int "Int" int$]
- [#Rev "Rev" rev$]
- [#Frac "Frac" frac$]
- [#Text "Text" text$]
- [#Tag "Tag" name$]
- [#Identifier "Identifier" name$])
-
- [_ (#Record fields)]
- (do meta_monad
- [=fields (monad\map meta_monad
- (function (_ [key value])
- (do meta_monad
- [=key (untemplate_pattern key)
- =value (untemplate_pattern value)]
- (wrap (` [(~ =key) (~ =value)]))))
- fields)
- g!meta (gensym "g!meta")]
- (wrap (` [(~ g!meta) (#.Record (~ (untemplate_list =fields)))])))
-
- [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]
- (return unquoted)
-
- [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
- (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.")
+ [=inits (monad\map meta_monad untemplate_pattern (list\reverse inits))]
+ (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list& spliced =inits)))])))
- (^template [<tag>]
- [[_ (<tag> elems)]
- (case (list\reverse elems)
- (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
- inits)
- (do meta_monad
- [=inits (monad\map meta_monad untemplate_pattern (list\reverse inits))
- g!meta (gensym "g!meta")]
- (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list& spliced =inits)))])))
+ _
+ (do meta_monad
+ [=elems (monad\map meta_monad untemplate_pattern elems)]
+ (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list =elems)))])))))]
- _
- (do meta_monad
- [=elems (monad\map meta_monad untemplate_pattern elems)
- g!meta (gensym "g!meta")]
- (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list =elems)))]))))])
- ([#Tuple] [#Form])
- ))
+ [#.Tuple untemplate_tuple]
+ [#.Form untemplate_form]
+ )
+
+(def: (untemplate_pattern pattern)
+ (-> Code (Meta Code))
+ (do meta_monad
+ [g!meta (gensym "g!meta")]
+ (case pattern
+ (^template [<tag> <gen>]
+ [[_ (<tag> value)]
+ (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))]))])
+ ([#.Bit bit$]
+ [#.Nat nat$]
+ [#.Int int$]
+ [#.Rev rev$]
+ [#.Frac frac$]
+ [#.Text text$]
+ [#.Tag name$]
+ [#.Identifier name$])
+
+ [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]
+ (return unquoted)
+
+ [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
+ (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.")
+
+ (^template [<tag> <untemplate>]
+ [[_ (<tag> elems)]
+ (<untemplate> g!meta untemplate_pattern elems)])
+ ([#.Tuple ..untemplate_tuple]
+ [#.Form ..untemplate_form])
+
+ [_ (#Record fields)]
+ (..untemplate_record g!meta untemplate_pattern fields)
+ )))
(macro: #export (^code tokens)
(case tokens
diff --git a/stdlib/source/lux/target/common_lisp.lux b/stdlib/source/lux/target/common_lisp.lux
index 25ee6e44d..766c63a6d 100644
--- a/stdlib/source/lux/target/common_lisp.lux
+++ b/stdlib/source/lux/target/common_lisp.lux
@@ -6,7 +6,7 @@
["." text
["%" format (#+ format)]]
[collection
- ["." list ("#\." monad fold)]]]
+ ["." list ("#\." monad fold monoid)]]]
[macro
["." template]]
[math
@@ -35,7 +35,7 @@
(`` (abstract: #export (<brand> brand) Any))
(`` (type: #export (<type> brand)
(<super> (<brand> brand)))))]
-
+
[Expression Code]
[Computation Expression]
[Access Computation]
@@ -50,6 +50,7 @@
(`` (type: #export <type> (<super> <brand>))))]
[Label Code]
+ [Tag Expression]
[Literal Expression]
[Var/1 Var]
[Var/* Input]
@@ -191,10 +192,10 @@
body)))
(def: #export (destructuring-bind [bindings expression] body)
- (-> [Var/* (Expression Any)] (Expression Any) (Computation Any))
- (..form (list (..var "destructuring-bind")
- (:transmutation bindings) expression
- body)))
+ (-> [Var/* (Expression Any)] (List (Expression Any)) (Computation Any))
+ (..form (list& (..var "destructuring-bind")
+ (:transmutation bindings) expression
+ body)))
(template [<call> <input_var>+ <input_type>+ <function>+]
[(`` (def: #export (<call> [(~~ (template.splice <input_var>+))] function)
@@ -232,6 +233,7 @@
[hash-table-size/1 "hash-table-size"]
[hash-table-rehash-size/1 "hash-table-rehash-size"]
[code-char/1 "code-char"]
+ [char-code/1 "char-code"]
[string/1 "string"]
[write-line/1 "write-line"]
[pprint/1 "pprint"]]]
@@ -340,13 +342,13 @@
(template [<lux_name> <host_name>]
[(def: #export (<lux_name> bindings body)
- (-> (List [Var/1 (Expression Any)]) (Expression Any) (Computation Any))
- (..form (list (..var <host_name>)
- (|> bindings
- (list\map (function (_ [name value])
- (..form (list name value))))
- ..form)
- body)))]
+ (-> (List [Var/1 (Expression Any)]) (List (Expression Any)) (Computation Any))
+ (..form (list& (..var <host_name>)
+ (|> bindings
+ (list\map (function (_ [name value])
+ (..form (list name value))))
+ ..form)
+ body)))]
[let "let"]
[let* "let*"]
@@ -360,9 +362,15 @@
(-> Var/1 Var/* (Expression Any) (Expression Any))
(..form (list (..var "defun") name (:transmutation inputs) body)))
- (def: #export (progn pre post)
- (-> (Expression Any) (Expression Any) (Computation Any))
- (..form (list (..var "progn") pre post)))
+ (template [<name> <symbol>]
+ [(def: #export <name>
+ (-> (List (Expression Any)) (Computation Any))
+ (|>> (list& (..var <symbol>)) ..form))]
+
+ [progn "progn"]
+ [tagbody "tagbody"]
+ [values/* "values"]
+ )
(def: #export (setq name value)
(-> Var/1 (Expression Any) (Expression Any))
@@ -413,8 +421,8 @@
(|>> :abstraction))
(def: #export (block name body)
- (-> Label (Expression Any) (Computation Any))
- (..form (list (..var "block") (:transmutation name) body)))
+ (-> Label (List (Expression Any)) (Computation Any))
+ (..form (list& (..var "block") (:transmutation name) body)))
(def: #export (return-from target value)
(-> Label (Expression Any) (Computation Any))
@@ -422,10 +430,31 @@
(def: #export (cond clauses else)
(-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any))
- (list\fold (function (_ [test then] next)
- (..if test then next))
- (:transmutation else)
- (list.reverse clauses)))
+ (..form (list& (..var "cond")
+ (list\compose (list\map (function (_ [test then])
+ (..form (list test then)))
+ clauses)
+ (list (..form (list (..bool true) else)))))))
+
+ (def: #export tag
+ (-> Text Tag)
+ (|>> :abstraction))
+
+ (def: #export go
+ (-> Tag (Expression Any))
+ (|>> (list (..var "go"))
+ ..form))
+
+ (def: #export values-list/1
+ (-> (Expression Any) (Expression Any))
+ (|>> (list (..var "values-list"))
+ ..form))
+
+ (def: #export (multiple-value-setq bindings values)
+ (-> Var/* (Expression Any) (Expression Any))
+ (..form (list (..var "multiple-value-setq")
+ (:transmutation bindings)
+ values)))
)
(def: #export (while condition body)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
index 2a64aeb1e..b47bade2d 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
@@ -53,7 +53,7 @@
(template: (!unary function)
(|>> list _.apply/* (|> (_.constant function))))
-## TODO: Get rid of this ASAP
+## ## TODO: Get rid of this ASAP
## (def: lux::syntax_char_case!
## (..custom [($_ <>.and
## <s>.any
@@ -74,18 +74,18 @@
## branchG])))
## conditionals))]
## (wrap (_.let (list [@input inputG])
-## (list\fold (function (_ [test then] else)
-## (_.if test then else))
-## elseG
-## conditionalsG)))))]))
+## (list (list\fold (function (_ [test then] else)
+## (_.if test then else))
+## elseG
+## conditionalsG))))))]))
-## (def: lux_procs
-## Bundle
-## (|> /.empty
-## (/.install "syntax char case!" lux::syntax_char_case!)
-## (/.install "is" (binary (product.uncurry _.eq?/2)))
-## (/.install "try" (unary //runtime.lux//try))
-## ))
+(def: lux_procs
+ Bundle
+ (|> /.empty
+ ## (/.install "syntax char case!" lux::syntax_char_case!)
+ (/.install "is" (binary _.eq/2))
+ ## (/.install "try" (unary //runtime.lux//try))
+ ))
## (def: (capped operation parameter subject)
## (-> (-> Expression Expression Expression)
@@ -128,13 +128,17 @@
## (/.install "decode" (unary //runtime.f64//decode))
)))
-## (def: (text//index [offset sub text])
-## (Trinary Expression)
-## (//runtime.text//index offset sub text))
+(def: (text//index [offset sub text])
+ (Trinary (Expression Any))
+ (//runtime.text//index offset sub text))
+
+(def: (text//clip [offset length text])
+ (Trinary (Expression Any))
+ (//runtime.text//clip offset length text))
-## (def: (text//clip [paramO extraO subjectO])
-## (Trinary Expression)
-## (//runtime.text//clip paramO extraO subjectO))
+(def: (text//char [index text])
+ (Binary (Expression Any))
+ (_.char-code/1 (_.char/2 [text index])))
(def: text_procs
Bundle
@@ -144,16 +148,17 @@
## (/.install "<" (binary (product.uncurry _.string<?/2)))
(/.install "concat" (binary (function (_ [left right])
(_.concatenate/3 [(_.symbol "string") left right]))))
- ## (/.install "index" (trinary ..text//index))
- ## (/.install "size" (unary _.string-length/1))
- ## (/.install "char" (binary (product.uncurry //runtime.text//char)))
- ## (/.install "clip" (trinary ..text//clip))
+ (/.install "index" (trinary ..text//index))
+ (/.install "size" (unary _.length/1))
+ (/.install "char" (binary ..text//char))
+ (/.install "clip" (trinary ..text//clip))
)))
(def: (io//log! message)
(Unary (Expression Any))
- (_.progn (_.write-line/1 message)
- //runtime.unit))
+ (_.progn (list (_.pprint/1 message)
+ ## (_.write-line/1 message)
+ //runtime.unit)))
(def: io_procs
Bundle
@@ -168,7 +173,7 @@
Bundle
(<| (/.prefix "lux")
(|> /.empty
- ## (dictionary.merge lux_procs)
+ (dictionary.merge lux_procs)
(dictionary.merge i64_procs)
(dictionary.merge f64_procs)
(dictionary.merge text_procs)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
index 1c669ae52..08250d5d9 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
@@ -7,7 +7,7 @@
[data
["." text]
[collection
- ["." list ("#\." functor fold)]
+ ["." list ("#\." functor fold monoid)]
["." set]]]
[math
[number
@@ -47,7 +47,7 @@
[valueG (expression archive valueS)
bodyG (expression archive bodyS)]
(wrap (_.let (list [(..register register) valueG])
- bodyG))))
+ (list bodyG)))))
(def: #export (if expression archive [testS thenS elseS])
(Generator [Synthesis Synthesis Synthesis])
@@ -94,10 +94,9 @@
(_.setq @savepoint (_.cons/2 [@cursor @savepoint])))
(def: restore!
- (Expression Any)
- ($_ _.progn
- (_.setq @cursor (_.car/1 @savepoint))
- (_.setq @savepoint (_.cdr/1 @savepoint))))
+ (List (Expression Any))
+ (list (_.setq @cursor (_.car/1 @savepoint))
+ (_.setq @savepoint (_.cdr/1 @savepoint))))
(def: @fail (_.label "lux_pm_fail"))
(def: @done (_.label "lux_pm_done"))
@@ -109,19 +108,23 @@
(_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor])))
(template [<name> <flag> <prep>]
- [(def: (<name> simple? idx)
- (-> Bit Nat (Expression Any))
+ [(def: (<name> simple? idx next!)
+ (-> Bit Nat (Maybe (Expression Any)) (Expression Any))
(.let [<failure_condition> (_.eq/2 [@variant @temp])]
(_.let (list [@variant ..peek])
- ($_ _.progn
- (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>)))
- (.if simple?
- (_.when <failure_condition>
- fail!)
- (_.if <failure_condition>
- fail!
- (..push! @temp))
- )))))]
+ (list& (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>)))
+ (.if simple?
+ (_.when <failure_condition>
+ fail!)
+ (_.if <failure_condition>
+ fail!
+ (..push! @temp)))
+ (.case next!
+ (#.Some next!)
+ (list next!)
+
+ #.None
+ (list))))))]
[left_choice _.nil (<|)]
[right_choice (_.string "") inc]
@@ -129,12 +132,12 @@
(def: (alternation pre! post!)
(-> (Expression Any) (Expression Any) (Expression Any))
- (_.progn (<| (_.block ..@fail)
- (_.progn ..save!)
- pre!)
- ($_ _.progn
+ (_.progn ($_ list\compose
+ (list (_.block ..@fail
+ (list ..save!
+ pre!)))
..restore!
- post!)))
+ (list post!))))
(def: (pattern_matching' expression archive)
(Generator Path)
@@ -186,12 +189,12 @@
(^template [<complex> <simple> <choice>]
[(^ (<complex> idx))
- (///////phase\wrap (<choice> false idx))
+ (///////phase\wrap (<choice> false idx #.None))
(^ (<simple> idx nextP))
(|> nextP
recur
- (\ ///////phase.monad map (_.progn (<choice> true idx))))])
+ (\ ///////phase.monad map (|>> #.Some (<choice> true idx))))])
([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
[/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
@@ -208,27 +211,29 @@
(.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
(do ///////phase.monad
[next! (recur nextP')]
- (///////phase\wrap ($_ _.progn
- (..multi_pop! (n.+ 2 extra_pops))
- next!))))
-
- (^template [<tag> <combinator>]
- [(^ (<tag> preP postP))
- (do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)]
- (wrap (<combinator> pre! post!)))])
- ([/////synthesis.path/alt ..alternation]
- [/////synthesis.path/seq _.progn]))))
+ (///////phase\wrap (_.progn (list (..multi_pop! (n.+ 2 extra_pops))
+ next!)))))
+
+ (^ (/////synthesis.path/alt preP postP))
+ (do ///////phase.monad
+ [pre! (recur preP)
+ post! (recur postP)]
+ (wrap (..alternation pre! post!)))
+
+ (^ (/////synthesis.path/seq preP postP))
+ (do ///////phase.monad
+ [pre! (recur preP)
+ post! (recur postP)]
+ (wrap (_.progn (list pre! post!)))))))
(def: (pattern_matching expression archive pathP)
(Generator Path)
(do ///////phase.monad
[pattern_matching! (pattern_matching' expression archive pathP)]
(wrap (_.block ..@done
- (_.progn (_.block ..@fail
- pattern_matching!)
- (_.error/1 (_.string ////synthesis/case.pattern_matching_error)))))))
+ (list (_.block ..@fail
+ (list pattern_matching!))
+ (_.error/1 (_.string ////synthesis/case.pattern_matching_error)))))))
(def: #export (case expression archive [valueS pathP])
(Generator [Synthesis Path])
@@ -246,4 +251,4 @@
[@savepoint (_.list/* (list))]
[@temp _.nil]
storage)
- pattern_matching!))))
+ (list pattern_matching!)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
index 23f60e9d0..2a5896e92 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
@@ -6,6 +6,8 @@
pipe]
[data
["." product]
+ [text
+ ["%" format (#+ format)]]
[collection
["." list ("#\." functor fold)]]]
[target
@@ -58,12 +60,11 @@
(def: #export (function expression archive [environment arity bodyS])
(Generator (Abstraction Synthesis))
(do {! ///////phase.monad}
- [[function_name bodyG] (/////generation.with_new_context archive
- (do !
- [@self (\ ! map (|>> ///reference.artifact _.var)
- (/////generation.context archive))]
- (/////generation.with_anchor @self
- (expression archive bodyS))))
+ [@scope (\ ! map (|>> %.nat (format "function_scope") _.tag) /////generation.next)
+ @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next)
+ [function_name bodyG] (/////generation.with_new_context archive
+ (/////generation.with_anchor [@scope 1]
+ (expression archive bodyS)))
closureG+ (monad.map ! (expression archive) environment)
#let [@curried (_.var "curried")
@missing (_.var "missing")
@@ -78,20 +79,24 @@
(with_closure closureG+
(_.labels (list [@self [(_.args& (list) @curried)
(_.let (list [@num_args (_.length/1 @curried)])
- (_.cond (list [(_.=/2 [arityG @num_args])
- (_.let (list initialize_self!)
- (_.destructuring-bind initialize!
- bodyG))]
+ (list (_.cond (list [(_.=/2 [arityG @num_args])
+ (_.let (list [@output _.nil]
+ initialize_self!)
+ (list (_.destructuring-bind initialize!
+ (list (_.tagbody
+ (list @scope
+ (_.setq @output bodyG)))
+ @output))))]
- [(_.>/2 [arityG @num_args])
- (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG])
- extra_inputs (_.subseq/3 [@curried arityG @num_args])]
- (_.apply/2 [(_.apply/2 [(_.function/1 @self)
- arity_inputs])
- extra_inputs]))])
- ## (|> @num_args (_.< arityG))
- (_.lambda (_.args& (list) @missing)
- (_.apply/2 [(_.function/1 @self)
- (_.append/2 [@curried @missing])]))))]])
+ [(_.>/2 [arityG @num_args])
+ (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG])
+ extra_inputs (_.subseq/3 [@curried arityG @num_args])]
+ (_.apply/2 [(_.apply/2 [(_.function/1 @self)
+ arity_inputs])
+ extra_inputs]))])
+ ## (|> @num_args (_.< arityG))
+ (_.lambda (_.args& (list) @missing)
+ (_.apply/2 [(_.function/1 @self)
+ (_.append/2 [@curried @missing])])))))]])
(_.function/1 @self)))
))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
index 14aa89668..7256e926d 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
@@ -41,20 +41,29 @@
## true loop
_
(do {! ///////phase.monad}
- [@scope (\ ! map (|>> %.nat (format "scope") _.var) /////generation.next)
+ [@scope (\ ! map (|>> %.nat (format "loop_scope") _.tag) /////generation.next)
+ @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next)
initsG+ (monad.map ! (expression archive) initsS+)
- bodyG (/////generation.with_anchor @scope
+ bodyG (/////generation.with_anchor [@scope start]
(expression archive bodyS))]
- (wrap (_.labels (list [@scope {#_.input (|> initsS+
- list.enumeration
- (list\map (|>> product.left (n.+ start) //case.register))
- _.args)
- #_.output bodyG}])
- (_.funcall/+ [(_.function/1 @scope) initsG+]))))))
+ (wrap (_.let (|> initsG+
+ list.enumeration
+ (list\map (function (_ [idx init])
+ [(|> idx (n.+ start) //case.register)
+ init]))
+ (list& [@output _.nil]))
+ (list (_.tagbody (list @scope
+ (_.setq @output bodyG)))
+ @output))))))
(def: #export (recur expression archive argsS+)
(Generator (List Synthesis))
(do {! ///////phase.monad}
- [@scope /////generation.anchor
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.call/* @scope argsO+))))
+ [[tag offset] /////generation.anchor
+ argsO+ (monad.map ! (expression archive) argsS+)
+ #let [bindings (|> argsO+
+ list.enumeration
+ (list\map (|>> product.left (n.+ offset) //case.register))
+ _.args)]]
+ (wrap (_.progn (list (_.multiple-value-setq bindings (_.values/* argsO+))
+ (_.go tag))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
index b8c9149d3..73f885ebd 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
@@ -22,7 +22,7 @@
[number (#+ hex)
["." i64]]]
["@" target
- ["_" common_lisp (#+ Expression Var/1 Computation Literal)]]]
+ ["_" common_lisp (#+ Expression Computation Literal)]]]
["." /// #_
["#." reference]
["//#" /// #_
@@ -42,7 +42,7 @@
(template [<name> <base>]
[(type: #export <name>
- (<base> Var/1 (Expression Any) (Expression Any)))]
+ (<base> [_.Tag Register] (Expression Any) (Expression Any)))]
[Operation /////generation.Operation]
[Phase /////generation.Phase]
@@ -157,10 +157,8 @@
..none)]))))
(def: runtime//lux
- ($_ _.progn
- @lux//try
- @lux//program_args
- ))
+ (_.progn (list @lux//try
+ @lux//program_args)))
(def: last_index
(|>> _.length/1 [(_.int +1)] _.-/2))
@@ -175,23 +173,22 @@
(runtime: (tuple//left lefts tuple)
(with_vars [last_index_right]
(_.let (list [last_index_right (..last_index tuple)])
- (_.if (_.>/2 [lefts last_index_right])
- ## No need for recursion
- (_.elt/2 [tuple lefts])
- ## Needs recursion
- (!recur tuple//left)))))
+ (list (_.if (_.>/2 [lefts last_index_right])
+ ## No need for recursion
+ (_.elt/2 [tuple lefts])
+ ## Needs recursion
+ (!recur tuple//left))))))
(runtime: (tuple//right lefts tuple)
(with_vars [last_index_right right_index]
(_.let (list [last_index_right (..last_index tuple)]
[right_index (_.+/2 [(_.int +1) lefts])])
- (_.cond (list [(_.=/2 [last_index_right right_index])
- (_.elt/2 [tuple right_index])]
- [(_.>/2 [last_index_right right_index])
- ## Needs recursion.
- (!recur tuple//right)])
- (_.subseq/3 [tuple right_index (_.length/1 tuple)]))
- ))))
+ (list (_.cond (list [(_.=/2 [last_index_right right_index])
+ (_.elt/2 [tuple right_index])]
+ [(_.>/2 [last_index_right right_index])
+ ## Needs recursion.
+ (!recur tuple//right)])
+ (_.subseq/3 [tuple right_index (_.length/1 tuple)])))))))
## TODO: Find a way to extract parts of the sum without "nth", which
## does a linear search, and is thus expensive.
@@ -203,34 +200,31 @@
sum_value (_.nth/2 [(_.int +2) sum])
test_recursion! (_.if sum_flag
## Must iterate.
- ($_ _.progn
- (_.setq wantedTag (_.-/2 [sum_tag wantedTag]))
- (_.setq sum sum_value))
+ (_.progn (list (_.setq wantedTag (_.-/2 [sum_tag wantedTag]))
+ (_.setq sum sum_value)))
no_match!)]
- (<| (_.progn (_.setq sum_tag (_.nth/2 [(_.int +0) sum])))
- (_.progn (_.setq sum_flag (_.nth/2 [(_.int +1) sum])))
- (_.block @exit)
- (_.while (_.bool true))
- (_.cond (list [(_.=/2 [sum_tag wantedTag])
- (_.if (_.equal/2 [wantsLast sum_flag])
- (return! sum_value)
- test_recursion!)]
+ (_.progn (list (_.setq sum_tag (_.nth/2 [(_.int +0) sum]))
+ (_.setq sum_flag (_.nth/2 [(_.int +1) sum]))
+ (_.block @exit
+ (list (_.while (_.bool true)
+ (_.cond (list [(_.=/2 [sum_tag wantedTag])
+ (_.if (_.equal/2 [wantsLast sum_flag])
+ (return! sum_value)
+ test_recursion!)]
- [(_.>/2 [sum_tag wantedTag])
- test_recursion!]
+ [(_.>/2 [sum_tag wantedTag])
+ test_recursion!]
- [(_.and (_.</2 [sum_tag wantedTag])
- wantsLast)
- (return! (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))])
+ [(_.and (_.</2 [sum_tag wantedTag])
+ wantsLast)
+ (return! (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))])
- no_match!)))))
+ no_match!)))))))))
(def: runtime//adt
- ($_ _.progn
- @tuple//left
- @tuple//right
- @sum//get
- ))
+ (_.progn (list @tuple//left
+ @tuple//right
+ @sum//get)))
(runtime: (i64//right_shift shift input)
(_.if (_.=/2 [(_.int +0) shift])
@@ -244,56 +238,47 @@
[mask] _.logand/2))))
(def: runtime//i64
- ($_ _.progn
- @i64//right_shift
- ))
+ @i64//right_shift)
-(runtime: (text//clip from to text)
- (_.subseq/3 [text from to]))
+(runtime: (text//clip offset length text)
+ (_.subseq/3 [text offset (_.+/2 [offset length])]))
-(runtime: (text//index reference start space)
+(runtime: (text//index offset sub text)
(with_vars [index]
- (_.let (list [index (_.search/3 [reference space start])])
- (_.if index
- (..some index)
- ..none))))
+ (_.let (list [index (_.search/3 [sub text offset])])
+ (list (_.if index
+ (..some index)
+ ..none)))))
(def: runtime//text
- ($_ _.progn
- @text//index
- @text//clip
- ))
+ (_.progn (list @text//index
+ @text//clip)))
(runtime: (io//exit code)
- ($_ _.progn
- (_.conditional+ (list "sbcl")
- (_.call/* (_.var "sb-ext:quit") (list code)))
- (_.conditional+ (list "clisp")
- (_.call/* (_.var "ext:exit") (list code)))
- (_.conditional+ (list "ccl")
- (_.call/* (_.var "ccl:quit") (list code)))
- (_.conditional+ (list "allegro")
- (_.call/* (_.var "excl:exit") (list code)))
- (_.call/* (_.var "cl-user::quit") (list code))))
+ (_.progn (list (_.conditional+ (list "sbcl")
+ (_.call/* (_.var "sb-ext:quit") (list code)))
+ (_.conditional+ (list "clisp")
+ (_.call/* (_.var "ext:exit") (list code)))
+ (_.conditional+ (list "ccl")
+ (_.call/* (_.var "ccl:quit") (list code)))
+ (_.conditional+ (list "allegro")
+ (_.call/* (_.var "excl:exit") (list code)))
+ (_.call/* (_.var "cl-user::quit") (list code)))))
(runtime: (io//current_time _)
(_.*/2 [(_.int +1,000)
(_.get-universal-time/0 [])]))
(def: runtime//io
- ($_ _.progn
- @io//exit
- @io//current_time
- ))
+ (_.progn (list @io//exit
+ @io//current_time)))
(def: runtime
- ($_ _.progn
- runtime//adt
- runtime//lux
- runtime//i64
- runtime//text
- runtime//io
- ))
+ (_.progn (list runtime//adt
+ runtime//lux
+ runtime//i64
+ runtime//text
+ runtime//io)))
(def: #export generate
(Operation [Registry Output])