From eb59547eae1753c9aed1ee887e44c825c1b32c05 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 May 2019 19:51:14 -0400 Subject: WIP: Separate Scheme compiler. --- lux-scheme/project.clj | 30 ++++ lux-scheme/source/program.lux | 355 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 385 insertions(+) create mode 100644 lux-scheme/project.clj create mode 100644 lux-scheme/source/program.lux (limited to 'lux-scheme') 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 [] + [(interface: + (getValue [] java/lang/Object)) + + (`` (import: #long (~~ (template.identifier ["program/" ])) + (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 [] + [(case (host.check host-object) + (#.Some host-object) + (#error.Success host-object) + #.None)] + + [java/lang/Boolean] [java/lang/String] [gnu/expr/ModuleMethod] + )) + (~~ (template [ ] + [(case (host.check host-object) + (#.Some host-object) + (#error.Success ( 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)) -- cgit v1.2.3