WIP: Separate Scheme compiler.

3 files changed, 0 insertions, 413 deletions

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