diff options
author | Eduardo Julian | 2019-05-21 19:51:14 -0400 |
---|---|---|
committer | Eduardo Julian | 2019-05-21 19:51:14 -0400 |
commit | eb59547eae1753c9aed1ee887e44c825c1b32c05 (patch) | |
tree | aabce6250366d4f71ae64c50bde8b8bb717ac636 | |
parent | 814d5e86f6475e18d671be5149c9a9747e93d455 (diff) |
WIP: Separate Scheme compiler.
-rw-r--r-- | .gitignore | 6 | ||||
-rw-r--r-- | commands | 13 | ||||
-rw-r--r-- | documentation/research/debugging.md | 1 | ||||
-rw-r--r-- | lux-scheme/project.clj | 30 | ||||
-rw-r--r-- | lux-scheme/source/program.lux | 355 | ||||
-rw-r--r-- | new-luxc/project.clj | 5 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/scheme.lux | 214 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/scheme/eval.jvm.lux | 154 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/scheme/statement.jvm.lux | 45 | ||||
-rw-r--r-- | stdlib/source/lux/target/scheme.lux | 112 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux | 42 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux | 123 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux | 133 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux | 6 |
14 files changed, 590 insertions, 649 deletions
diff --git a/.gitignore b/.gitignore index 15b96b13d..ef15d6b25 100644 --- a/.gitignore +++ b/.gitignore @@ -57,3 +57,9 @@ pom.xml.asc /lux-cl/source/program /lux-cl/source/spec +/lux-scheme/target +/lux-scheme/source/lux.lux +/lux-scheme/source/lux +/lux-scheme/source/program +/lux-scheme/source/spec + @@ -10,7 +10,8 @@ cd ~/lux/lux-python/ && lein clean && \ cd ~/lux/lux-lua/ && lein clean && \ cd ~/lux/lux-ruby/ && lein clean && \ cd ~/lux/lux-php/ && lein clean && \ -cd ~/lux/lux-cl/ && lein clean +cd ~/lux/lux-cl/ && lein clean && \ +cd ~/lux/lux-scheme/ && lein clean # Old Lux compiler # Re-build and re-install @@ -99,6 +100,16 @@ cd ~/lux/lux-cl/ && lein clean # Try cd ~/lux/lux-cl/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux +# Scheme compiler + # Test + cd ~/lux/lux-scheme/ && lein_2_7_1 lux auto test + cd ~/lux/lux-scheme/ && lein clean && lein_2_7_1 lux auto test + # Build + cd ~/lux/lux-scheme/ && lein_2_7_1 lux auto build + cd ~/lux/lux-scheme/ && lein clean && lein_2_7_1 lux auto build + # Try + cd ~/lux/lux-scheme/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux + # Run compiler test suite cd ~/lux/new-luxc/ && lein_2_7_1 lux auto test cd ~/lux/new-luxc/ && lein clean && lein_2_7_1 lux auto test diff --git a/documentation/research/debugging.md b/documentation/research/debugging.md index bd2074543..39fa3b51f 100644 --- a/documentation/research/debugging.md +++ b/documentation/research/debugging.md @@ -1,5 +1,6 @@ # Tool +1. https://github.com/srg-imperial/SaBRe 1. https://developer.mozilla.org/en-US/docs/Mozilla/Projects/WebReplay 1. https://umaar.github.io/performance-debugging-devtools-2018/#/ 1. https://microsoft.github.io/debug-adapter-protocol/ diff --git a/lux-scheme/project.clj b/lux-scheme/project.clj new file mode 100644 index 000000000..b5f22536e --- /dev/null +++ b/lux-scheme/project.clj @@ -0,0 +1,30 @@ +(def version "0.6.0-SNAPSHOT") +(def repo "https://github.com/LuxLang/lux") +(def sonatype-releases "https://oss.sonatype.org/service/local/staging/deploy/maven2/") +(def sonatype-snapshots "https://oss.sonatype.org/content/repositories/snapshots/") + +(defproject com.github.luxlang/lux-scheme #=(identity version) + :description "A Scheme compiler for Lux." + :url ~repo + :license {:name "Lux License v0.1" + :url ~(str repo "/blob/master/license.txt")} + :scm {:name "git" + :url ~(str repo ".git")} + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + + :repositories [["releases" ~sonatype-releases] + ["snapshots" ~sonatype-snapshots]] + :deploy-repositories [["releases" {:url ~sonatype-releases :creds :gpg}] + ["snapshots" {:url ~sonatype-snapshots :creds :gpg}]] + + :plugins [[com.github.luxlang/lein-luxc ~version]] + :dependencies [[com.github.luxlang/luxc-jvm ~version] + [com.github.luxlang/stdlib ~version] + [kawa-scheme/kawa-core "2.4"]] + + :manifest {"lux" ~version} + :source-paths ["source"] + :lux {:program "program"} + ) diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux new file mode 100644 index 000000000..b4adddec9 --- /dev/null +++ b/lux-scheme/source/program.lux @@ -0,0 +1,355 @@ +(.module: + [lux #* + ["." debug] + ["." host (#+ import: interface: do-to object)] + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["." io (#+ IO io)] + [parser + [cli (#+ program:)]]] + [data + ["." maybe] + ["." error (#+ Error)] + [number + ["." i64]] + ["." text ("#@." hash) + format] + [collection + ["." array (#+ Array)]]] + [macro + ["." template]] + [world + ["." file]] + [target + ["_" scheme]] + [tool + [compiler + ["." name] + ["." synthesis] + [phase + [macro (#+ Expander)] + ["." generation + ["." scheme + ["." runtime] + ["." extension]]]] + [default + ["." platform (#+ Platform)]]]]] + [program + ["/" compositor + ["/." cli]]]) + +(import: #long java/lang/Boolean) +(import: #long java/lang/String) + +(import: #long (java/lang/Class a)) + +(import: #long java/lang/Object + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))) + +(import: #long java/lang/Long + (intValue [] java/lang/Integer)) + +(import: #long java/lang/Integer + (longValue [] java/lang/Long)) + +(import: #long gnu/math/IntNum + (new #manual [int]) + (longValue [] long)) + +(import: #long gnu/math/DFloNum + (doubleValue [] double)) + +(import: #long gnu/lists/FString + (toString [] String)) + +(import: #long gnu/lists/Pair + (getCar [] java/lang/Object) + (getCdr [] java/lang/Object)) + +(import: #long (gnu/lists/FVector E) + (getBufferLength [] int) + (getRaw [int] E)) + +(import: #long gnu/expr/ModuleMethod + (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object)) + +(import: #long gnu/mapping/Environment) + +(import: #long gnu/expr/Language + (eval [java/lang/String] #try java/lang/Object)) + +(import: #long kawa/standard/Scheme + (#static getR7rsInstance [] kawa/standard/Scheme)) + +(def: (variant? value) + (-> Any Bit) + (case (host.check (Array java/lang/Object) (:coerce java/lang/Object value)) + (#.Some array) + ## TODO: Get rid of this coercion ASAP. + (let [array (:coerce (Array java/lang/Object) array)] + (and (n/= 3 (array.size array)) + (case (array.read 0 array) + (#.Some tag) + (case (host.check java/lang/Integer tag) + (#.Some _) + true + + #.None + false) + + #.None + false))) + + #.None + false)) + +(template [<name>] + [(interface: <name> + (getValue [] java/lang/Object)) + + (`` (import: #long (~~ (template.identifier ["program/" <name>])) + (getValue [] java/lang/Object)))] + + [VariantValue] + [TupleValue] + ) + +(def: (variant-value lux-value cdr? value) + (-> (-> java/lang/Object java/lang/Object) Bit (Array java/lang/Object) gnu/lists/Pair) + (object [] gnu/lists/Pair [program/VariantValue] + [] + ## Methods + (program/VariantValue + (getValue self) java/lang/Object + (:coerce java/lang/Object value)) + (gnu/lists/Pair + (getCar self) java/lang/Object + (if cdr? + (case (array.read 1 value) + (#.Some flag-is-set) + (:coerce java/lang/Object "") + + #.None + (host.null)) + (|> value + (array.read 0) + maybe.assume + (:coerce java/lang/Integer) + gnu/math/IntNum::new))) + (gnu/lists/Pair + (getCdr self) java/lang/Object + (if cdr? + (|> value + (array.read 2) + maybe.assume + lux-value) + (variant-value lux-value true value))))) + +(def: (tuple-value lux-value value) + (-> (-> java/lang/Object java/lang/Object) (Array java/lang/Object) gnu/lists/FVector) + (object [] gnu/lists/SimpleVector [program/TupleValue] + [] + ## Methods + (program/TupleValue + (getValue self) java/lang/Object + (:coerce java/lang/Object value)) + (gnu/lists/SimpleVector + (getBufferLength self) int + (host.long-to-int (array.size value))) + (gnu/lists/SimpleVector + (getRaw self {idx int}) java/lang/Object + (|> value + (array.read (|> idx java/lang/Integer::longValue (:coerce Nat))) + maybe.assume + lux-value)) + (gnu/lists/SimpleVector + (getBuffer self) java/lang/Object + (error! "tuple-value getBuffer")) + (gnu/lists/SimpleVector + (setBuffer self {_ java/lang/Object}) void + (error! "tuple-value setBuffer")) + (gnu/lists/SimpleVector + (clearBuffer self {_ int} {_ int}) void + (error! "tuple-value clearBuffer")) + (gnu/lists/SimpleVector + (copyBuffer self {_ int}) void + (error! "tuple-value copyBuffer")) + (gnu/lists/SimpleVector + (newInstance self {_ int}) gnu/lists/SimpleVector + (error! "tuple-value newInstance")) + )) + +(exception: (unknown-kind-of-host-object {object java/lang/Object}) + (exception.report + ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] + ["Object" (java/lang/Object::toString object)])) + +(exception: (cannot-apply-a-non-function {object java/lang/Object}) + (exception.report + ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] + ["Object" (java/lang/Object::toString object)])) + +(def: (lux-value value) + (-> java/lang/Object java/lang/Object) + (<| (case (host.check (Array java/lang/Object) value) + (#.Some value) + ## TODO: Get rid of the coercions below. + (if (variant? value) + (variant-value lux-value false (:coerce (Array java/lang/Object) value)) + (tuple-value lux-value (:coerce (Array java/lang/Object) value))) + #.None) + value)) + +(type: (Reader a) + (-> a (Error Any))) + +(def: (variant tag flag value) + (-> Nat Bit Any Any) + [(java/lang/Long::intValue (:coerce java/lang/Long tag)) + (: Any + (if flag + synthesis.unit + (host.null))) + value]) + +(def: (read-variant read host-object) + (-> (Reader java/lang/Object) (Reader gnu/lists/Pair)) + (do error.monad + [tag (read (gnu/lists/Pair::getCar host-object)) + #let [host-object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host-object)) + flag (case (host.check java/lang/String (gnu/lists/Pair::getCar host-object)) + (#.Some _) + true + + #.None + false)] + value (read (gnu/lists/Pair::getCdr host-object))] + (wrap (..variant (:coerce Nat tag) flag value)))) + +(def: (read-tuple read host-object) + (-> (Reader java/lang/Object) (Reader (gnu/lists/FVector java/lang/Object))) + (let [size (.nat (gnu/lists/FVector::getBufferLength host-object))] + (loop [idx 0 + output (: (Array Any) + (array.new size))] + (if (n/< size idx) + (case (read (gnu/lists/FVector::getRaw (.int idx) host-object)) + (#error.Failure error) + (#error.Failure error) + + (#error.Success lux-value) + (recur (inc idx) (array.write idx (: Any lux-value) output))) + (#error.Success output))))) + +(def: (read host-object) + (Reader java/lang/Object) + (`` (<| (~~ (template [<class>] + [(case (host.check <class> host-object) + (#.Some host-object) + (#error.Success host-object) + #.None)] + + [java/lang/Boolean] [java/lang/String] [gnu/expr/ModuleMethod] + )) + (~~ (template [<class> <method>] + [(case (host.check <class> host-object) + (#.Some host-object) + (#error.Success (<method> host-object)) + #.None)] + + [gnu/math/IntNum gnu/math/IntNum::longValue] + [gnu/math/DFloNum gnu/math/DFloNum::doubleValue] + [gnu/lists/FString gnu/lists/FString::toString] + [program/VariantValue program/VariantValue::getValue] + [program/TupleValue program/TupleValue::getValue] + )) + (case (host.check gnu/lists/Pair host-object) + (#.Some host-object) + (read-variant read host-object) + #.None) + (case (host.check gnu/lists/FVector host-object) + (#.Some host-object) + (read-tuple read (:coerce (gnu/lists/FVector java/lang/Object) host-object)) + #.None) + ## else + (exception.throw ..unknown-kind-of-host-object host-object)))) + +(def: ensure-macro + (-> Macro (Maybe gnu/expr/ModuleMethod)) + (|>> (:coerce java/lang/Object) (host.check gnu/expr/ModuleMethod))) + +(def: (expander macro inputs lux) + Expander + (case (ensure-macro macro) + (#.Some macro) + (case (gnu/expr/ModuleMethod::apply2 (lux-value (:coerce java/lang/Object inputs)) + (lux-value (:coerce java/lang/Object lux)) + macro) + (#error.Success output) + (|> output + ..read + (:coerce (Error (Error [Lux (List Code)])))) + + (#error.Failure error) + (#error.Failure error)) + + #.None + (exception.throw ..cannot-apply-a-non-function (:coerce java/lang/Object macro))) + ) + +(def: separator "$") + +(type: Host + (generation.Host _.Expression _.Expression)) + +(def: host + (IO Host) + (io (let [interpreter (kawa/standard/Scheme::getR7rsInstance) + evaluate! (function (evaluate! alias input) + (do error.monad + [output (gnu/expr/Language::eval (_.code input) interpreter)] + (read output)))] + (: Host + (structure + (def: evaluate! evaluate!) + (def: (execute! alias input) + (gnu/expr/Language::eval (_.code input) interpreter)) + (def: (define! [module name] input) + (let [global (format (text.replace-all .module-separator ..separator module) + ..separator (name.normalize name) + "___" (%n (text@hash name))) + @global (_.var global)] + (do error.monad + [#let [definition (_.define-constant @global input)] + _ (gnu/expr/Language::eval (_.code definition) interpreter) + value (evaluate! global @global)] + (wrap [global value definition]))))))))) + +(def: platform + (IO (Platform IO _.Var _.Expression _.Expression)) + (do io.monad + [host ..host] + (wrap {#platform.&monad io.monad + #platform.&file-system file.system + #platform.host host + #platform.phase scheme.generate + #platform.runtime runtime.generate}))) + +(def: (program program) + (-> _.Expression _.Expression) + (_.apply/2 program + ## TODO: Figure out how to always get the command-line + ## arguments. + ## It appears that it differs between Scheme implementations. + (runtime.lux//program-args _.nil) + _.nil)) + +(program: [{service /cli.service}] + (/.compiler ..expander + ..platform + extension.bundle + ..program + service)) diff --git a/new-luxc/project.clj b/new-luxc/project.clj index 322800e29..cd74becbc 100644 --- a/new-luxc/project.clj +++ b/new-luxc/project.clj @@ -22,10 +22,7 @@ :url ~(str repo ".git")} :dependencies [;; JVM Bytecode - [org.ow2.asm/asm-all "5.0.3"] - ;; ;; Scheme - ;; [kawa-scheme/kawa-core "2.4"] - ] + [org.ow2.asm/asm-all "5.0.3"]] :manifest {"lux" ~version} :source-paths ["source"] diff --git a/new-luxc/source/luxc/lang/translation/scheme.lux b/new-luxc/source/luxc/lang/translation/scheme.lux deleted file mode 100644 index e509cb8ca..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme.lux +++ /dev/null @@ -1,214 +0,0 @@ -(.module: - lux - (lux (control ["ex" exception #+ exception:] - pipe - [monad #+ do]) - (data [bit] - [maybe] - ["e" error #+ Error] - [text "text/" Eq<Text>] - text/format - (coll [array])) - [macro] - [io #+ IO Process io] - [host #+ class: interface: object] - (world [file #+ File])) - (luxc [lang] - (lang [".L" variable #+ Register] - (host [scheme #+ Expression])) - [".C" io])) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [No-Active-Module-Buffer] - [Cannot-Execute] - - [No-Anchor] - ) - -(host.import: java/lang/Object) - -(host.import: java/lang/String - (getBytes [String] #try (Array byte))) - -(host.import: java/lang/CharSequence) - -(host.import: java/lang/Appendable - (append [CharSequence] Appendable)) - -(host.import: java/lang/StringBuilder - (new []) - (toString [] String)) - -(host.import: gnu/mapping/Environment) - -(host.import: gnu/expr/Language - (eval [String] #try #? Object)) - -(host.import: kawa/standard/Scheme - (#static getR7rsInstance [] Scheme)) - -(type: #export Anchor [Text Register]) - -(type: #export Host - {#context [Text Nat] - #anchor (Maybe Anchor) - #loader (-> Expression (Error Any)) - #interpreter (-> Expression (Error Object)) - #module-buffer (Maybe StringBuilder) - #program-buffer StringBuilder}) - -(def: #export init - (IO Host) - (io (let [interpreter (Scheme::getR7rsInstance [])] - {#context ["" +0] - #anchor #.None - #loader (function (_ code) - (do e.Monad<Error> - [_ (Language::eval [(scheme.expression code)] interpreter)] - (wrap []))) - #interpreter (function (_ code) - (do e.Monad<Error> - [output (Language::eval [(scheme.expression code)] interpreter)] - (wrap (maybe.default (:coerce Object []) - output)))) - #module-buffer #.None - #program-buffer (StringBuilder::new [])}))) - -(def: #export file-extension ".scm") - -(def: #export r-module-name Text (format "module" file-extension)) - -(def: #export init-module-buffer - (Meta Any) - (function (_ compiler) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #module-buffer (#.Some (StringBuilder::new []))) - (:coerce Nothing)) - compiler) - []]))) - -(def: #export (with-sub-context expr) - (All [a] (-> (Meta a) (Meta [Text a]))) - (function (_ compiler) - (let [old (:coerce Host (get@ #.host compiler)) - [old-name old-sub] (get@ #context old) - new-name (format old-name "f___" (%i (.int old-sub)))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #context [new-name +0] old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #context [old-name (inc old-sub)]) - (:coerce Nothing)) - compiler') - [new-name output]]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export context - (Meta Text) - (function (_ compiler) - (#e.Success [compiler - (|> (get@ #.host compiler) - (:coerce Host) - (get@ #context) - (let> [name sub] - name))]))) - -(def: #export (with-anchor anchor expr) - (All [a] (-> Anchor (Meta a) (Meta a))) - (function (_ compiler) - (let [old (:coerce Host (get@ #.host compiler))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #anchor (#.Some anchor) old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #anchor (get@ #anchor old)) - (:coerce Nothing)) - compiler') - output]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export anchor - (Meta Anchor) - (function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce Host) (get@ #anchor)) - (#.Some anchor) - (#e.Success [compiler anchor]) - - #.None - ((lang.throw No-Anchor "") compiler)))) - -(def: #export module-buffer - (Meta StringBuilder) - (function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce Host) (get@ #module-buffer)) - #.None - ((lang.throw No-Active-Module-Buffer "") compiler) - - (#.Some module-buffer) - (#e.Success [compiler module-buffer])))) - -(def: #export program-buffer - (Meta StringBuilder) - (function (_ compiler) - (#e.Success [compiler (|> compiler (get@ #.host) (:coerce Host) (get@ #program-buffer))]))) - -(template [<name> <field> <outputT>] - [(def: (<name> code) - (-> Expression (Meta <outputT>)) - (function (_ compiler) - (let [runner (|> compiler (get@ #.host) (:coerce Host) (get@ <field>))] - (case (runner code) - (#e.Error error) - ((lang.throw Cannot-Execute error) compiler) - - (#e.Success output) - (#e.Success [compiler output])))))] - - [load! #loader Any] - [interpret #interpreter Object] - ) - -(def: #export variant-tag "lux-variant") - -(def: #export unit Text "") - -(def: #export (definition-name [module name]) - (-> Name Text) - (lang.normalize-name (format module "$" name))) - -(def: #export (save code) - (-> Expression (Meta Any)) - (do macro.Monad<Meta> - [module-buffer module-buffer - #let [_ (Appendable::append [(:coerce CharSequence (scheme.expression code))] - module-buffer)]] - (load! code))) - -(def: #export run interpret) - -(def: #export (save-module! target) - (-> File (Meta (Process Any))) - (do macro.Monad<Meta> - [module macro.current-module-name - module-buffer module-buffer - program-buffer program-buffer - #let [module-code (StringBuilder::toString [] module-buffer) - _ (Appendable::append [(:coerce CharSequence (format module-code "\n"))] - program-buffer)]] - (wrap (ioC.write target - (format (lang.normalize-name module) "/" r-module-name) - (|> module-code - (String::getBytes ["UTF-8"]) - e.assume))))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/eval.jvm.lux deleted file mode 100644 index db9b25129..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/eval.jvm.lux +++ /dev/null @@ -1,154 +0,0 @@ -(.module: - lux - (lux (control ["ex" exception #+ exception:] - [monad #+ do]) - (data [bit] - [maybe] - ["e" error #+ Error] - [text "text/" Eq<Text>] - text/format - (coll [array])) - [host]) - (luxc [lang] - (lang (host [scheme #+ Expression]))) - [//]) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Unknown-Kind-Of-Host-Object] - [Null-Has-No-Lux-Representation] - [Cannot-Evaluate] - [invalid-variant] - ) - -(host.import: java/lang/Object - (toString [] String) - (getClass [] (Class Object))) - -(host.import: java/lang/Long - (intValue [] Integer)) - -(host.import: java/lang/Boolean) -(host.import: java/lang/String) - -(host.import: gnu/math/IntNum - (longValue [] long)) - -(host.import: gnu/math/DFloNum - (doubleValue [] double)) - -(host.import: (gnu/lists/FVector E) - (getBufferLength [] int) - (get [int] E)) - -(host.import: gnu/lists/EmptyList) - -(host.import: gnu/lists/FString - (toString [] String)) - -(host.import: gnu/lists/Pair - (getCar [] Object) - (getCdr [] Object) - (get [int] Object)) - -(host.import: gnu/mapping/Symbol - (getName [] String)) - -(host.import: gnu/mapping/SimpleSymbol) - -(def: (parse-tuple lux-object host-object) - (-> (-> Object (Error Any)) (FVector Object) (Error Any)) - (let [size (:coerce Nat (FVector::getBufferLength [] host-object))] - (loop [idx +0 - output (:coerce (Array Any) (array.new size))] - (if (n/< size idx) - (case (lux-object (FVector::get [(:coerce Int idx)] host-object)) - (#e.Error error) - (#e.Error error) - - (#e.Success lux-value) - (recur (inc idx) (array.write idx (:coerce Any lux-value) output))) - (#e.Success output))))) - -(def: (variant tag flag value) - (-> Nat Bit Any Any) - [(Long::intValue [] (:coerce Long tag)) - (: Any - (if flag - //.unit - (host.null))) - value]) - -(def: (to-text value) - (-> Any Text) - (let [value-text (:coerce Text (Object::toString [] (:coerce Object value))) - class-text (:coerce Text (Object::toString [] (Object::getClass [] (:coerce Object value))))] - (format value-text " : " class-text))) - -(def: (parse-variant lux-object host-object) - (-> (-> Object (Error Any)) Pair (Error Any)) - (let [variant-tag (Pair::getCar [] host-object)] - (if (and (host.instance? gnu/mapping/SimpleSymbol variant-tag) - (text/= //.variant-tag (Symbol::getName [] (:coerce Symbol variant-tag)))) - (do e.Monad<Error> - [#let [host-object (:coerce Pair (Pair::getCdr [] host-object))] - tag (lux-object (Pair::getCar [] host-object)) - #let [host-object (:coerce Pair (Pair::getCdr [] host-object))] - #let [flag (host.instance? java/lang/String - (Pair::getCar [] host-object))] - value (lux-object (Pair::getCdr [] host-object))] - (wrap (..variant (:coerce Nat tag) flag value))) - (ex.throw invalid-variant (:coerce Text (Object::toString [] (:coerce Object host-object))))))) - -(def: (lux-object host-object) - (-> Object (Error Any)) - (cond (or (host.instance? java/lang/Boolean host-object) - (host.instance? java/lang/String host-object)) - (#e.Success host-object) - - (host.instance? gnu/math/IntNum host-object) - (#e.Success (IntNum::longValue [] (:coerce IntNum host-object))) - - (host.instance? gnu/math/DFloNum host-object) - (#e.Success (DFloNum::doubleValue [] (:coerce DFloNum host-object))) - - (host.instance? gnu/lists/FString host-object) - (#e.Success (FString::toString [] (:coerce FString host-object))) - - (host.instance? gnu/lists/FVector host-object) - (parse-tuple lux-object (:coerce (FVector Object) host-object)) - - (host.instance? gnu/lists/EmptyList host-object) - (#e.Success //.unit) - - (host.instance? gnu/lists/Pair host-object) - (parse-variant lux-object (:coerce Pair host-object)) - - ## else - (let [object-class (:coerce Text (Object::toString [] (Object::getClass [] (:coerce Object host-object)))) - text-representation (:coerce Text (Object::toString [] (:coerce Object host-object)))] - (ex.throw Unknown-Kind-Of-Host-Object (format object-class " --- " text-representation))))) - -(def: #export (eval code) - (-> Expression (Meta Any)) - (function (_ compiler) - (let [interpreter (|> compiler (get@ #.host) (:coerce //.Host) (get@ #//.interpreter))] - (case (interpreter code) - (#e.Error error) - (exec (log! (format "eval #e.Error\n" - "<< " (scheme.expression code) "\n" - error)) - ((lang.throw Cannot-Evaluate error) compiler)) - - (#e.Success output) - (case (lux-object output) - (#e.Success parsed-output) - (#e.Success [compiler parsed-output]) - - (#e.Error error) - (exec (log! (format "eval #e.Error\n" - "<< " (scheme.expression code) "\n" - error)) - ((lang.throw Cannot-Evaluate error) compiler))))))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/statement.jvm.lux deleted file mode 100644 index 755e8a898..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/statement.jvm.lux +++ /dev/null @@ -1,45 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - [macro] - (data text/format)) - (luxc (lang [".L" module] - (host ["_" scheme #+ Expression @@]))) - [//] - (// [".T" runtime] - [".T" reference] - [".T" eval])) - -(def: #export (translate-def name expressionT expressionO metaV) - (-> Text Type Expression Code (Meta Any)) - (do macro.Monad<Meta> - [current-module macro.current-module-name - #let [def-name [current-module name]]] - (case (macro.get-identifier-ann (name-of #.alias) metaV) - (#.Some real-def) - (do @ - [[realT realA realV] (macro.find-def real-def) - _ (moduleL.define def-name [realT metaV realV])] - (wrap [])) - - _ - (do @ - [#let [def-name (referenceT.global def-name)] - _ (//.save (_.define def-name (list) expressionO)) - expressionV (evalT.eval (@@ def-name)) - _ (moduleL.define def-name [expressionT metaV expressionV]) - _ (if (macro.type? metaV) - (case (macro.declared-tags metaV) - #.Nil - (wrap []) - - tags - (moduleL.declare-tags tags (macro.export? metaV) (:coerce Type expressionV))) - (wrap [])) - #let [_ (log! (format "DEF " (%name def-name)))]] - (wrap [])) - ))) - -(def: #export (translate-program programO) - (-> Expression (Meta Expression)) - (macro.fail "translate-program NOT IMPLEMENTED YET")) diff --git a/stdlib/source/lux/target/scheme.lux b/stdlib/source/lux/target/scheme.lux index 820ff8c83..886d2ba88 100644 --- a/stdlib/source/lux/target/scheme.lux +++ b/stdlib/source/lux/target/scheme.lux @@ -1,15 +1,14 @@ (.module: [lux (#- Code int or and if function cond let) [control - [pipe (#+ new> cond> case>)] - ["." function]] + [pipe (#+ new> cond> case>)]] [data [number ["." frac]] ["." text format] [collection - ["." list ("#;." functor fold)]]] + ["." list ("#@." functor fold)]]] [macro ["." template]] [type @@ -44,25 +43,25 @@ (def: #export var (-> Text Var) (|>> :abstraction)) - (def: (arguments [vars rest]) + (def: (arguments [mandatory rest]) (-> Arguments (Code Any)) (case rest (#.Some rest) - (case vars + (case mandatory #.Nil rest _ (|> (format " . " (:representation rest)) - (format (|> vars - (list;map ..code) + (format (|> mandatory + (list@map ..code) (text.join-with " "))) (text.enclose ["(" ")"]) :abstraction)) #.None - (|> vars - (list;map ..code) + (|> mandatory + (list@map ..code) (text.join-with " ") (text.enclose ["(" ")"]) :abstraction))) @@ -129,14 +128,15 @@ (|>> :abstraction)) (def: form - (-> (List (Code Any)) Text) - (|>> (list;map ..code) + (-> (List (Code Any)) Code) + (|>> (list@map ..code) (text.join-with " ") - (text.enclose ["(" ")"]))) + (text.enclose ["(" ")"]) + :abstraction)) (def: #export (apply/* func args) (-> Expression (List Expression) Computation) - (:abstraction (..form (#.Cons func args)))) + (..form (#.Cons func args))) (template [<name> <function>] [(def: #export <name> @@ -193,7 +193,7 @@ [[append/2 "append"] [cons/2 "cons"] [make-vector/2 "make-vector"] - [vector-ref/2 "vector-ref"] + ## [vector-ref/2 "vector-ref"] [list-tail/2 "list-tail"] [map/2 "map"] [string-ref/2 "string-ref"] @@ -207,6 +207,23 @@ [[vector-copy!/5 "vector-copy!"]]] ) + ## TODO: define "vector-ref/2" like a normal apply/2 function. + ## "vector-ref/2" as an 'invoke' is problematic, since it only works + ## in Kawa. + ## However, the way Kawa defines "vector-ref" causes trouble, + ## because it does a runtime type-check which throws an error when + ## it checks against custom values/objects/classes made for + ## JVM<->Scheme interop. + ## There are 2 ways to deal with this: + ## 0. To fork Kawa, and get rid of the type-check so the normal + ## "vector-ref" can be used instead. + ## 1. To carry on, and then, when it's time to compile the compiler + ## itself into Scheme, switch from 'invoke' to normal 'vector-ref'. + ## Either way, the 'invoke' needs to go away. + (def: #export (vector-ref/2 vector index) + (-> Expression Expression Computation) + (..form (list (..var "invoke") vector (..symbol "getRaw") index))) + (template [<lux-name> <scheme-name>] [(def: #export (<lux-name> param subject) (-> Expression Expression Computation) @@ -238,7 +255,7 @@ (template [<lux-name> <scheme-name>] [(def: #export <lux-name> (-> (List Expression) Computation) - (|>> (list& (..global <scheme-name>)) ..form :abstraction))] + (|>> (list& (..global <scheme-name>)) ..form))] [or "or"] [and "and"] @@ -247,20 +264,17 @@ (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 function.identity] - [let* "let*" Var function.identity] - [letrec "letrec" Var function.identity] + (..form (list (..global <scheme-name>) + (|> bindings + (list@map (.function (_ [binding/name binding/value]) + (..form (list (|> binding/name <pre>) + binding/value)))) + ..form) + body)))] + + [let "let" Var (<|)] + [let* "let*" Var (<|)] + [letrec "letrec" Var (<|)] [let-values "let-values" Arguments ..arguments] [let*-values "let*-values" Arguments ..arguments] [letrec-values "letrec-values" Arguments ..arguments] @@ -268,17 +282,15 @@ (def: #export (if test then else) (-> Expression Expression Expression Computation) - (:abstraction - (..form (list (..global "if") test then else)))) + (..form (list (..global "if") test then else))) (def: #export (when test then) (-> Expression Expression Computation) - (:abstraction - (..form (list (..global "when") test then)))) + (..form (list (..global "when") test then))) (def: #export (cond clauses else) (-> (List [Expression Expression]) Expression Computation) - (|> (list;fold (.function (_ [test then] next) + (|> (list@fold (.function (_ [test then] next) (if test then next)) else (list.reverse clauses)) @@ -287,31 +299,31 @@ (def: #export (lambda arguments body) (-> Arguments Expression Computation) - (:abstraction - (..form (list (..global "lambda") - (..arguments arguments) - body)))) + (..form (list (..global "lambda") + (..arguments arguments) + body))) - (def: #export (define name arguments body) + (def: #export (define-function name arguments body) (-> Var Arguments Expression Computation) - (:abstraction - (..form (list (..global "define") - (|> arguments - (update@ #mandatory (|>> (#.Cons name))) - ..arguments) - body)))) + (..form (list (..global "define") + (|> arguments + (update@ #mandatory (|>> (#.Cons name))) + ..arguments) + body))) + + (def: #export (define-constant name value) + (-> Var Expression Computation) + (..form (list (..global "define") name value))) (def: #export begin (-> (List Expression) Computation) - (|>> (#.Cons (..global "begin")) ..form :abstraction)) + (|>> (#.Cons (..global "begin")) ..form)) (def: #export (set! name value) (-> Var Expression Computation) - (:abstraction - (..form (list (..global "set!") name value)))) + (..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)))) + (..form (list (..global "with-exception-handler") handler body))) ) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux index d4cd440fb..04d3bae1d 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux @@ -9,7 +9,7 @@ ["." text format] [collection - ["." list ("#;." functor fold)]]] + ["." list ("#@." functor fold)]]] [target ["_" scheme (#+ Expression Computation Var)]]] ["." // #_ @@ -17,7 +17,7 @@ ["#." primitive] ["#/" // #_ ["#." reference] - ["#/" // ("#;." monad) + ["#/" // ("#@." monad) ["#/" // #_ [reference (#+ Register)] ["#." synthesis (#+ Synthesis Path)]]]]]) @@ -35,15 +35,18 @@ bodyO)))) (def: #export (record-get generate valueS pathP) - (-> Phase Synthesis (List [Nat Bit]) + (-> Phase Synthesis (List (Either Nat Nat)) (Operation Expression)) (do ////.monad [valueO (generate valueS)] - (wrap (list;fold (function (_ [idx tail?] source) - (.let [method (.if tail? - //runtime.product//right - //runtime.product//left)] - (method source (_.int (.int idx))))) + (wrap (list@fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + (<side> lefts) + (<accessor> (_.int (.int lefts)))) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) valueO pathP)))) @@ -98,9 +101,9 @@ (def: (pm-catch handler) (-> Expression Computation) (_.lambda [(list @alt-error) #.None] - (_.if (|> @alt-error (_.eqv?/2 pm-error)) - handler - (_.raise/1 @alt-error)))) + (_.if (|> @alt-error (_.eqv?/2 pm-error)) + handler + (_.raise/1 @alt-error)))) (def: (pattern-matching' generate pathP) (-> Phase Path (Operation Expression)) @@ -109,15 +112,14 @@ (generate bodyS) #/////synthesis.Pop - (////;wrap pop-cursor!) + (////@wrap pop-cursor!) (#/////synthesis.Bind register) - (////;wrap (_.define (..register register) [(list) #.None] - cursor-top)) + (////@wrap (_.define-constant (..register register) ..cursor-top)) (^template [<tag> <format> <=>] (^ (<tag> value)) - (////;wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) + (////@wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) fail-pm!))) ([/////synthesis.path/bit //primitive.bit _.eqv?/2] [/////synthesis.path/i64 (<| //primitive.i64 .int) _.=/2] @@ -126,18 +128,18 @@ (^template [<pm> <flag> <prep>] (^ (<pm> idx)) - (////;wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))]) + (////@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>] + (^template [<pm> <getter>] (^ (<pm> idx)) - (////;wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!))) - ([/////synthesis.member/left //runtime.product//left (<|)] - [/////synthesis.member/right //runtime.product//right inc]) + (////@wrap (push-cursor! (<getter> (_.int (.int idx)) cursor-top)))) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) (^template [<tag> <computation>] (^ (<tag> leftP rightP)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux index f33cb9599..6701bc078 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux @@ -82,36 +82,24 @@ Binary (<op> paramO subjectO))] - [bit::and _.bit-and/2] - [bit::or _.bit-or/2] - [bit::xor _.bit-xor/2] + [i64::and _.bit-and/2] + [i64::or _.bit-or/2] + [i64::xor _.bit-xor/2] ) -(def: (bit::left-shift [subjectO paramO]) +(def: (i64::left-shift [subjectO paramO]) Binary (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) subjectO)) -(def: (bit::arithmetic-right-shift [subjectO paramO]) +(def: (i64::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]) +(def: (i64::logical-right-shift [subjectO paramO]) Binary - (///runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) - -(def: bundle::bit - Bundle - (<| (bundle.prefix "bit") - (|> bundle.empty - (bundle.install "and" (binary bit::and)) - (bundle.install "or" (binary bit::or)) - (bundle.install "xor" (binary bit::xor)) - (bundle.install "left-shift" (binary bit::left-shift)) - (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) - ))) + (///runtime.i64//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) (import: java/lang/Double (#static MIN_VALUE Double) @@ -122,9 +110,9 @@ Nullary (<encode> <const>))] - [frac::smallest (Double::MIN_VALUE) _.float] - [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float] - [frac::max (Double::MAX_VALUE) _.float] + [f64::smallest (Double::MIN_VALUE) _.float] + [f64::min (f/* -1.0 (Double::MAX_VALUE)) _.float] + [f64::max (Double::MAX_VALUE) _.float] ) (template [<name> <op>] @@ -132,11 +120,11 @@ Binary (|> subjectO (<op> paramO)))] - [int::+ _.+/2] - [int::- _.-/2] - [int::* _.*/2] - [int::/ _.quotient/2] - [int::% _.remainder/2] + [i64::+ _.+/2] + [i64::- _.-/2] + [i64::* _.*/2] + [i64::/ _.quotient/2] + [i64::% _.remainder/2] ) (template [<name> <op>] @@ -144,13 +132,13 @@ Binary (<op> paramO subjectO))] - [frac::+ _.+/2] - [frac::- _.-/2] - [frac::* _.*/2] - [frac::/ _.//2] - [frac::% _.mod/2] - [frac::= _.=/2] - [frac::< _.</2] + [f64::+ _.+/2] + [f64::- _.-/2] + [f64::* _.*/2] + [f64::/ _.//2] + [f64::% _.mod/2] + [f64::= _.=/2] + [f64::< _.</2] [text::= _.string=?/2] [text::< _.string<?/2] @@ -161,41 +149,47 @@ Binary (<cmp> paramO subjectO))] - [int::= _.=/2] - [int::< _.</2] + [i64::= _.=/2] + [i64::< _.</2] ) -(def: int::char (|>> _.integer->char/1 _.string/1)) +(def: i64::char (|>> _.integer->char/1 _.string/1)) -(def: bundle::int +(def: bundle::i64 Bundle - (<| (bundle.prefix "int") + (<| (bundle.prefix "i64") (|> bundle.empty - (bundle.install "+" (binary int::+)) - (bundle.install "-" (binary int::-)) - (bundle.install "*" (binary int::*)) - (bundle.install "/" (binary int::/)) - (bundle.install "%" (binary int::%)) - (bundle.install "=" (binary int::=)) - (bundle.install "<" (binary int::<)) - (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0))))) - (bundle.install "char" (unary int::char))))) - -(def: bundle::frac + (bundle.install "and" (binary i64::and)) + (bundle.install "or" (binary i64::or)) + (bundle.install "xor" (binary i64::xor)) + (bundle.install "left-shift" (binary i64::left-shift)) + (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) + (bundle.install "+" (binary i64::+)) + (bundle.install "-" (binary i64::-)) + (bundle.install "*" (binary i64::*)) + (bundle.install "/" (binary i64::/)) + (bundle.install "%" (binary i64::%)) + (bundle.install "=" (binary i64::=)) + (bundle.install "<" (binary i64::<)) + (bundle.install "f64" (unary (|>> (_.//2 (_.float +1.0))))) + (bundle.install "char" (unary i64::char))))) + +(def: bundle::f64 Bundle - (<| (bundle.prefix "frac") + (<| (bundle.prefix "f64") (|> bundle.empty - (bundle.install "+" (binary frac::+)) - (bundle.install "-" (binary frac::-)) - (bundle.install "*" (binary frac::*)) - (bundle.install "/" (binary frac::/)) - (bundle.install "%" (binary frac::%)) - (bundle.install "=" (binary frac::=)) - (bundle.install "<" (binary frac::<)) - (bundle.install "smallest" (nullary frac::smallest)) - (bundle.install "min" (nullary frac::min)) - (bundle.install "max" (nullary frac::max)) - (bundle.install "to-int" (unary _.exact/1)) + (bundle.install "+" (binary f64::+)) + (bundle.install "-" (binary f64::-)) + (bundle.install "*" (binary f64::*)) + (bundle.install "/" (binary f64::/)) + (bundle.install "%" (binary f64::%)) + (bundle.install "=" (binary f64::=)) + (bundle.install "<" (binary f64::<)) + (bundle.install "smallest" (nullary f64::smallest)) + (bundle.install "min" (nullary f64::min)) + (bundle.install "max" (nullary f64::max)) + (bundle.install "i64" (unary _.exact/1)) (bundle.install "encode" (unary _.number->string/1)) (bundle.install "decode" (unary ///runtime.frac//decode))))) @@ -240,9 +234,8 @@ Bundle (<| (bundle.prefix "lux") (|> bundle::lux - (dict.merge bundle::bit) - (dict.merge bundle::int) - (dict.merge bundle::frac) + (dict.merge bundle::i64) + (dict.merge bundle::f64) (dict.merge bundle::text) (dict.merge bundle::io) ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux index 3fe02a55d..94269b4aa 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux @@ -38,8 +38,6 @@ (def: unit (_.string /////synthesis.unit)) -(def: #export variant-tag "lux-variant") - (def: (flag value) (-> Bit Computation) (if value @@ -48,8 +46,7 @@ (def: (variant' tag last? value) (-> Expression Expression Expression Computation) - (<| (_.cons/2 (_.symbol ..variant-tag)) - (_.cons/2 tag) + (<| (_.cons/2 tag) (_.cons/2 last?) value)) @@ -102,15 +99,15 @@ _.Computation (~ (case argsC+ #.Nil - (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + (` (_.define-constant (~ @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)))))))))))) + (_.define-function (~ @runtime) [(list (~+ argsLC+)) #.None] + (~ definition)))))))))))) (runtime: (slice offset length list) (<| (_.if (_.null?/1 list) @@ -156,58 +153,40 @@ (_.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) +(def: last-index (-> Expression Computation) - (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1))))) + (|>> _.length/1 (_.-/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")] +(runtime: (tuple//left lefts tuple) + (with-vars [last-index-right] (_.begin - (list (_.define @index_min_length [(list) #.None] - (minimum-index-length index)) - (_.if (|> product _.length/1 (_.>/2 @index_min_length)) + (list (_.define-constant last-index-right (..last-index tuple)) + (_.if (_.>/2 lefts last-index-right) ## No need for recursion - (product-element index product) + (_.vector-ref/2 tuple lefts) ## 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))] + (tuple//left (_.-/2 last-index-right lefts) + (_.vector-ref/2 tuple last-index-right))))))) + +(runtime: (tuple//right lefts tuple) + (with-vars [last-index-right right-index @slice] (_.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))))))) + (list (_.define-constant last-index-right (..last-index tuple)) + (_.define-constant right-index (_.+/2 (_.int +1) lefts)) + (_.cond (list [(_.=/2 right-index last-index-right) + (_.vector-ref/2 tuple right-index)] + [(_.>/2 right-index last-index-right) + ## Needs recursion. + (tuple//right (_.-/2 last-index-right lefts) + (_.vector-ref/2 tuple last-index-right))]) + (_.begin + (list (_.define-constant @slice (_.make-vector/1 (_.-/2 right-index (_.length/1 tuple)))) + (_.vector-copy!/5 @slice (_.int +0) tuple right-index (_.length/1 tuple)) + @slice)))) + ))) (runtime: (sum//get sum last? wanted-tag) - (with-vars [variant-tag sum-tag sum-flag sum-value] + (with-vars [sum-tag sum-flag sum-value] (let [no-match _.nil is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) test-recursion (_.if is-last? @@ -216,8 +195,10 @@ (|> 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))])) + (<| (_.let (list [sum-tag (_.car/1 sum)] + [sum-value (_.cdr/1 sum)])) + (_.let (list [sum-flag (_.car/1 sum-value)] + [sum-value (_.cdr/1 sum-value)])) (_.if (|> wanted-tag (_.=/2 sum-tag)) (_.if (|> sum-flag (_.eqv?/2 last?)) sum-value @@ -231,11 +212,11 @@ (def: runtime//adt Computation - (_.begin (list @@product//left - @@product//right + (_.begin (list @@tuple//left + @@tuple//right @@sum//get))) -(runtime: (bit//logical-right-shift shift input) +(runtime: (i64//logical-right-shift shift input) (_.if (_.=/2 (_.int +0) shift) input (|> input @@ -244,7 +225,7 @@ (def: runtime//bit Computation - (_.begin (list @@bit//logical-right-shift))) + (_.begin (list @@i64//logical-right-shift))) (runtime: (frac//decode input) (with-vars [@output] @@ -259,42 +240,6 @@ (_.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: (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)) @@ -310,8 +255,6 @@ runtime//bit runtime//adt runtime//frac - runtime//array - runtime//box runtime//io ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux index e101effeb..f435442cc 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux @@ -30,4 +30,8 @@ (-> Phase (Variant Synthesis) (Operation Expression)) (do ///.monad [valueT (generate valueS)] - (wrap (runtime.variant [lefts right? valueT])))) + (wrap (runtime.variant [(if right? + (inc lefts) + lefts) + right? + valueT])))) |