From ef3a84b05c924ae5978bdc7336120a5adb9713b4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 30 May 2021 00:23:22 -0400 Subject: More adjustments for Common Lisp. --- stdlib/source/lux.lux | 514 +++++++++++---------- stdlib/source/lux/target/common_lisp.lux | 73 ++- .../extension/generation/common_lisp/common.lux | 55 ++- .../lux/phase/generation/common_lisp/case.lux | 85 ++-- .../lux/phase/generation/common_lisp/function.lux | 45 +- .../lux/phase/generation/common_lisp/loop.lux | 31 +- .../lux/phase/generation/common_lisp/runtime.lux | 135 +++--- 7 files changed, 499 insertions(+), 439 deletions(-) (limited to 'stdlib/source') 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 [ ]" ..new_line + "(template [ ]" ..\n " " "[(def: #export (-> Int Int) (+ ))]" __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 []" ..new_line - " [(^ (list [_ ( [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 []" ..\n + " [(^ (list [_ ( [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 (_ ) (fold text\compose '''' (interpose '' '' (list\map int\encode ))))"))} (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 (_ ) (fold text\compose '''' (interpose '' '' (list\map int\encode ))))"))} (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 []" ..new_line - " [( left right)" ..new_line - " ( (beta_reduce env left) (beta_reduce env right))])" ..new_line + " (^template []" ..\n + " [( left right)" ..\n + " ( (beta_reduce env left) (beta_reduce env right))])" ..\n " ([#.Sum] [#.Product])" __paragraph - " (^template []" ..new_line - " [( left right)" ..new_line - " ( (beta_reduce env left) (beta_reduce env right))])" ..new_line + " (^template []" ..\n + " [( left right)" ..\n + " ( (beta_reduce env left) (beta_reduce env right))])" ..\n " ([#.Function] [#.Apply])" __paragraph - " (^template []" ..new_line - " [( old_env def)" ..new_line - " (case old_env" ..new_line - " #.Nil" ..new_line + " (^template []" ..\n + " [( old_env def)" ..\n + " (case old_env" ..\n + " #.Nil" ..\n " ( 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 [ (template [ ] @@ -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 [ (target_pick target options' default)] - (case key - [_ (#Text platform)] - (if (text\= target platform) - (return (list pick)) - ) - - [_ (#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)) - ) - - _ - (fail ($_ text\compose - "Invalid target platform (must be a value of type Text): " (name\encode identifier) - " : " (..code\encode (..type_to_code type)))))) - - _ - )) - )) + (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 [ ] - [[_ ( 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 [ ] + [(def: ( 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) ( (~ ( 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) ( (~ (untemplate_list& spliced =inits)))]))) - (^template [] - [[_ ( 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) ( (~ (untemplate_list& spliced =inits)))]))) + _ + (do meta_monad + [=elems (monad\map meta_monad untemplate_pattern elems)] + (wrap (` [(~ g!meta) ( (~ (untemplate_list =elems)))])))))] - _ - (do meta_monad - [=elems (monad\map meta_monad untemplate_pattern elems) - g!meta (gensym "g!meta")] - (wrap (` [(~ g!meta) ( (~ (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 [ ] + [[_ ( value)] + (wrap (` [(~ g!meta) ( (~ ( 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 [ ] + [[_ ( elems)] + ( 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) Any)) (`` (type: #export ( brand) ( ( brand)))))] - + [Expression Code] [Computation Expression] [Access Computation] @@ -50,6 +50,7 @@ (`` (type: #export ( ))))] [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 [ + + +] [(`` (def: #export ( [(~~ (template.splice +))] 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 [ ] [(def: #export ( bindings body) - (-> (List [Var/1 (Expression Any)]) (Expression Any) (Computation Any)) - (..form (list (..var ) - (|> 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 ) + (|> 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 [ ] + [(def: #export + (-> (List (Expression Any)) (Computation Any)) + (|>> (list& (..var )) ..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 ## .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 /.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 [ ] - [(def: ( simple? idx) - (-> Bit Nat (Expression Any)) + [(def: ( simple? idx next!) + (-> Bit Nat (Maybe (Expression Any)) (Expression Any)) (.let [ (_.eq/2 [@variant @temp])] (_.let (list [@variant ..peek]) - ($_ _.progn - (_.setq @temp (|> idx .int _.int (//runtime.sum//get @variant ))) - (.if simple? - (_.when - fail!) - (_.if - fail! - (..push! @temp)) - )))))] + (list& (_.setq @temp (|> idx .int _.int (//runtime.sum//get @variant ))) + (.if simple? + (_.when + fail!) + (_.if + 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 [ ] [(^ ( idx)) - (///////phase\wrap ( false idx)) + (///////phase\wrap ( false idx #.None)) (^ ( idx nextP)) (|> nextP recur - (\ ///////phase.monad map (_.progn ( true idx))))]) + (\ ///////phase.monad map (|>> #.Some ( 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 [ ] - [(^ ( preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap ( 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 [ ] [(type: #export - ( Var/1 (Expression Any) (Expression Any)))] + ( [_.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 (_.