WIP: Separate Scheme compiler.

2 files changed, 385 insertions, 0 deletions

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))