diff options
| author | Eduardo Julian | 2018-06-17 00:27:21 -0400 | 
|---|---|---|
| committer | Eduardo Julian | 2018-06-17 00:27:21 -0400 | 
| commit | b6ccfc87c52e1a98ead3b04b45bccc119418a4dc (patch) | |
| tree | db13d4605a0a3041de6ef2ef5ddc92b766f1a7f3 /stdlib/source/lux/lang | |
| parent | bcd3d9ee8f6797f758a2abea98d5cb6a74cc7df0 (diff) | |
- Migrated Scheme back-end to stdlib.
Diffstat (limited to '')
23 files changed, 1855 insertions, 105 deletions
| diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux index 2259b615b..322b9f655 100644 --- a/stdlib/source/lux/lang.lux +++ b/stdlib/source/lux/lang.lux @@ -16,6 +16,10 @@  (type: #export Eval    (-> Type Code (Meta Any))) +(type: #export Version Text) + +(def: #export version Version "0.6.0") +  (def: #export (fail message)    (All [a] (-> Text (Meta a)))    (do macro.Monad<Meta> diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux index 0996ad1f4..6efa934d8 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/analysis.lux @@ -77,7 +77,11 @@  (type: #export (Tuple a) (List a)) -(type: #export Application [Analysis (List Analysis)]) +(type: #export Arity Nat) + +(type: #export (Abstraction c) [Environment Arity c]) + +(type: #export (Application c) [c (List c)])  (def: (last? size tag)    (-> Nat Tag Bool) @@ -131,7 +135,7 @@    )  (def: #export (apply [func args]) -  (-> Application Analysis) +  (-> (Application Analysis) Analysis)    (list/fold (function (_ arg func) (#Apply arg func)) func args))  (type: #export Analyser @@ -180,7 +184,7 @@    )  (def: #export (application analysis) -  (-> Analysis Application) +  (-> Analysis (Application Analysis))    (case analysis      (#Apply head func)      (let [[func' tail] (application func)] diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux index d9eb90fc9..7edac52c3 100644 --- a/stdlib/source/lux/lang/extension.lux +++ b/stdlib/source/lux/lang/extension.lux @@ -4,16 +4,16 @@                  ["ex" exception #+ exception:])         (data ["e" error]               [text] -             (coll (dictionary ["dict" unordered #+ Dict]))) -       [macro]) +             (coll (dictionary ["dict" unordered #+ Dict]))))    [// #+ Eval]    [//compiler #+ Operation Compiler]    [//analysis #+ Analyser] -  [//synthesis #+ Synthesizer]) +  [//synthesis #+ Synthesizer] +  [//translation #+ Translator])  (do-template [<name>] -  [(exception: #export (<name> {message Text}) -     message)] +  [(exception: #export (<name> {extension Text}) +     extension)]    [unknown-analysis]    [unknown-synthesis] @@ -27,7 +27,10 @@    )  (type: #export Analysis -  (-> Analyser Eval (List Code) (Meta //analysis.Analysis))) +  (-> Analyser Eval +      (Compiler .Lux +                (List Code) +                //analysis.Analysis)))  (type: #export Synthesis    (-> Synthesizer @@ -35,8 +38,11 @@                  (List //analysis.Analysis)                  //synthesis.Synthesis))) -(type: #export Translation -  (-> (List Code) (Meta Code))) +(type: #export (Translation anchor code) +  (-> (Translator anchor code) +      (Compiler (//translation.State anchor code) +                (List //synthesis.Synthesis) +                code)))  (type: #export Statement    (-> (List Code) (Meta Any))) @@ -72,14 +78,14 @@  (do-template [<name> <type> <category> <exception>]    [(def: #export (<name> name)       (-> Text (Meta <type>)) -     (do macro.Monad<Meta> +     (do //compiler.Monad<Operation>         [extensions ..get]         (case (dict.get name (get@ <category> extensions))           (#.Some extension)           (wrap extension)           #.None -         (//.throw <exception> name))))] +         (//compiler.throw <exception> name))))]    [find-analysis    Analysis    #analysis    unknown-analysis]    [find-synthesis   Synthesis   #synthesis   unknown-synthesis] @@ -91,25 +97,30 @@    (All [e] (Extension e))    (dict.new text.Hash<Text>)) -(do-template [<all> <type> <category>] +(do-template [<params> <all> <state> <type> <category>]    [(def: #export <all> -     (Meta (Extension <type>)) +     (All <params> (Operation <state> (Extension <type>)))       (|> ..get -         (:: macro.Monad<Meta> map (get@ <category>))))] - -  [all-analyses     Analysis    #analysis] -  [all-syntheses    Synthesis   #synthesis] -  [all-translations Translation #translation] -  [all-statements   Statement   #statement] +         (:: //compiler.Monad<Operation> map (get@ <category>))))] + +  [[]            all-analyses     .Lux +   Analysis    #analysis] +  [[]            all-syntheses    //synthesis.State +   Synthesis   #synthesis] +  [[anchor code] all-translations (//translation.State anchor code) +   Translation #translation] +  [[]            all-statements   Any +   Statement   #statement]    )  (do-template [<name> <type> <category> <exception>]    [(def: #export (<name> name extension)       (-> Text <type> (Meta Any)) -     (do macro.Monad<Meta> +     (do //compiler.Monad<Operation>         [extensions ..get -        _ (//.assert <exception> name -                     (not (dict.contains? name (get@ <category> extensions)))) +        _ (if (not (dict.contains? name (get@ <category> extensions))) +            (wrap []) +            (//compiler.throw <exception> name))          _ (..set (update@ <category> (dict.put name extension) extensions))]         (wrap [])))] diff --git a/new-luxc/source/luxc/lang/extension/synthesis.lux b/stdlib/source/lux/lang/extension/synthesis.lux index c48f3e3a5..c48f3e3a5 100644 --- a/new-luxc/source/luxc/lang/extension/synthesis.lux +++ b/stdlib/source/lux/lang/extension/synthesis.lux diff --git a/new-luxc/source/luxc/lang/extension/translation.lux b/stdlib/source/lux/lang/extension/translation.lux index bc95ed1f4..bc95ed1f4 100644 --- a/new-luxc/source/luxc/lang/extension/translation.lux +++ b/stdlib/source/lux/lang/extension/translation.lux diff --git a/stdlib/source/lux/lang/host/scheme.lux b/stdlib/source/lux/lang/host/scheme.lux new file mode 100644 index 000000000..f6e7b1834 --- /dev/null +++ b/stdlib/source/lux/lang/host/scheme.lux @@ -0,0 +1,302 @@ +(.module: +  [lux #- Code' Code int or and if function cond when let] +  (lux (control pipe) +       (data [text] +             text/format +             [number] +             (coll [list "list/" Functor<List> Fold<List>])) +       (type abstract))) + +(abstract: Global' {} Any) +(abstract: Var' {} Any) +(abstract: Computation' {} Any) +(abstract: (Expression' k) {} Any) + +(abstract: (Code' k) +  {} +   +  Text + +  (type: #export Code (Ex [k] (Code' k))) +  (type: #export Expression (Code' (Ex [k] (Expression' k)))) +  (type: #export Global (Code' (Expression' Global'))) +  (type: #export Computation (Code' (Expression' Computation'))) +  (type: #export Var (Code' (Expression' Var'))) + +  (type: #export Arguments +    {#mandatory (List Var) +     #rest (Maybe Var)}) + +  (def: #export code (-> Code Text) (|>> @representation)) + +  (def: #export var (-> Text Var) (|>> @abstraction)) + +  (def: (arguments [vars rest]) +    (-> Arguments Code) +    (case rest +      (#.Some rest) +      (case vars +        #.Nil +        rest + +        _ +        (|> (format " . " (@representation rest)) +            (format (|> vars +                        (list/map ..code) +                        (text.join-with " "))) +            (text.enclose ["(" ")"]) +            @abstraction)) +       +      #.None +      (|> vars +          (list/map ..code) +          (text.join-with " ") +          (text.enclose ["(" ")"]) +          @abstraction))) + +  (def: #export nil +    Computation +    (@abstraction "'()")) + +  (def: #export bool +    (-> Bool Computation) +    (|>> (case> true "#t" +                false "#f") +         @abstraction)) + +  (def: #export int +    (-> Int Computation) +    (|>> %i @abstraction)) + +  (def: #export float +    (-> Frac Computation) +    (|>> (cond> [(f/= number.positive-infinity)] +                [(new> "+inf.0")] +                 +                [(f/= number.negative-infinity)] +                [(new> "-inf.0")] +                 +                [number.not-a-number?] +                [(new> "+nan.0")] +                 +                ## else +                [%f]) +         @abstraction)) + +  (def: #export positive-infinity Computation (..float number.positive-infinity)) +  (def: #export negative-infinity Computation (..float number.negative-infinity)) +  (def: #export not-a-number Computation (..float number.not-a-number)) + +  (def: #export string +    (-> Text Computation) +    (|>> %t @abstraction)) + +  (def: #export symbol +    (-> Text Computation) +    (|>> (format "'") @abstraction)) + +  (def: #export global +    (-> Text Global) +    (|>> @abstraction)) + +  (def: form +    (-> (List Code) Text) +    (|>> (list/map ..code) +         (text.join-with " ") +         (text.enclose ["(" ")"]))) +   +  (def: #export (apply/* func args) +    (-> Expression (List Expression) Computation) +    (@abstraction (..form (#.Cons func args)))) +   +  (do-template [<name> <function>] +    [(def: #export <name> +       (-> (List Expression) Computation) +       (apply/* (..global <function>)))] + +    [vector/* "vector"] +    [list/*   "list"] +    ) + +  (def: #export (apply/0 func) +    (-> Expression Computation) +    (..apply/* func (list))) + +  (do-template [<lux-name> <scheme-name>] +    [(def: #export <lux-name> (apply/0 (..global <scheme-name>)))] + +    [newline/0 "newline"] +    ) + +  (def: #export (apply/1 func) +    (-> Expression (-> Expression Computation)) +    (|>> (list) (..apply/* func))) + +  (do-template [<lux-name> <scheme-name>] +    [(def: #export <lux-name> (apply/1 (..global <scheme-name>)))] + +    [exact/1 "exact"] +    [integer->char/1 "integer->char"] +    [number->string/1 "number->string"] +    [string/1 "string"] +    [length/1 "length"] +    [values/1 "values"] +    [null?/1 "null?"] +    [car/1 "car"] +    [cdr/1 "cdr"] +    [raise/1 "raise"] +    [error-object-message/1 "error-object-message"] +    [make-vector/1 "make-vector"] +    [vector-length/1 "vector-length"] +    [not/1 "not"] +    [string-length/1 "string-length"] +    [string-hash/1 "string-hash"] +    [reverse/1 "reverse"] +    [display/1 "display"] +    [exit/1 "exit"] +    ) +   +  (def: #export (apply/2 func) +    (-> Expression (-> Expression Expression Computation)) +    (.function (_ _0 _1) +      (..apply/* func (list _0 _1)))) + +  (do-template [<lux-name> <scheme-name>] +    [(def: #export <lux-name> (apply/2 (..global <scheme-name>)))] + +    [append/2 "append"] +    [cons/2 "cons"] +    [make-vector/2 "make-vector"] +    [vector-ref/2 "vector-ref"] +    [list-tail/2 "list-tail"] +    [map/2 "map"] +    [string-ref/2 "string-ref"] +    [string-append/2 "string-append"] +    ) + +  (do-template [<lux-name> <scheme-name>] +    [(def: #export (<lux-name> param subject) +       (-> Expression Expression Computation) +       (..apply/2 (..global <scheme-name>) subject param))] + +    [=/2   "="] +    [eq?/2 "eq?"] +    [eqv?/2 "eqv?"] +    [</2   "<"] +    [<=/2  "<="] +    [>/2   ">"] +    [>=/2  ">="] +    [string=?/2 "string=?"] +    [string<?/2 "string<?"] +    [+/2   "+"] +    [-/2   "-"] +    [//2   "/"] +    [*/2   "*"] +    [expt/2 "expt"] +    [remainder/2 "remainder"] +    [quotient/2 "quotient"] +    [mod/2 "mod"] +    [arithmetic-shift/2 "arithmetic-shift"] +    [bit-and/2 "bitwise-and"] +    [bit-or/2 "bitwise-ior"] +    [bit-xor/2 "bitwise-xor"] +    ) + +  (def: #export (apply/3 func) +    (-> Expression (-> Expression Expression Expression Computation)) +    (.function (_ _0 _1 _2) +      (..apply/* func (list _0 _1 _2)))) + +  (do-template [<lux-name> <scheme-name>] +    [(def: #export <lux-name> (apply/3 (..global <scheme-name>)))] + +    [substring/3 "substring"] +    [vector-set!/3 "vector-set!"] +    ) + +  (def: #export (vector-copy!/5 _0 _1 _2 _3 _4) +    (-> Expression Expression Expression Expression Expression +        Computation) +    (..apply/* (..global "vector-copy!") +               (list _0 _1 _2 _3 _4))) +   +  (do-template [<lux-name> <scheme-name>] +    [(def: #export <lux-name> +       (-> (List Expression) Computation) +       (|>> (list& (..global <scheme-name>)) ..form @abstraction))] + +    [or "or"] +    [and "and"] +    ) + +  (do-template [<lux-name> <scheme-name> <var> <pre>] +    [(def: #export (<lux-name> bindings body) +       (-> (List [<var> Expression]) Expression Computation) +       (@abstraction +        (..form (list (..global <scheme-name>) +                      (|> bindings +                          (list/map (.function (_ [binding/name binding/value]) +                                      (@abstraction +                                       (..form (list (<pre> binding/name) +                                                     binding/value))))) +                          ..form +                          @abstraction) +                      body))))] + +    [let           "let"           Var       .id] +    [let*          "let*"          Var       .id] +    [letrec        "letrec"        Var       .id] +    [let-values    "let-values"    Arguments ..arguments] +    [let*-values   "let*-values"   Arguments ..arguments] +    [letrec-values "letrec-values" Arguments ..arguments] +    ) + +  (def: #export (if test then else) +    (-> Expression Expression Expression Computation) +    (@abstraction +     (..form (list (..global "if") test then else)))) + +  (def: #export (when test then) +    (-> Expression Expression Computation) +    (@abstraction +     (..form (list (..global "when") test then)))) + +  (def: #export (cond clauses else) +    (-> (List [Expression Expression]) Expression Computation) +    (|> (list/fold (.function (_ [test then] next) +                     (if test then next)) +                   else +                   (list.reverse clauses)) +        @representation +        @abstraction)) + +  (def: #export (lambda arguments body) +    (-> Arguments Expression Computation) +    (@abstraction +     (..form (list (..global "lambda") +                   (..arguments arguments) +                   body)))) + +  (def: #export (define name arguments body) +    (-> Var Arguments Expression Computation) +    (@abstraction +     (..form (list (..global "define") +                   (|> arguments +                       (update@ #mandatory (|>> (#.Cons name))) +                       ..arguments) +                   body)))) + +  (def: #export begin +    (-> (List Expression) Computation) +    (|>> (#.Cons (..global "begin")) ..form @abstraction)) + +  (def: #export (set! name value) +    (-> Var Expression Computation) +    (@abstraction +     (..form (list (..global "set!") name value)))) + +  (def: #export (with-exception-handler handler body) +    (-> Expression Expression Computation) +    (@abstraction +     (..form (list (..global "with-exception-handler") handler body)))) +  ) diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux index 9c909942e..40a7fc69c 100644 --- a/stdlib/source/lux/lang/init.lux +++ b/stdlib/source/lux/lang/init.lux @@ -1,10 +1,11 @@  (.module:    lux +  [//]    (// ["//." target]        [".L" extension]        (extension [".E" analysis] -                 ## [".E" synthesis] -                 ## [".E" translation] +                 [".E" synthesis] +                 [".E" translation]                   ## [".E" statement]                   ))) @@ -26,10 +27,6 @@     #.var-counter +0     #.var-bindings (list)}) -(type: #export Version Text) - -(def: #export version Version "0.6.0") -  (`` (def: #export info        Info        {#.target  (for {(~~ (static //target.common-lisp)) //target.common-lisp @@ -41,7 +38,7 @@                         (~~ (static //target.r))           //target.r                         (~~ (static //target.ruby))        //target.ruby                         (~~ (static //target.scheme))      //target.scheme}) -       #.version ..version +       #.version //.version         #.mode    #.Build}))  (def: #export (compiler host) @@ -57,8 +54,8 @@     #.seed            +0     #.scope-type-vars (list)     #.extensions      {#extensionL.analysis analysisE.defaults -                      #extensionL.synthesis (:!! []) ## synthesisE.defaults -                      #extensionL.translation (:!! []) ## translationE.defaults +                      #extensionL.synthesis synthesisE.defaults +                      #extensionL.translation translationE.defaults                        #extensionL.statement (:!! []) ## statementE.defaults                        }     #.host            host}) diff --git a/new-luxc/source/luxc/lang.lux b/stdlib/source/lux/lang/name.lux index f02af30c5..1053eb76f 100644 --- a/new-luxc/source/luxc/lang.lux +++ b/stdlib/source/lux/lang/name.lux @@ -4,7 +4,7 @@               [text]               text/format))) -(def: (normalize-char char) +(def: (sanitize char)    (-> Nat Text)    (case char      (^ (char "*")) "_ASTER_" @@ -30,15 +30,18 @@      (^ (char ">")) "_GT_"      (^ (char "~")) "_TILDE_"      (^ (char "|")) "_PIPE_" -    _ -    (text.from-code char))) +    _              (text.from-code char))) -(def: underflow Nat (dec +0)) - -(def: #export (normalize-name name) +(def: #export (normalize name)    (-> Text Text) -  (loop [idx (dec (text.size name)) -         output ""] -    (if (n/= underflow idx) -      output -      (recur (dec idx) (format (|> (text.nth idx name) maybe.assume normalize-char) output))))) +  (let [name/size (text.size name)] +    (loop [idx +0 +           output ""] +      (if (n/< name/size idx) +        (recur (inc idx) +               (|> (text.nth idx name) maybe.assume sanitize (format output))) +        output)))) + +(def: #export (definition [module name]) +  (-> Ident Text) +  (format (normalize module) "___" (normalize name))) diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux index cc43ea0b3..1bf06cdd0 100644 --- a/stdlib/source/lux/lang/synthesis.lux +++ b/stdlib/source/lux/lang/synthesis.lux @@ -5,11 +5,9 @@               (coll (dictionary ["dict" unordered #+ Dict]))))    [// #+ Extension]    [//reference #+ Register Variable Reference] -  [//analysis #+ Environment Analysis] +  [//analysis #+ Environment Arity Analysis]    [//compiler #+ Operation Compiler]) -(type: #export Arity Nat) -  (type: #export Resolver (Dict Variable Variable))  (type: #export State @@ -66,8 +64,7 @@  (type: #export (Branch s)    (#Case s (Path' s))    (#Let s Register s) -  (#If s s s) -  (#Exec s)) +  (#If s s s))  (type: #export (Scope s)    {#start Register @@ -111,6 +108,29 @@    [path/text #..Text]    ) +(do-template [<name> <kind>] +  [(template: #export (<name> content) +     (.<| #..Access +          <kind> +          content))] + +  [path/side   #..Side] +  [path/member #..Member] +  ) + +(do-template [<name> <kind> <side>] +  [(template: #export (<name> content) +     (.<| #..Access +          <kind> +          <side> +          content))] + +  [side/left    #..Side   #.Left] +  [side/right   #..Side   #.Right] +  [member/left  #..Member #.Left] +  [member/right #..Member #.Right] +  ) +  (do-template [<name> <tag>]    [(template: #export (<name> content)       (<tag> content))] @@ -186,25 +206,34 @@  (do-template [<name> <tag>]    [(template: #export (<name> content) -     (<| #..Reference +     (<| #..Structure           <tag>           content))] +  [variant #..Variant] +  [tuple   #..Tuple] +  ) + +(do-template [<name> <tag>] +  [(template: #export (<name> content) +     (.<| #..Reference +          <tag> +          content))] +    [variable/local   //reference.local]    [variable/foreign //reference.foreign]    )  (do-template [<name> <family> <tag>]    [(template: #export (<name> content) -     (<| #..Control -         <family> -         <tag> -         content))] +     (.<| #..Control +          <family> +          <tag> +          content))]    [branch/case          #..Branch   #..Case]    [branch/let           #..Branch   #..Let]    [branch/if            #..Branch   #..If] -  [branch/exec          #..Branch   #..Exec]    [loop/scope           #..Loop     #..Scope]    [loop/recur           #..Loop     #..Recur] diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/synthesis/case.lux index 85065393d..b7f224168 100644 --- a/stdlib/source/lux/lang/synthesis/case.lux +++ b/stdlib/source/lux/lang/synthesis/case.lux @@ -126,45 +126,52 @@    (-> //.Synthesizer Analysis Match (Operation //.State Synthesis))    (do ///compiler.Monad<Operation>      [inputS (synthesize^ inputA)] -    (case [headB tailB+] -      [[(#///analysis.Bind inputR) headB/bodyA] -       #.Nil] -      (case headB/bodyA -        (^ (#///analysis.Reference (///reference.local outputR))) -        (wrap (if (n/= inputR outputR) -                inputS -                (//.branch/exec inputS))) - -        _ -        (do @ -          [arity //.scope-arity -           headB/bodyS (//.with-new-local -                         (synthesize^ headB/bodyA))] -          (wrap (//.branch/let [inputS -                                (if (//function.nested? arity) -                                  (n/+ (dec arity) inputR) -                                  inputR) -                                headB/bodyS])))) - -      (^or (^ [[(///analysis.pattern/bool true) thenA] -               (list [(///analysis.pattern/bool false) elseA])]) -           (^ [[(///analysis.pattern/bool false) elseA] -               (list [(///analysis.pattern/bool true) thenA])])) -      (do @ -        [thenS (synthesize^ thenA) -         elseS (synthesize^ elseA)] -        (wrap (//.branch/if [inputS thenS elseS]))) - -      _ -      (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) -                                        list.reverse -                                        (case> (#.Cons [lastP lastA] prevsPA) -                                               [[lastP lastA] prevsPA] - -                                               _ -                                               (undefined)))] -        (do @ -          [lastSP (path synthesize^ lastP lastA) -           prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] -          (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))) -      ))) +    (with-expansions [<unnecesary-let> +                      (as-is (^multi (^ (#///analysis.Reference (///reference.local outputR))) +                                     (n/= inputR outputR)) +                             (wrap inputS)) + +                      <let> +                      (as-is [[(#///analysis.Bind inputR) headB/bodyA] +                              #.Nil] +                             (case headB/bodyA +                               <unnecesary-let> + +                               _ +                               (do @ +                                 [arity //.scope-arity +                                  headB/bodyS (//.with-new-local +                                                (synthesize^ headB/bodyA))] +                                 (wrap (//.branch/let [inputS +                                                       (if (//function.nested? arity) +                                                         (n/+ (dec arity) inputR) +                                                         inputR) +                                                       headB/bodyS]))))) + +                      <if> +                      (as-is (^or (^ [[(///analysis.pattern/bool true) thenA] +                                      (list [(///analysis.pattern/bool false) elseA])]) +                                  (^ [[(///analysis.pattern/bool false) elseA] +                                      (list [(///analysis.pattern/bool true) thenA])])) +                             (do @ +                               [thenS (synthesize^ thenA) +                                elseS (synthesize^ elseA)] +                               (wrap (//.branch/if [inputS thenS elseS])))) + +                      <case> +                      (as-is _ +                             (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) +                                                               list.reverse +                                                               (case> (#.Cons [lastP lastA] prevsPA) +                                                                      [[lastP lastA] prevsPA] + +                                                                      _ +                                                                      (undefined)))] +                               (do @ +                                 [lastSP (path synthesize^ lastP lastA) +                                  prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] +                                 (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] +      (case [headB tailB+] +        <let> +        <if> +        <case>)))) diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux index cc40bea4d..35b9e047e 100644 --- a/stdlib/source/lux/lang/synthesis/function.lux +++ b/stdlib/source/lux/lang/synthesis/function.lux @@ -10,8 +10,8 @@                     (dictionary ["dict" unordered #+ Dict]))))    [///reference #+ Variable]    [///compiler #+ Operation] -  [///analysis #+ Environment Analysis] -  [// #+ Arity Synthesis Synthesizer] +  [///analysis #+ Environment Arity Analysis] +  [// #+ Synthesis Synthesizer]    [//loop])  (def: #export nested? diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/synthesis/loop.lux index 6aab72213..eb57eb7ad 100644 --- a/stdlib/source/lux/lang/synthesis/loop.lux +++ b/stdlib/source/lux/lang/synthesis/loop.lux @@ -60,9 +60,6 @@                   _                   proper))) -        (#//.Exec bodyS) -        (proper? bodyS) -          (#//.Let inputS register bodyS)          (and (proper? inputS)               (proper? bodyS)) @@ -131,9 +128,6 @@                (path-recursion recur)                (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) -          (#//.Exec bodyS) -          (maybe/map (|>> //.branch/exec) (recur bodyS)) -            (#//.Let inputS register bodyS)            (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control)                       (recur bodyS)) diff --git a/stdlib/source/lux/lang/translation.lux b/stdlib/source/lux/lang/translation.lux new file mode 100644 index 000000000..c117bc019 --- /dev/null +++ b/stdlib/source/lux/lang/translation.lux @@ -0,0 +1,164 @@ +(.module: +  lux +  (lux (control ["ex" exception #+ exception:] +                [monad #+ do]) +       (data [maybe "maybe/" Functor<Maybe>] +             [error #+ Error] +             [text] +             text/format +             (coll [sequence #+ Sequence] +                   (dictionary ["dict" unordered #+ Dict]))) +       (world [file #+ File])) +  [//name] +  [//reference #+ Register] +  [//compiler #+ Operation Compiler] +  [//synthesis #+ Synthesis]) + +(do-template [<name>] +  [(exception: #export (<name>) +     "")] + +  [no-active-buffer] +  [no-anchor] +  ) + +(exception: #export (cannot-interpret {message Text}) +  message) + +(type: #export Context +  {#scope-name Text +   #inner-functions Nat}) + +(sig: #export (Host code) +  (: (-> code (Error Any)) +     execute!) +  (: (-> code (Error Any)) +     evaluate!)) + +(type: #export (Buffer code) (Sequence [Ident code])) + +(type: #export (Artifacts code) (Dict File (Buffer code))) + +(type: #export (State anchor code) +  {#context Context +   #anchor (Maybe anchor) +   #host (Host code) +   #buffer (Maybe (Buffer code)) +   #artifacts (Artifacts code)}) + +(type: #export (Translator anchor code) +  (Compiler (State anchor code) Synthesis code)) + +(def: #export (init host) +  (All [anchor code] (-> (Host code) (..State anchor code))) +  {#context {#scope-name "" +             #inner-functions +0} +   #anchor #.None +   #host host +   #buffer #.None +   #artifacts (dict.new text.Hash<Text>)}) + +(def: #export (with-context expr) +  (All [anchor code output] +    (-> (Operation (..State anchor code) output) +        (Operation (..State anchor code) [Text output]))) +  (function (_ state) +    (let [[old-scope old-inner] (get@ #context state) +          new-scope (format old-scope "c___" (%i (.int old-inner)))] +      (case (expr (set@ #context [new-scope +0] state)) +        (#error.Success [state' output]) +        (#error.Success [(set@ #context [old-scope (inc old-inner)] state') +                         [new-scope output]]) + +        (#error.Error error) +        (#error.Error error))))) + +(def: #export context +  (All [anchor code] (Operation (..State anchor code) Text)) +  (function (_ state) +    (#error.Success [state +                     (|> state +                         (get@ #context) +                         (get@ #scope-name))]))) + +(do-template [<tag> +              <with-declaration> <with-type> <with-value> +              <get> <get-type> <exception>] +  [(def: #export <with-declaration> +     (All [anchor code output] <with-type>) +     (function (_ body) +       (function (_ state) +         (case (body (set@ <tag> (#.Some <with-value>) state)) +           (#error.Success [state' output]) +           (#error.Success [(set@ <tag> (get@ <tag> state) state') +                            output]) + +           (#error.Error error) +           (#error.Error error))))) + +   (def: #export <get> +     (All [anchor code] (Operation (..State anchor code) <get-type>)) +     (function (_ state) +       (case (get@ <tag> state) +         (#.Some output) +         (#error.Success [state output]) + +         #.None +         (ex.throw <exception> []))))] + +  [#anchor +   (with-anchor anchor) +   (-> anchor (Operation (..State anchor code) output) +       (Operation (..State anchor code) output)) +   anchor +   anchor anchor no-anchor] + +  [#buffer +   with-buffer +   (-> (Operation (..State anchor code) output) +       (Operation (..State anchor code) output)) +   sequence.empty +   buffer (Buffer code) no-active-buffer] +  ) + +(def: #export artifacts +  (All [anchor code] +    (Operation (..State anchor code) (Artifacts code))) +  (function (_ state) +    (#error.Success [state (get@ #artifacts state)]))) + +(do-template [<name>] +  [(def: #export (<name> code) +     (All [anchor code] +       (-> code (Operation (..State anchor code) Any))) +     (function (_ state) +       (case (:: (get@ #host state) <name> code) +         (#error.Error error) +         (ex.throw cannot-interpret error) +          +         (#error.Success output) +         (#error.Success [state output]))))] + +  [execute!] +  [evaluate!] +  ) + +(def: #export (save! name code) +  (All [anchor code] +    (-> Ident code (Operation (..State anchor code) Any))) +  (do //compiler.Monad<Operation> +    [_ (execute! code)] +    (function (_ state) +      (#error.Success [(update@ #buffer +                                (maybe/map (sequence.add [name code])) +                                state) +                       []])))) + +(def: #export (save-buffer! target) +  (All [anchor code] +    (-> File (Operation (..State anchor code) Any))) +  (do //compiler.Monad<Operation> +    [buffer ..buffer] +    (function (_ state) +      (#error.Success [(update@ #artifacts (dict.put target buffer) state) +                       []])))) diff --git a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..e5d12a005 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux @@ -0,0 +1,170 @@ +(.module: +  [lux #- case let if] +  (lux (control [monad #+ do] +                ["ex" exception #+ exception:]) +       (data [number] +             [text] +             text/format +             (coll [list "list/" Functor<List> Fold<List>] +                   (set ["set" unordered #+ Set])))) +  (//// [reference #+ Register] +        (host ["_" scheme #+ Expression Computation Var]) +        [compiler #+ "operation/" Monad<Operation>] +        [synthesis #+ Synthesis Path]) +  [//runtime #+ Operation Translator] +  [//reference]) + +(def: #export (let translate [valueS register bodyS]) +  (-> Translator [Synthesis Register Synthesis] +      (Operation Computation)) +  (do compiler.Monad<Operation> +    [valueO (translate valueS) +     bodyO (translate bodyS)] +    (wrap (_.let (list [(//reference.local' register) valueO]) +            bodyO)))) + +(def: #export (record-get translate valueS pathP) +  (-> Translator Synthesis (List [Nat Bool]) +      (Operation Expression)) +  (do compiler.Monad<Operation> +    [valueO (translate valueS)] +    (wrap (list/fold (function (_ [idx tail?] source) +                       (.let [method (.if tail? +                                       //runtime.product//right +                                       //runtime.product//left)] +                         (method source (_.int (:! Int idx))))) +                     valueO +                     pathP)))) + +(def: #export (if translate [testS thenS elseS]) +  (-> Translator [Synthesis Synthesis Synthesis] +      (Operation Computation)) +  (do compiler.Monad<Operation> +    [testO (translate testS) +     thenO (translate thenS) +     elseO (translate elseS)] +    (wrap (_.if testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) + +(def: @cursor (_.var "lux_pm_cursor")) + +(def: top _.length/1) + +(def: (push! value var) +  (-> Expression Var Computation) +  (_.set! var (_.cons/2 value var))) + +(def: (pop! var) +  (-> Var Computation) +  (_.set! var var)) + +(def: (push-cursor! value) +  (-> Expression Computation) +  (push! value @cursor)) + +(def: save-cursor! +  Computation +  (push! @cursor @savepoint)) + +(def: restore-cursor! +  Computation +  (_.set! @cursor (_.car/1 @savepoint))) + +(def: cursor-top +  Computation +  (_.car/1 @cursor)) + +(def: pop-cursor! +  Computation +  (pop! @cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise/1 pm-error)) + +(def: @temp (_.var "lux_pm_temp")) + +(exception: #export (unrecognized-path) +  "") + +(def: $alt_error (_.var "alt_error")) + +(def: (pm-catch handler) +  (-> Expression Computation) +  (_.lambda [(list $alt_error) #.None] +       (_.if (|> $alt_error (_.eqv?/2 pm-error)) +         handler +         (_.raise/1 $alt_error)))) + +(def: (pattern-matching' translate pathP) +  (-> Translator Path (Operation Expression)) +  (.case pathP +    (^ (synthesis.path/then bodyS)) +    (translate bodyS) + +    #synthesis.Pop +    (operation/wrap pop-cursor!) + +    (#synthesis.Bind register) +    (operation/wrap (_.define (//reference.local' register) [(list) #.None] +                              cursor-top)) + +    (^template [<tag> <format> <=>] +      (^ (<tag> value)) +      (operation/wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) +                              fail-pm!))) +    ([synthesis.path/bool _.bool   _.eqv?/2] +     [synthesis.path/i64  _.int    _.=/2] +     [synthesis.path/f64  _.float  _.=/2] +     [synthesis.path/text _.string _.eqv?/2]) + +    (^template [<pm> <flag> <prep>] +      (^ (<pm> idx)) +      (operation/wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))]) +                        (_.if (_.null?/1 @temp) +                          fail-pm! +                          (push-cursor! @temp))))) +    ([synthesis.side/left  _.nil         (<|)] +     [synthesis.side/right (_.string "") inc]) + +    (^template [<pm> <getter> <prep>] +      (^ (<pm> idx)) +      (operation/wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!))) +    ([synthesis.member/left  //runtime.product//left  (<|)] +     [synthesis.member/right //runtime.product//right inc]) + +    (^template [<tag> <computation>] +      (^ (<tag> [leftP rightP])) +      (do compiler.Monad<Operation> +        [leftO (pattern-matching' translate leftP) +         rightO (pattern-matching' translate rightP)] +        (wrap <computation>))) +    ([synthesis.path/seq (_.begin (list leftO +                                        rightO))] +     [synthesis.path/alt (_.with-exception-handler +                           (pm-catch (_.begin (list restore-cursor! +                                                    rightO))) +                           (_.lambda [(list) #.None] +                                (_.begin (list save-cursor! +                                               leftO))))]) +     +    _ +    (compiler.throw unrecognized-path []))) + +(def: (pattern-matching translate pathP) +  (-> Translator Path (Operation Computation)) +  (do compiler.Monad<Operation> +    [pattern-matching! (pattern-matching' translate pathP)] +    (wrap (_.with-exception-handler +            (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) +            (_.lambda [(list) #.None] +                 pattern-matching!))))) + +(def: #export (case translate [valueS pathP]) +  (-> Translator [Synthesis Path] (Operation Computation)) +  (do compiler.Monad<Operation> +    [valueO (translate valueS)] +    (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] +                               [@savepoint (_.list/* (list))]))) +        (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux b/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..96bb17126 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux @@ -0,0 +1,53 @@ +(.module: +  lux +  (lux (control [monad #+ do])) +  (//// [compiler] +        [synthesis] +        [extension]) +  [//runtime #+ Translator] +  [//primitive] +  [//structure] +  [//reference] +  [//function] +  [//case]) + +(def: #export (translate synthesis) +  Translator +  (case synthesis +    (^template [<tag> <generator>] +      (^ (<tag> value)) +      (<generator> value)) +    ([synthesis.bool //primitive.bool] +     [synthesis.i64  //primitive.i64] +     [synthesis.f64  //primitive.f64] +     [synthesis.text //primitive.text]) + +    (^ (synthesis.variant variantS)) +    (//structure.variant translate variantS) + +    (^ (synthesis.tuple members)) +    (//structure.tuple translate members) + +    (#synthesis.Reference reference) +    (//reference.reference reference) + +    (^ (synthesis.function/apply application)) +    (//function.apply translate application) + +    (^ (synthesis.function/abstraction abstraction)) +    (//function.function translate abstraction) + +    (^ (synthesis.branch/case case)) +    (//case.case translate case) + +    (^ (synthesis.branch/let let)) +    (//case.let translate let) + +    (^ (synthesis.branch/if if)) +    (//case.if translate if) + +    (#synthesis.Extension [extension argsS]) +    (do compiler.Monad<Operation> +      [extension (extension.find-translation extension)] +      (extension argsS)) +    )) diff --git a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux new file mode 100644 index 000000000..6475caf68 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux @@ -0,0 +1,32 @@ +(.module: +  lux +  (lux (control [monad #+ do] +                ["ex" exception #+ exception:]) +       (data [maybe] +             text/format +             (coll (dictionary ["dict" unordered #+ Dict])))) +  (//// [reference #+ Register Variable] +        (host ["_" scheme #+ Computation]) +        [compiler "operation/" Monad<Operation>] +        [synthesis #+ Synthesis]) +  [//runtime #+ Operation Translator] +  [/common] +  ## [/host] +  ) + +(exception: #export (unknown-extension {message Text}) +  message) + +(def: extensions +  /common.Bundle +  (|> /common.extensions +      ## (dict.merge /host.extensions) +      )) + +(def: #export (extension translate name args) +  (-> Translator Text (List Synthesis) +      (Operation Computation)) +  (<| (maybe.default (compiler.throw unknown-extension (%t name))) +      (do maybe.Monad<Maybe> +        [ext (dict.get name extensions)] +        (wrap (ext translate args))))) diff --git a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..140045aaf --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux @@ -0,0 +1,389 @@ +(.module: +  lux +  (lux (control [monad #+ do] +                ["ex" exception #+ exception:]) +       (data ["e" error] +             [product] +             [text] +             text/format +             [number #+ hex] +             (coll [list "list/" Functor<List>] +                   (dictionary ["dict" unordered #+ Dict]))) +       [macro #+ with-gensyms] +       (macro [code] +              ["s" syntax #+ syntax:]) +       [host]) +  (///// (host ["_" scheme #+ Expression Computation]) +         [compiler] +         [synthesis #+ Synthesis]) +  [///runtime #+ Operation Translator]) + +## [Types] +(type: #export Extension +  (-> Translator (List Synthesis) (Operation Computation))) + +(type: #export Bundle +  (Dict Text Extension)) + +(syntax: (Vector {size s.nat} elemT) +  (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 Expression) Computation)) +(type: #export Unary   (-> (Vector +1 Expression) Computation)) +(type: #export Binary  (-> (Vector +2 Expression) Computation)) +(type: #export Trinary (-> (Vector +3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +## [Utils] +(def: #export (install name unnamed) +  (-> Text (-> Text Extension) +      (-> Bundle Bundle)) +  (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) +  (-> Text Bundle Bundle) +  (|> bundle +      dict.entries +      (list/map (function (_ [key val]) [(format prefix " " key) val])) +      (dict.from-list text.Hash<Text>))) + +(exception: #export (wrong-arity {extension Text} {expected Nat} {actual Nat}) +  (ex.report ["Extension" (%t extension)] +             ["Expected" (|> expected .int %i)] +             ["Actual" (|> actual .int %i)])) + +(syntax: (arity: {name s.local-symbol} {arity s.nat}) +  (with-gensyms [g!_ g!extension g!name g!translate g!inputs] +    (do @ +      [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] +      (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!extension)) +                       (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) +                           (-> Text ..Extension)) +                       (function ((~ g!_) (~ g!name)) +                         (function ((~ g!_) (~ g!translate) (~ g!inputs)) +                           (case (~ g!inputs) +                             (^ (list (~+ g!input+))) +                             (do compiler.Monad<Operation> +                               [(~+ (|> g!input+ +                                        (list/map (function (_ g!input) +                                                    (list g!input (` ((~ g!translate) (~ g!input)))))) +                                        list.concat))] +                               ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + +                             (~' _) +                             (compiler.throw wrong-arity [(~ g!name) +1 (list.size (~ g!inputs))]))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic extension) +  (-> Variadic (-> Text Extension)) +  (function (_ extension-name) +    (function (_ translate inputsS) +      (do compiler.Monad<Operation> +        [inputsI (monad.map @ translate inputsS)] +        (wrap (extension inputsI)))))) + +## [Extensions] +## [[Lux]] +(def: extensions/lux +  Bundle +  (|> (dict.new text.Hash<Text>) +      (install "is?" (binary (product.uncurry _.eq?/2))) +      (install "try" (unary ///runtime.lux//try)))) + +## [[Bits]] +(do-template [<name> <op>] +  [(def: (<name> [subjectO paramO]) +     Binary +     (<op> paramO subjectO))] +   +  [bit//and _.bit-and/2] +  [bit//or  _.bit-or/2] +  [bit//xor _.bit-xor/2] +  ) + +(def: (bit//left-shift [subjectO paramO]) +  Binary +  (_.arithmetic-shift/2 (_.remainder/2 (_.int 64) paramO) +                        subjectO)) + +(def: (bit//arithmetic-right-shift [subjectO paramO]) +  Binary +  (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int 64)) (_.*/2 (_.int -1))) +                        subjectO)) + +(def: (bit//logical-right-shift [subjectO paramO]) +  Binary +  (///runtime.bit//logical-right-shift (_.remainder/2 (_.int 64) paramO) subjectO)) + +(def: extensions/bit +  Bundle +  (<| (prefix "bit") +      (|> (dict.new text.Hash<Text>) +          (install "and" (binary bit//and)) +          (install "or" (binary bit//or)) +          (install "xor" (binary bit//xor)) +          (install "left-shift" (binary bit//left-shift)) +          (install "logical-right-shift" (binary bit//logical-right-shift)) +          (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) +          ))) + +## [[Arrays]] +(def: (array//new size0) +  Unary +  (_.make-vector/2 size0 _.nil)) + +(def: (array//get [arrayO idxO]) +  Binary +  (///runtime.array//get arrayO idxO)) + +(def: (array//put [arrayO idxO elemO]) +  Trinary +  (///runtime.array//put arrayO idxO elemO)) + +(def: (array//remove [arrayO idxO]) +  Binary +  (///runtime.array//put arrayO idxO _.nil)) + +(def: extensions/array +  Bundle +  (<| (prefix "array") +      (|> (dict.new text.Hash<Text>) +          (install "new" (unary array//new)) +          (install "get" (binary array//get)) +          (install "put" (trinary array//put)) +          (install "remove" (binary array//remove)) +          (install "size" (unary _.vector-length/1)) +          ))) + +## [[Numbers]] +(host.import java/lang/Double +  (#static MIN_VALUE Double) +  (#static MAX_VALUE Double)) + +(do-template [<name> <const> <encode>] +  [(def: (<name> _) +     Nullary +     (<encode> <const>))] + +  [frac//smallest Double::MIN_VALUE            _.float] +  [frac//min      (f/* -1.0 Double::MAX_VALUE) _.float] +  [frac//max      Double::MAX_VALUE            _.float] +  ) + +(do-template [<name> <frac>] +  [(def: (<name> _) +     Nullary +     (_.float <frac>))] + +  [frac//not-a-number      number.not-a-number] +  [frac//positive-infinity number.positive-infinity] +  [frac//negative-infinity number.negative-infinity] +  ) + +(do-template [<name> <op>] +  [(def: (<name> [subjectO paramO]) +     Binary +     (|> subjectO (<op> paramO)))] + +  [int//+ _.+/2] +  [int//- _.-/2] +  [int//* _.*/2] +  [int/// _.quotient/2] +  [int//% _.remainder/2] +  ) + +(do-template [<name> <op>] +  [(def: (<name> [subjectO paramO]) +     Binary +     (<op> paramO subjectO))] + +  [frac//+ _.+/2] +  [frac//- _.-/2] +  [frac//* _.*/2] +  [frac/// _.//2] +  [frac//% _.mod/2] +  [frac//= _.=/2] +  [frac//< _.</2] + +  [text//= _.string=?/2] +  [text//< _.string<?/2] +  ) + +(do-template [<name> <cmp>] +  [(def: (<name> [subjectO paramO]) +     Binary +     (<cmp> paramO subjectO))] + +  [int//= _.=/2] +  [int//< _.</2] +  ) + +(def: int//char (|>> _.integer->char/1 _.string/1)) + +(def: extensions/int +  Bundle +  (<| (prefix "int") +      (|> (dict.new text.Hash<Text>) +          (install "+" (binary int//+)) +          (install "-" (binary int//-)) +          (install "*" (binary int//*)) +          (install "/" (binary int///)) +          (install "%" (binary int//%)) +          (install "=" (binary int//=)) +          (install "<" (binary int//<)) +          (install "to-frac" (unary (|>> (_.//2 (_.float 1.0))))) +          (install "char" (unary int//char))))) + +(def: extensions/frac +  Bundle +  (<| (prefix "frac") +      (|> (dict.new text.Hash<Text>) +          (install "+" (binary frac//+)) +          (install "-" (binary frac//-)) +          (install "*" (binary frac//*)) +          (install "/" (binary frac///)) +          (install "%" (binary frac//%)) +          (install "=" (binary frac//=)) +          (install "<" (binary frac//<)) +          (install "smallest" (nullary frac//smallest)) +          (install "min" (nullary frac//min)) +          (install "max" (nullary frac//max)) +          (install "not-a-number" (nullary frac//not-a-number)) +          (install "positive-infinity" (nullary frac//positive-infinity)) +          (install "negative-infinity" (nullary frac//negative-infinity)) +          (install "to-int" (unary _.exact/1)) +          (install "encode" (unary _.number->string/1)) +          (install "decode" (unary ///runtime.frac//decode))))) + +## [[Text]] +(def: (text//char [subjectO paramO]) +  Binary +  (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text//clip [subjectO startO endO]) +  Trinary +  (_.substring/3 subjectO startO endO)) + +(def: extensions/text +  Bundle +  (<| (prefix "text") +      (|> (dict.new text.Hash<Text>) +          (install "=" (binary text//=)) +          (install "<" (binary text//<)) +          (install "concat" (binary (product.uncurry _.string-append/2))) +          (install "size" (unary _.string-length/1)) +          (install "char" (binary text//char)) +          (install "clip" (trinary text//clip))))) + +## [[Math]] +(def: (math//pow [subject param]) +  Binary +  (_.expt/2 param subject)) + +(def: math-func +  (-> Text Unary) +  (|>> _.global _.apply/1)) + +(def: extensions/math +  Bundle +  (<| (prefix "math") +      (|> (dict.new text.Hash<Text>) +          (install "cos" (unary (math-func "cos"))) +          (install "sin" (unary (math-func "sin"))) +          (install "tan" (unary (math-func "tan"))) +          (install "acos" (unary (math-func "acos"))) +          (install "asin" (unary (math-func "asin"))) +          (install "atan" (unary (math-func "atan"))) +          (install "exp" (unary (math-func "exp"))) +          (install "log" (unary (math-func "log"))) +          (install "ceil" (unary (math-func "ceiling"))) +          (install "floor" (unary (math-func "floor"))) +          (install "pow" (binary math//pow)) +          ))) + +## [[IO]] +(def: (io//log input) +  Unary +  (_.begin (list (_.display/1 input) +                 _.newline/0))) + +(def: (void code) +  (-> Expression Computation) +  (_.begin (list code (_.string synthesis.unit)))) + +(def: extensions/io +  Bundle +  (<| (prefix "io") +      (|> (dict.new text.Hash<Text>) +          (install "log" (unary (|>> io//log ..void))) +          (install "error" (unary _.raise/1)) +          (install "exit" (unary _.exit/1)) +          (install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string synthesis.unit)))))))) + +## [[Atoms]] +(def: atom//new +  Unary +  (|>> (list) _.vector/*)) + +(def: (atom//read atom) +  Unary +  (_.vector-ref/2 atom (_.int 0))) + +(def: (atom//compare-and-swap [atomO oldO newO]) +  Trinary +  (///runtime.atom//compare-and-swap atomO oldO newO)) + +(def: extensions/atom +  Bundle +  (<| (prefix "atom") +      (|> (dict.new text.Hash<Text>) +          (install "new" (unary atom//new)) +          (install "read" (unary atom//read)) +          (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +## [[Box]] +(def: (box//write [valueO boxO]) +  Binary +  (///runtime.box//write valueO boxO)) + +(def: extensions/box +  Bundle +  (<| (prefix "box") +      (|> (dict.new text.Hash<Text>) +          (install "new" (unary atom//new)) +          (install "read" (unary atom//read)) +          (install "write" (binary box//write))))) + +## [[Processes]] +(def: (process//parallelism-level []) +  Nullary +  (_.int 1)) + +(def: extensions/process +  Bundle +  (<| (prefix "process") +      (|> (dict.new text.Hash<Text>) +          (install "parallelism-level" (nullary process//parallelism-level)) +          (install "schedule" (binary (product.uncurry ///runtime.process//schedule))) +          ))) + +## [Bundles] +(def: #export extensions +  Bundle +  (<| (prefix "lux") +      (|> extensions/lux +          (dict.merge extensions/bit) +          (dict.merge extensions/int) +          (dict.merge extensions/frac) +          (dict.merge extensions/text) +          (dict.merge extensions/array) +          (dict.merge extensions/math) +          (dict.merge extensions/io) +          (dict.merge extensions/atom) +          (dict.merge extensions/box) +          (dict.merge extensions/process) +          ))) diff --git a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..11c64076c --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/function.jvm.lux @@ -0,0 +1,85 @@ +(.module: +  [lux #- function] +  (lux (control [monad #+ do] +                pipe) +       (data [product] +             text/format +             (coll [list "list/" Functor<List>]))) +  (//// [reference #+ Register Variable] +        [name] +        [compiler "operation/" Monad<Operation>] +        [analysis #+ Variant Tuple Environment Arity Abstraction Application Analysis] +        [synthesis #+ Synthesis] +        (host ["_" scheme #+ Expression Computation Var])) +  [///] +  [//runtime #+ Operation Translator] +  [//primitive] +  [//reference]) + +(def: #export (apply translate [functionS argsS+]) +  (-> Translator (Application Synthesis) (Operation Computation)) +  (do compiler.Monad<Operation> +    [functionO (translate functionS) +     argsO+ (monad.map @ translate argsS+)] +    (wrap (_.apply/* functionO argsO+)))) + +(def: (with-closure function-name inits function-definition) +  (-> Text (List Expression) Computation (Operation Computation)) +  (let [@closure (_.var (format function-name "___CLOSURE"))] +    (operation/wrap +     (case inits +       #.Nil +       function-definition + +       _ +       (_.letrec (list [@closure +                        (_.lambda [(|> (list.enumerate inits) +                                  (list/map (|>> product.left //reference.foreign'))) +                              #.None] +                             function-definition)]) +                 (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input +  (|>> inc //reference.local')) + +(def: #export (function translate [environment arity bodyS]) +  (-> Translator (Abstraction Synthesis) (Operation Computation)) +  (do compiler.Monad<Operation> +    [[function-name bodyO] (///.with-context +                             (do @ +                               [function-name ///.context] +                               (///.with-anchor (_.var function-name) +                                 (translate bodyS)))) +     closureO+ (monad.map @ //reference.variable environment) +     #let [arityO (|> arity .int _.int) +           @num-args (_.var "num_args") +           @function (_.var function-name) +           apply-poly (.function (_ args func) +                        (_.apply/2 (_.global "apply") func args))]] +    (with-closure function-name closureO+ +      (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] +                                      (_.let (list [@num-args (_.length/1 @curried)]) +                                        (<| (_.if (|> @num-args (_.=/2 arityO)) +                                              (<| (_.let (list [(//reference.local' +0) @function])) +                                                  (_.let-values (list [[(|> (list.n/range +0 (dec arity)) +                                                                            (list/map ..input)) +                                                                        #.None] +                                                                       (_.apply/2 (_.global "apply") (_.global "values") @curried)])) +                                                  bodyO)) +                                            (_.if (|> @num-args (_.>/2 arityO)) +                                              (let [arity-args (//runtime.slice (_.int 0) arityO @curried) +                                                    output-func-args (//runtime.slice arityO +                                                                                      (|> @num-args (_.-/2 arityO)) +                                                                                      @curried)] +                                                (|> @function +                                                    (apply-poly arity-args) +                                                    (apply-poly output-func-args)))) +                                            ## (|> @num-args (_.</2 arityO)) +                                            (_.lambda [(list) (#.Some @missing)] +                                                 (|> @function +                                                     (apply-poly (_.append/2 @curried @missing)))))))]) +                @function)) +    )) diff --git a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..6f305336e --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux @@ -0,0 +1,39 @@ +(.module: +  [lux #- loop] +  (lux (control [monad #+ do]) +       (data [product] +             [text] +             text/format +             (coll [list "list/" Functor<List>])) +       [macro]) +  [////] +  (//// [name] +        (host ["_" scheme #+ Computation Var]) +        [compiler "operation/" Monad<Operation>] +        [synthesis #+ Synthesis]) +  [///] +  [//runtime #+ Operation Translator] +  [//reference]) + +(def: @loop (_.var "loop")) + +(def: #export (loop translate offset initsS+ bodyS) +  (-> Translator Nat (List Synthesis) Synthesis +      (Operation Computation)) +  (do compiler.Monad<Operation> +    [initsO+ (monad.map @ translate initsS+) +     bodyO (///.with-anchor @loop +             (translate bodyS))] +    (wrap (_.letrec (list [@loop (_.lambda [(|> initsS+ +                                           list.enumerate +                                           (list/map (|>> product.left (n/+ offset) //reference.local'))) +                                       #.None] +                                      bodyO)]) +                    (_.apply/* @loop initsO+))))) + +(def: #export (recur translate argsS+) +  (-> Translator (List Synthesis) (Operation Computation)) +  (do compiler.Monad<Operation> +    [@loop ///.anchor +     argsO+ (monad.map @ translate argsS+)] +    (wrap (_.apply/* @loop argsO+)))) diff --git a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..ac775fa82 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux @@ -0,0 +1,22 @@ +(.module: +  [lux #- i64] +  [/// #+ State] +  (//// [compiler #+ "operation/" Monad<Operation>] +        (host ["_" scheme #+ Expression])) +  [//runtime #+ Operation]) + +(def: #export bool +  (-> Bool (Operation Expression)) +  (|>> _.bool operation/wrap)) + +(def: #export i64 +  (-> (I64 Any) (Operation Expression)) +  (|>> .int _.int operation/wrap)) + +(def: #export f64 +  (-> Frac (Operation Expression)) +  (|>> _.float operation/wrap)) + +(def: #export text +  (-> Text (Operation Expression)) +  (|>> _.string operation/wrap)) diff --git a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux b/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..453d4edb6 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux @@ -0,0 +1,54 @@ +(.module: +  lux +  (lux (control pipe) +       (data text/format)) +  (//// [reference #+ Register Variable Reference] +        [name] +        [compiler "operation/" Monad<Operation>] +        [analysis #+ Variant Tuple] +        [synthesis #+ Synthesis] +        (host ["_" scheme #+ Expression Var])) +  [//runtime #+ Operation Translator] +  [//primitive]) + +(do-template [<name> <prefix>] +  [(def: #export <name> +     (-> Register Var) +     (|>> .int %i (format <prefix>) _.var))] + +  [local'   "l"] +  [foreign' "f"] +  ) + +(def: #export variable' +  (-> Variable Var) +  (|>> (case> (#reference.Local register) +              (local' register) +               +              (#reference.Foreign register) +              (foreign' register)))) + +(def: #export variable +  (-> Variable (Operation Var)) +  (|>> ..variable' +       operation/wrap)) + +(def: #export constant' +  (-> Ident Var) +  (|>> name.definition _.var)) + +(def: #export constant +  (-> Ident (Operation Var)) +  (|>> constant' operation/wrap)) + +(def: #export reference' +  (-> Reference Expression) +  (|>> (case> (#reference.Constant value) +              (..constant' value) +               +              (#reference.Variable value) +              (..variable' value)))) + +(def: #export reference +  (-> Reference (Operation Expression)) +  (|>> reference' operation/wrap)) diff --git a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..b30aff3a2 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux @@ -0,0 +1,362 @@ +(.module: +  lux +  (lux (control ["p" parser "p/" Monad<Parser>] +                [monad #+ do]) +       (data [number #+ hex] +             text/format +             (coll [list "list/" Monad<List>])) +       [function] +       (macro [code] +              ["s" syntax #+ syntax:])) +  [/// #+ State] +  (//// [name] +        [compiler] +        [analysis #+ Variant] +        [synthesis] +        (host ["_" scheme #+ Expression Computation Var]))) + +(type: #export Operation +  (compiler.Operation (State Var Expression))) + +(type: #export Translator +  (///.Translator Var Expression)) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) +  (-> Bool Computation) +  (if value +    (_.string "") +    _.nil)) + +(def: (variant' tag last? value) +  (-> Expression Expression Expression Computation) +  (<| (_.cons/2 (_.symbol ..variant-tag)) +      (_.cons/2 tag) +      (_.cons/2 last?) +      value)) + +(def: #export (variant [lefts right? value]) +  (-> (Variant Expression) Computation) +  (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none +  Computation +  (variant [+0 false ..unit])) + +(def: #export some +  (-> Expression Computation) +  (|>> [+0 true] ..variant)) + +(def: #export left +  (-> Expression Computation) +  (|>> [+0 false] ..variant)) + +(def: #export right +  (-> Expression Computation) +  (|>> [+0 true] ..variant)) + +(def: declaration +  (s.Syntax [Text (List Text)]) +  (p.either (p.seq s.local-symbol (p/wrap (list))) +            (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) + +(syntax: (runtime: {[name args] declaration} +           definition) +  (let [implementation (code.local-symbol (format "@@" name)) +        runtime (format prefix "__" (name.normalize name)) +        @runtime (` (_.var (~ (code.text runtime)))) +        argsC+ (list/map code.local-symbol args) +        argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) +                          args) +        declaration (` ((~ (code.local-symbol name)) +                        (~+ argsC+))) +        type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) +                    _.Computation))] +    (wrap (list (` (def: (~' #export) (~ declaration) +                     (~ type) +                     (~ (case argsC+ +                          #.Nil +                          @runtime + +                          _ +                          (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) +                (` (def: (~ implementation) +                     _.Computation +                     (~ (case argsC+ +                          #.Nil +                          (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + +                          _ +                          (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) +                                           (list/map (function (_ [left right]) +                                                       (list left right))) +                                           list/join))] +                               (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] +                                         (~ definition)))))))))))) + +(runtime: (slice offset length list) +  (<| (_.if (_.null?/1 list) +        list) +      (_.if (|> offset (_.>/2 (_.int 0))) +        (slice (|> offset (_.-/2 (_.int 1))) +               length +               (_.cdr/1 list))) +      (_.if (|> length (_.>/2 (_.int 0))) +        (_.cons/2 (_.car/1 list) +                  (slice offset +                         (|> length (_.-/2 (_.int 1))) +                         (_.cdr/1 list)))) +      _.nil)) + +(syntax: #export (with-vars {vars (s.tuple (p.many s.local-symbol))} +                   body) +  (wrap (list (` (let [(~+ (|> vars +                               (list/map (function (_ var) +                                           (list (code.local-symbol var) +                                                 (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) +                               list/join))] +                   (~ body)))))) + +(runtime: (lux//try op) +  (with-vars [error] +    (_.with-exception-handler +      (_.lambda [(list error) #.None] +           (..left error)) +      (_.lambda [(list) #.None] +           (..right (_.apply/* op (list ..unit))))))) + +(runtime: (lux//program-args program-args) +  (with-vars [@loop @input @output] +    (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] +                                (_.if (_.eqv?/2 _.nil @input) +                                  @output +                                  (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) +              (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + +(def: runtime//lux +  Computation +  (_.begin (list @@lux//try +                 @@lux//program-args))) + +(def: minimum-index-length +  (-> Expression Computation) +  (|>> (_.+/2 (_.int 1)))) + +(def: product-element +  (-> Expression Expression Computation) +  (function.flip _.vector-ref/2)) + +(def: (product-tail product) +  (-> Expression Computation) +  (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int 1))))) + +(def: (updated-index min-length product) +  (-> Expression Expression Computation) +  (|> min-length (_.-/2 (_.length/1 product)))) + +(runtime: (product//left product index) +  (let [@index_min_length (_.var "index_min_length")] +    (_.begin +     (list (_.define @index_min_length [(list) #.None] +                     (minimum-index-length index)) +           (_.if (|> product _.length/1 (_.>/2 @index_min_length)) +             ## No need for recursion +             (product-element index product) +             ## Needs recursion +             (product//left (product-tail product) +                            (updated-index @index_min_length product))))))) + +(runtime: (product//right product index) +  (let [@index_min_length (_.var "index_min_length") +        @product_length (_.var "product_length") +        @slice (_.var "slice") +        last-element? (|> @product_length (_.=/2 @index_min_length)) +        needs-recursion? (|> @product_length (_.</2 @index_min_length))] +    (_.begin +     (list +      (_.define @index_min_length [(list) #.None] (minimum-index-length index)) +      (_.define @product_length [(list) #.None] (_.length/1 product)) +      (<| (_.if last-element? +            (product-element index product)) +          (_.if needs-recursion? +            (product//right (product-tail product) +                            (updated-index @index_min_length product))) +          ## Must slice +          (_.begin +           (list (_.define @slice [(list) #.None] +                           (_.make-vector/1 (|> @product_length (_.-/2 index)))) +                 (_.vector-copy!/5 @slice (_.int 0) product index @product_length) +                 @slice))))))) + +(runtime: (sum//get sum last? wanted-tag) +  (with-vars [variant-tag sum-tag sum-flag sum-value] +    (let [no-match _.nil +          is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) +          test-recursion (_.if is-last? +                           ## Must recurse. +                           (sum//get sum-value +                                     (|> wanted-tag (_.-/2 sum-tag)) +                                     last?) +                           no-match)] +      (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] +                               (_.apply/* (_.global "apply") (list (_.global "values") sum))])) +          (_.if (|> wanted-tag (_.=/2 sum-tag)) +            (_.if (|> sum-flag (_.eqv?/2 last?)) +              sum-value +              test-recursion)) +          (_.if (|> wanted-tag (_.>/2 sum-tag)) +            test-recursion) +          (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) +                             (|> wanted-tag (_.</2 sum-tag)))) +            (variant' (|> sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) +          no-match)))) + +(def: runtime//adt +  Computation +  (_.begin (list @@product//left +                 @@product//right +                 @@sum//get))) + +(runtime: (bit//logical-right-shift shift input) +  (_.if (_.=/2 (_.int 0) shift) +    input +    (|> input +        (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) +        (_.bit-and/2 (_.int (hex "7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit +  Computation +  (_.begin (list @@bit//logical-right-shift))) + +(runtime: (frac//decode input) +  (with-vars [@output] +    (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) +      (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) +                         (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) +        ..none +        (..some @output))))) + +(def: runtime//frac +  Computation +  (_.begin +   (list @@frac//decode))) + +(def: (check-index-out-of-bounds array idx body) +  (-> Expression Expression Expression Computation) +  (_.if (|> idx (_.<=/2 (_.length/1 array))) +    body +    (_.raise/1 (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) +  (with-vars [@temp] +    (<| (check-index-out-of-bounds array idx) +        (_.let (list [@temp (_.vector-ref/2 array idx)]) +          (_.if (|> @temp (_.eqv?/2 _.nil)) +            ..none +            (..some @temp)))))) + +(runtime: (array//put array idx value) +  (<| (check-index-out-of-bounds array idx) +      (_.begin +       (list (_.vector-set!/3 array idx value) +             array)))) + +(def: runtime//array +  Computation +  (_.begin +   (list @@array//get +         @@array//put))) + +(runtime: (atom//compare-and-swap atom old new) +  (with-vars [@temp] +    (_.let (list [@temp (_.vector-ref/2 atom (_.int 0))]) +      (_.if (_.eq?/2 old @temp) +        (_.begin +         (list (_.vector-set!/3 atom (_.int 0) new) +               (_.bool true))) +        (_.bool false))))) + +(def: runtime//atom +  Computation +  @@atom//compare-and-swap) + +(runtime: (box//write value box) +  (_.begin +   (list +    (_.vector-set!/3 box (_.int 0) value) +    ..unit))) + +(def: runtime//box +  Computation +  (_.begin (list @@box//write))) + +(runtime: (io//current-time _) +  (|> (_.apply/* (_.global "current-second") (list)) +      (_.*/2 (_.int 1_000)) +      _.exact/1)) + +(def: runtime//io +  (_.begin (list @@io//current-time))) + +(def: process//incoming +  Var +  (_.var (name.normalize "process//incoming"))) + +(runtime: (process//loop _) +  (_.when (_.not/1 (_.null?/1 process//incoming)) +          (with-vars [queue process] +            (_.let (list [queue process//incoming]) +              (_.begin (list (_.set! process//incoming (_.list/* (list))) +                             (_.map/2 (_.lambda [(list process) #.None] +                                           (_.apply/1 process ..unit)) +                                      queue) +                             (process//loop ..unit))))))) + +(runtime: (process//schedule milli-seconds procedure) +  (let [process//future (function (_ process) +                          (_.set! process//incoming (_.cons/2 process process//incoming)))] +    (_.begin +     (list +      (_.if (_.=/2 (_.int 0) milli-seconds) +        (process//future procedure) +        (with-vars [@start @process @now @ignored] +          (_.let (list [@start (io//current-time ..unit)]) +            (_.letrec (list [@process (_.lambda [(list) (#.Some @ignored)] +                                           (_.let (list [@now (io//current-time ..unit)]) +                                             (_.if (|> @now (_.-/2 @start) (_.>=/2 milli-seconds)) +                                               (_.apply/1 procedure ..unit) +                                               (process//future @process))))]) +                      (process//future @process))))) +      ..unit)))) + +(def: runtime//process +  Computation +  (_.begin (list (_.define process//incoming [(list) #.None] (_.list/* (list))) +                 @@process//loop +                 @@process//schedule))) + +(def: runtime +  Computation +  (_.begin (list @@slice +                 runtime//lux +                 runtime//bit +                 runtime//adt +                 runtime//frac +                 runtime//array +                 runtime//atom +                 runtime//box +                 runtime//io +                 runtime//process +                 ))) + +(def: #export translate +  (Operation Any) +  (///.with-buffer +    (do compiler.Monad<Operation> +      [_ (///.save! ["" ..prefix] ..runtime)] +      (///.save-buffer! "")))) diff --git a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux b/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..a11434594 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux @@ -0,0 +1,29 @@ +(.module: +  lux +  (lux (control [monad #+ do])) +  (//// [compiler] +        [analysis #+ Variant Tuple] +        [synthesis #+ Synthesis] +        (host ["_" scheme #+ Expression])) +  [//runtime #+ Operation Translator] +  [//primitive]) + +(def: #export (tuple translate elemsS+) +  (-> Translator (Tuple Synthesis) (Operation Expression)) +  (case elemsS+ +    #.Nil +    (//primitive.text synthesis.unit) + +    (#.Cons singletonS #.Nil) +    (translate singletonS) + +    _ +    (do compiler.Monad<Operation> +      [elemsT+ (monad.map @ translate elemsS+)] +      (wrap (_.vector/* elemsT+))))) + +(def: #export (variant translate [lefts right? valueS]) +  (-> Translator (Variant Synthesis) (Operation Expression)) +  (do compiler.Monad<Operation> +    [valueT (translate valueS)] +    (wrap (//runtime.variant [lefts right? valueT])))) | 
