From c0acd75d41ed0e927ec318d4b12c0ec4f5f2e1d3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 2 Jul 2017 15:52:36 -0400 Subject: - Adjusted compiler to the new lack of Char type. - WIP: PM/case synthesis. --- new-luxc/source/luxc/analyser.lux | 1 - new-luxc/source/luxc/analyser/case.lux | 2 - new-luxc/source/luxc/analyser/case/coverage.lux | 2 +- new-luxc/source/luxc/analyser/primitive.lux | 1 - new-luxc/source/luxc/generator/expr.jvm.lux | 1 - new-luxc/source/luxc/generator/host/jvm/def.lux | 2 +- new-luxc/source/luxc/generator/host/jvm/inst.lux | 4 +- new-luxc/source/luxc/generator/host/jvm/type.lux | 2 +- new-luxc/source/luxc/generator/primitive.jvm.lux | 1 - new-luxc/source/luxc/lang/analysis.lux | 6 +- new-luxc/source/luxc/lang/synthesis.lux | 10 +-- .../source/luxc/module/descriptor/annotation.lux | 3 - new-luxc/source/luxc/module/descriptor/common.lux | 9 +- new-luxc/source/luxc/module/descriptor/type.lux | 1 - new-luxc/source/luxc/parser.lux | 65 ++++---------- new-luxc/source/luxc/synthesizer.lux | 67 +++++++------- new-luxc/source/luxc/synthesizer/case.lux | 91 +++++++++++++++++++ new-luxc/source/luxc/synthesizer/function.lux | 4 + new-luxc/source/luxc/synthesizer/variable.lux | 100 +++++++++++++++++++++ 19 files changed, 263 insertions(+), 109 deletions(-) create mode 100644 new-luxc/source/luxc/synthesizer/case.lux create mode 100644 new-luxc/source/luxc/synthesizer/variable.lux (limited to 'new-luxc/source') diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index e79b74f01..799e2365d 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -53,7 +53,6 @@ [#;Int &&primitive;analyse-int] [#;Deg &&primitive;analyse-deg] [#;Real &&primitive;analyse-real] - [#;Char &&primitive;analyse-char] [#;Text &&primitive;analyse-text]) (^ (#;Tuple (list))) diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux index 7d580f3b4..30d0a2b7a 100644 --- a/new-luxc/source/luxc/analyser/case.lux +++ b/new-luxc/source/luxc/analyser/case.lux @@ -4,7 +4,6 @@ eq) (data [bool "B/" Eq] [number] - [char] [text] text/format [product] @@ -104,7 +103,6 @@ [Int #;Int #la;IntP] [Deg #;Deg #la;DegP] [Real #;Real #la;RealP] - [Char #;Char #la;CharP] [Text #;Text #la;TextP]) (^ [cursor (#;Tuple (list))]) diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux index 5989952ee..88e40ac0f 100644 --- a/new-luxc/source/luxc/analyser/case/coverage.lux +++ b/new-luxc/source/luxc/analyser/case/coverage.lux @@ -54,7 +54,7 @@ ## Primitive patterns always have partial coverage because there ## are too many possibilities as far as values go. (^or (#la;NatP _) (#la;IntP _) (#la;DegP _) - (#la;RealP _) (#la;CharP _) (#la;TextP _)) + (#la;RealP _) (#la;TextP _)) #Partial ## Bools are the exception, since there is only "true" and diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux index 26580a503..9102acda5 100644 --- a/new-luxc/source/luxc/analyser/primitive.lux +++ b/new-luxc/source/luxc/analyser/primitive.lux @@ -21,7 +21,6 @@ [analyse-int Int #la;Int] [analyse-deg Deg #la;Deg] [analyse-real Real #la;Real] - [analyse-char Char #la;Char] [analyse-text Text #la;Text] ) diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux index 32291317f..32f8bde31 100644 --- a/new-luxc/source/luxc/generator/expr.jvm.lux +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -27,7 +27,6 @@ [#ls;Int &primitive;generate-int] [#ls;Deg &primitive;generate-deg] [#ls;Real &primitive;generate-real] - [#ls;Char &primitive;generate-char] [#ls;Text &primitive;generate-text]) (#ls;Variant tag tail? member) diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux index 39fab2f2a..6f0f97d9b 100644 --- a/new-luxc/source/luxc/generator/host/jvm/def.lux +++ b/new-luxc/source/luxc/generator/host/jvm/def.lux @@ -255,7 +255,7 @@ [long-field Int $t;long id] [float-field Real $t;float host;d2f] [double-field Real $t;double id] - [char-field Char $t;char id] + [char-field Nat $t;char (|>. nat-to-int host;l2i host;i2c)] [string-field Text ($t;class "java.lang.String" (list)) id] ) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index 82b360883..824598ab8 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -1,5 +1,5 @@ (;module: - lux + [lux #- char] (lux [host #+ jvm-import do-to]) ["$" ..] (.. ["$t" type])) @@ -122,7 +122,7 @@ [int Int host;l2i] [long Int id] [double Real id] - [char Char id] + [char Nat (|>. nat-to-int host;l2i host;i2c)] [string Text id] ) diff --git a/new-luxc/source/luxc/generator/host/jvm/type.lux b/new-luxc/source/luxc/generator/host/jvm/type.lux index b457ac636..3825d443b 100644 --- a/new-luxc/source/luxc/generator/host/jvm/type.lux +++ b/new-luxc/source/luxc/generator/host/jvm/type.lux @@ -1,5 +1,5 @@ (;module: - lux + [lux #- char] (lux (data [text] text/format (coll [list "L/" Functor]))) diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux index c444f791d..2cb01a6aa 100644 --- a/new-luxc/source/luxc/generator/primitive.jvm.lux +++ b/new-luxc/source/luxc/generator/primitive.jvm.lux @@ -33,6 +33,5 @@ [generate-int Int $i;long $i;wrap-long] [generate-deg Deg (|>. (:! Int) $i;long) $i;wrap-long] [generate-real Real $i;double $i;wrap-double] - [generate-char Char $i;char $i;wrap-char] [generate-text Text $i;string id] ) diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux index 2e122a526..308296086 100644 --- a/new-luxc/source/luxc/lang/analysis.lux +++ b/new-luxc/source/luxc/lang/analysis.lux @@ -4,16 +4,15 @@ (data (coll [list "L/" Fold])))) (type: #export #rec Pattern - (#BindP Nat) (#BoolP Bool) (#NatP Nat) (#IntP Int) (#DegP Deg) (#RealP Real) - (#CharP Char) (#TextP Text) (#TupleP (List Pattern)) - (#VariantP Nat Nat Pattern)) + (#VariantP Nat Nat Pattern) + (#BindP Nat)) (type: #export #rec Analysis #Unit @@ -22,7 +21,6 @@ (#Int Int) (#Deg Deg) (#Real Real) - (#Char Char) (#Text Text) (#Sum (Either Analysis Analysis)) (#Product Analysis Analysis) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux index b86f49fb2..ad31d0138 100644 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ b/new-luxc/source/luxc/lang/synthesis.lux @@ -6,17 +6,16 @@ (def: #export Variable Int) (type: #export (Path' s) - #PopP - (#BindP Nat) + #UnitP (#BoolP Bool) (#NatP Nat) (#IntP Int) (#DegP Deg) (#RealP Real) - (#CharP Char) (#TextP Text) - (#VariantP (Either Nat Nat)) - (#TupleP (Either Nat Nat)) + (#VariantP (Either Nat Nat) (Path' s)) + (#TupleP (Either Nat Nat) (Path' s)) + (#BindP Nat) (#AltP (Path' s) (Path' s)) (#SeqP (Path' s) (Path' s)) (#ExecP s)) @@ -28,7 +27,6 @@ (#Int Int) (#Deg Deg) (#Real Real) - (#Char Char) (#Text Text) (#Variant Nat Bool Synthesis) (#Tuple (List Synthesis)) diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux index d5e0d8000..ed5419974 100644 --- a/new-luxc/source/luxc/module/descriptor/annotation.lux +++ b/new-luxc/source/luxc/module/descriptor/annotation.lux @@ -5,7 +5,6 @@ (data [text] (text format ["l" lexer "l/" Monad]) - [char] [number] error (coll [list "L/" Functor]))) @@ -23,7 +22,6 @@ [int-signal "I"] [deg-signal "D"] [real-signal "R"] - [char-signal "C"] [text-signal "T"] [list-signal "%"] [dict-signal "#"] @@ -54,7 +52,6 @@ [#;IntA int-signal %i] [#;DegA deg-signal %d] [#;RealA real-signal %r] - [#;CharA char-signal %c] [#;TextA text-signal %t] [#;IdentA ident-signal %ident] [#;ListA list-signal (&;encode-list encode-ann-value)] diff --git a/new-luxc/source/luxc/module/descriptor/common.lux b/new-luxc/source/luxc/module/descriptor/common.lux index 60a313115..aac438a6f 100644 --- a/new-luxc/source/luxc/module/descriptor/common.lux +++ b/new-luxc/source/luxc/module/descriptor/common.lux @@ -3,17 +3,16 @@ (lux (data [text] (text format ["l" lexer "l/" Monad]) - [char] (coll [list "L/" Functor])))) (type: #export Signal Text) (do-template [ ] - [(def: #export Signal (|> char;char char;as-text))] + [(def: #export Signal )] - [cons-signal +5] - [nil-signal +6] - [stop-signal +7] + [cons-signal "\u0005"] + [nil-signal "\u0006"] + [stop-signal "\u0007"] ) (do-template [ ] diff --git a/new-luxc/source/luxc/module/descriptor/type.lux b/new-luxc/source/luxc/module/descriptor/type.lux index dd11a163f..bcf44e5a2 100644 --- a/new-luxc/source/luxc/module/descriptor/type.lux +++ b/new-luxc/source/luxc/module/descriptor/type.lux @@ -5,7 +5,6 @@ (data [text] (text format ["l" lexer "l/" Monad]) - [char] [number] ["R" result] (coll [list "L/" Functor])) diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux index 1e280e62b..7d9c77f2b 100644 --- a/new-luxc/source/luxc/parser.lux +++ b/new-luxc/source/luxc/parser.lux @@ -30,7 +30,6 @@ (lux (control monad ["p" parser "p/" Monad]) (data [bool] - [char] [text] ["R" result] [number] @@ -160,29 +159,28 @@ ## and 4 characters long (e.g. \u12aB). ## Escaped characters may show up in Char and Text literals. (def: escaped-char^ - (l;Lexer [Text Char]) + (l;Lexer [Nat Text]) (p;after (l;this "\\") (do p;Monad [code l;any] (case code ## Handle special cases. - "t" (wrap ["\\t" #"\t"]) - "v" (wrap ["\\v" #"\v"]) - "b" (wrap ["\\b" #"\b"]) - "n" (wrap ["\\n" #"\n"]) - "r" (wrap ["\\r" #"\r"]) - "f" (wrap ["\\f" #"\f"]) - "\"" (wrap ["\\\"" #"\""]) - "\\" (wrap ["\\\\" #"\\"]) + "t" (wrap [+2 "\t"]) + "v" (wrap [+2 "\v"]) + "b" (wrap [+2 "\b"]) + "n" (wrap [+2 "\n"]) + "r" (wrap [+2 "\r"]) + "f" (wrap [+2 "\f"]) + "\"" (wrap [+2 "\""]) + "\\" (wrap [+2 "\\"]) ## Handle unicode escapes. "u" (do p;Monad - [code (l;between +1 +4 l;hex-digit)] - (wrap (case (:: number;Hex@Codec decode - (format "+" code)) + [code (l;between +1 +4 l;hexadecimal)] + (wrap (case (|> code (format "+") (:: number;Hex@Codec decode)) (#;Right value) - [(format "\\u" code) (char;char value)] + [(n.+ +2 (text;size code)) (text;from-code value)] _ (undefined)))) @@ -190,31 +188,17 @@ _ (p;fail (format "Invalid escaping syntax: " (%t code))))))) -## A character can be either a normal glyph, or a escaped character. -## The reason why this parser returns both the Char and it's textual -## representation in the source-code, is for the sake of updating the -## cursor after parsing the char. -## A character only represents one glyph, but it's source-code -## representation may be multi-glyph (e.g. \u1234, \n), in which case, -## the text that was parsed needs to be counted to update the cursor. -(def: raw-char^ - (l;Lexer [Text Char]) - (p;either (do p;Monad - [char (l;none-of "\\\"\n")] - (wrap [char (|> char (text;nth +0) assume)])) - escaped-char^)) - ## These are very simple parsers that just cut chunks of text in ## specific shapes and then use decoders already present in the ## standard library to actually produce the values from the literals. (def: rich-digit (l;Lexer Text) - (p;either l;digit + (p;either l;decimal (p;after (l;this "_") (p/wrap "")))) (def: rich-digits^ (l;Lexer Text) - (l;seq l;digit + (l;seq l;decimal (l;some rich-digit))) (def: (marker^ token) @@ -262,16 +246,6 @@ number;Codec] ) -## This parser doesn't delegate the work of producing the value to a -## codec, since the raw-char^ parser already takes care of that magic. -(def: #export (parse-char where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [[chunk value] (l;enclosed ["#\"" "\""] - raw-char^)] - (wrap [(update@ #;column (|>. ($_ n.+ +3 (text;size chunk))) where) - [where (#;Char value)]]))) - ## This parser looks so complex because text in Lux can be multi-line ## and there are rules regarding how this is handled. (def: #export (parse-text where) @@ -334,10 +308,10 @@ ## Must handle escaped ## chars separately. (do @ - [[chunk char] escaped-char^] - (recur (format text-read (char;as-text char)) + [[chars-consumed char] escaped-char^] + (recur (format text-read char) (|> where - (update@ #;column (n.+ (text;size chunk)))) + (update@ #;column (n.+ chars-consumed))) false)) ## The text ends when it ## reaches the right-delimiter. @@ -538,15 +512,14 @@ (parse-deg where) (parse-symbol where) (parse-tag where) - (parse-char where) (parse-text where) ))) (def: #export (parse [where code]) (-> [Cursor Text] (R;Result [[Cursor Text] Code])) - (case (p;run code (parse-ast where)) + (case (p;run [+0 code] (parse-ast where)) (#R;Error error) (#R;Error error) - (#R;Success [remaining [where' output]]) + (#R;Success [[_ remaining] [where' output]]) (#R;Success [[where' remaining] output]))) diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 2f7344c6e..484864652 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -2,12 +2,14 @@ lux (lux (data text/format [number] + [product] (coll [list "L/" Functor Fold Monoid] ["d" dict]))) (luxc ["&" base] (lang ["la" analysis] ["ls" synthesis]) (synthesizer ["&&;" structure] + ["&&;" case] ["&&;" function] ["&&;" loop]) )) @@ -37,7 +39,6 @@ [#la;Int #ls;Int] [#la;Deg #ls;Deg] [#la;Real #ls;Real] - [#la;Char #ls;Char] [#la;Text #ls;Text] [#la;Absolute #ls;Definition]) @@ -63,6 +64,38 @@ (#ls;Variable (let [var (&&function;to-captured register)] (default var (d;get var resolver))))) + (#la;Case inputA branchesA) + (let [inputS (recur +0 resolver num-locals inputA)] + (case (list;reverse branchesA) + (^multi (^ (list [(#la;BindP input-register) + (#la;Relative (#;Local output-register))])) + (n.= input-register output-register)) + inputS + + (^ (list [(#la;BindP register) bodyA])) + (#ls;Let register inputS (recur +0 resolver num-locals bodyA)) + + (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA])) + (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA]))) + (#ls;If inputS + (recur +0 resolver num-locals thenA) + (recur +0 resolver num-locals elseA)) + + (#;Cons [lastP lastA] prevsPA) + (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) + (function [pattern expr] + (|> (recur +0 resolver num-locals expr) + #ls;ExecP + (#ls;SeqP (&&case;path pattern)))))] + (#ls;Case inputS + (L/fold &&case;weave + (transform-branch lastP lastA) + (L/map (product;uncurry transform-branch) prevsPA)))) + + _ + (undefined) + )) + (#la;Function scope bodyA) (let [inner-arity (n.inc outer-arity) raw-env (&&function;environment scope) @@ -111,36 +144,4 @@ (#la;Procedure name args) (#ls;Procedure name (L/map (recur +0 resolver num-locals) args)) - - _ - (undefined) - - ## (#la;Case inputA branchesA) - ## (let [inputS (recur +0 local-offset false inputA)] - ## (case branchesA - ## (^multi (^ (list [(#lp;Bind input-register) - ## (#la;Variable (#;Local output-register))])) - ## (n.= input-register output-register)) - ## inputS - - ## (^ (list [(#lp;Bind register) bodyA])) - ## (#ls;Let register inputS (recur +0 local-offset tail? bodyA)) - - ## (^or (^ (list [(#lp;Bool true) thenA] [(#lp;Bool false) elseA])) - ## (^ (list [(#lp;Bool false) elseA] [(#lp;Bool true) thenA]))) - ## (#ls;If inputS - ## (recur +0 local-offset tail? thenA) - ## (recur +0 local-offset tail? elseA)) - - ## (#;Cons [headP headA] tailPA) - ## (let [headP+ (|> (recur +0 local-offset tail? headA) - ## #ls;ExecP - ## (#ls;SeqP (&&case;path headP))) - ## tailP+ (L/map (function [[pattern bodyA]] - ## (|> (recur +0 local-offset tail? bodyA) - ## #ls;ExecP - ## (#ls;SeqP (&&case;path pattern)))) - ## tailPA)] - ## (#ls;Case inputS (&&case;weave-paths headP+ tailP+))) - ## )) ))) diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux new file mode 100644 index 000000000..ee2ef84b0 --- /dev/null +++ b/new-luxc/source/luxc/synthesizer/case.lux @@ -0,0 +1,91 @@ +(;module: + lux + (lux (data [bool "B/" Eq] + [text "T/" Eq] + [number] + (coll [list "L/" Functor Fold Monoid] + ["s" set]))) + (luxc (lang ["la" analysis] + ["ls" synthesis]) + (synthesizer ["&;" function]))) + +(def: #export (path pattern) + (-> la;Pattern ls;Path) + (case pattern + (^template [ ] + ( register) + ( register)) + ([#la;BindP #ls;BindP] + [#la;BoolP #ls;BoolP] + [#la;NatP #ls;NatP] + [#la;IntP #ls;IntP] + [#la;DegP #ls;DegP] + [#la;RealP #ls;RealP] + [#la;TextP #ls;TextP]) + + (#la;TupleP membersP) + (case (list;reverse membersP) + #;Nil + #ls;UnitP + + (#;Cons singletonP #;Nil) + (path singletonP) + + (#;Cons lastP prevsP) + (let [length (list;size membersP) + last-idx (n.dec length) + last-path (#ls;TupleP (#;Right last-idx) (path lastP)) + [_ tuple-path] (L/fold (function [current-pattern [current-idx next-path]] + [(n.dec current-idx) + (#ls;SeqP (#ls;TupleP (#;Left current-idx) + (path current-pattern)) + next-path)]) + [(n.dec last-idx) last-path] + prevsP)] + tuple-path)) + + (#la;VariantP tag num-tags memberP) + (let [last? (n.= (n.dec num-tags) tag)] + (#ls;VariantP (if last? (#;Right tag) (#;Left tag)) + (path memberP))))) + +(def: #export (weave nextP prevP) + (-> ls;Path ls;Path ls;Path) + (with-expansions [ (as-is (#ls;AltP prevP nextP))] + (case [nextP prevP] + [#ls;UnitP #ls;UnitP] + #ls;UnitP + + (^template [ ] + [( next) ( prev)] + (if ( next prev) + prevP + )) + ([#ls;BindP n.=] + [#ls;BoolP B/=] + [#ls;NatP n.=] + [#ls;IntP i.=] + [#ls;DegP d.=] + [#ls;RealP r.=] + [#ls;TextP T/=]) + + (^template [ ] + [( ( next-idx) next-then) ( ( prev-idx) prev-then)] + (if (n.= next-idx prev-idx) + (weave next-then prev-then) + )) + ([#ls;TupleP #;Left] + [#ls;TupleP #;Right] + [#ls;VariantP #;Left] + [#ls;VariantP #;Right]) + + [(#ls;SeqP next-pre next-post) (#ls;SeqP prev-pre prev-post)] + (case (weave next-pre prev-pre) + (#ls;AltP _ _) + + + weavedP + (#ls;SeqP weavedP (weave next-post prev-post))) + + _ + ))) diff --git a/new-luxc/source/luxc/synthesizer/function.lux b/new-luxc/source/luxc/synthesizer/function.lux index 42aa7a6cd..e8b2a7ec4 100644 --- a/new-luxc/source/luxc/synthesizer/function.lux +++ b/new-luxc/source/luxc/synthesizer/function.lux @@ -44,6 +44,10 @@ (-> Nat Int) (|> idx n.inc nat-to-int (i.* -1))) +(def: #export (captured-idx idx) + (-> Int Nat) + (|> idx (i.* -1) int-to-nat n.dec)) + (def: #export (to-local idx) (-> Nat Int) (nat-to-int idx)) diff --git a/new-luxc/source/luxc/synthesizer/variable.lux b/new-luxc/source/luxc/synthesizer/variable.lux new file mode 100644 index 000000000..3a48cb3f2 --- /dev/null +++ b/new-luxc/source/luxc/synthesizer/variable.lux @@ -0,0 +1,100 @@ +(;module: + lux + (lux (data [bool "B/" Eq] + [text "T/" Eq] + [number] + (coll [list "L/" Functor Fold Monoid] + ["s" set]))) + (luxc (lang ["la" analysis] + ["ls" synthesis]) + (synthesizer ["&;" function]))) + +(def: (bound-vars path) + (-> ls;Path (List ls;Variable)) + (case path + (#ls;BindP register) + (list (nat-to-int register)) + + (^or (#ls;SeqP pre post) (#ls;AltP pre post)) + (L/append (bound-vars pre) (bound-vars post)) + + _ + (list))) + +(def: (path-bodies path) + (-> ls;Path (List ls;Synthesis)) + (case path + (#ls;ExecP body) + (list body) + + (#ls;SeqP pre post) + (path-bodies post) + + (#ls;AltP pre post) + (L/append (path-bodies pre) (path-bodies post)) + + _ + (list))) + +(def: (non-arg? arity var) + (-> ls;Arity ls;Variable Bool) + (and (&function;local? var) + (n.> arity (int-to-nat var)))) + +(type: Tracker (s;Set ls;Variable)) + +(def: init-tracker Tracker (s;new number;Hash)) + +(def: (unused-vars current-arity bound exprS) + (-> ls;Arity (List ls;Variable) ls;Synthesis (List ls;Variable)) + (let [tracker (loop [exprS exprS + tracker (L/fold s;add init-tracker bound)] + (case exprS + (#ls;Variable var) + (if (non-arg? current-arity var) + (s;remove var tracker) + tracker) + + (#ls;Variant tag last? memberS) + (recur memberS tracker) + + (#ls;Tuple membersS) + (L/fold recur tracker membersS) + + (#ls;Call funcS argsS) + (L/fold recur (recur funcS tracker) argsS) + + (^or (#ls;Recur argsS) + (#ls;Procedure name argsS)) + (L/fold recur tracker argsS) + + (#ls;Let offset inputS outputS) + (|> tracker (recur inputS) (recur outputS)) + + (#ls;If testS thenS elseS) + (|> tracker (recur testS) (recur thenS) (recur elseS)) + + (#ls;Loop offset initsS bodyS) + (recur bodyS (L/fold recur tracker initsS)) + + (#ls;Case inputS outputPS) + (let [tracker' (L/fold s;add + (recur inputS tracker) + (bound-vars outputPS))] + (L/fold recur tracker' (path-bodies outputPS))) + + (#ls;Function arity env bodyS) + (L/fold s;remove tracker env) + + _ + tracker + ))] + (s;to-list tracker))) + +## (def: (optimize-register-use current-arity [pathS bodyS]) +## (-> ls;Arity [ls;Path ls;Synthesis] [ls;Path ls;Synthesis]) +## (let [bound (bound-vars pathS) +## unused (unused-vars current-arity bound bodyS) +## adjusted (adjust-vars unused bound)] +## [(|> pathS (clean-pattern adjusted) simplify-pattern) +## (clean-expression adjusted bodyS)])) -- cgit v1.2.3