aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--.gitignore6
-rw-r--r--commands13
-rw-r--r--documentation/research/debugging.md1
-rw-r--r--lux-scheme/project.clj30
-rw-r--r--lux-scheme/source/program.lux355
-rw-r--r--new-luxc/project.clj5
-rw-r--r--new-luxc/source/luxc/lang/translation/scheme.lux214
-rw-r--r--new-luxc/source/luxc/lang/translation/scheme/eval.jvm.lux154
-rw-r--r--new-luxc/source/luxc/lang/translation/scheme/statement.jvm.lux45
-rw-r--r--stdlib/source/lux/target/scheme.lux112
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux42
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux123
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux133
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux6
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
+
diff --git a/commands b/commands
index 84ccc9cc4..9e55eeec6 100644
--- a/commands
+++ b/commands
@@ -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]))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 23:53:54 +0000