aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator/statement.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/generator/statement.jvm.lux')
-rw-r--r--new-luxc/source/luxc/generator/statement.jvm.lux97
1 files changed, 78 insertions, 19 deletions
diff --git a/new-luxc/source/luxc/generator/statement.jvm.lux b/new-luxc/source/luxc/generator/statement.jvm.lux
index ed66f3ecb..830935dda 100644
--- a/new-luxc/source/luxc/generator/statement.jvm.lux
+++ b/new-luxc/source/luxc/generator/statement.jvm.lux
@@ -1,25 +1,84 @@
(;module:
lux
- (lux (control monad)
- [io #- run]
- (data [text "T/" Eq<Text>]
- text/format)
- [meta #+ Monad<Meta>])
+ (lux (control monad
+ ["ex" exception #+ exception:])
+ (concurrency ["T" task])
+ (data ["e" error]
+ [maybe]
+ [text "text/" Monoid<Text>]
+ text/format
+ (coll [list "list/" Functor<List> Fold<List>]))
+ [meta]
+ [host])
(luxc ["&" base]
- ["&;" module]
["&;" scope]
- (compiler ["&;" expr])))
+ ["&;" module]
+ ["&;" io]
+ (generator ["&;" expr]
+ ["&;" eval]
+ ["&;" common]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))))
+
+(exception: #export Invalid-Definition-Value)
+
+(host;import java.lang.Object
+ (toString [] String))
+
+(host;import java.lang.reflect.Field
+ (get [#? Object] #try #? Object))
+
+(host;import (java.lang.Class c)
+ (getField [String] #try Field))
+
+(def: #export (generate-def def-name valueT valueI metaI metaV)
+ (-> Text Type $;Inst $;Inst Code (Meta Unit))
+ (do meta;Monad<Meta>
+ [current-module meta;current-module-name
+ #let [def-ident [current-module def-name]
+ normal-name (&;normalize-name def-name)
+ bytecode-name (format current-module "/" normal-name)
+ class-name (format current-module "." normal-name)
+ bytecode ($d;class #$;V1.6
+ #$;Public $;finalC
+ bytecode-name
+ (list) ["java.lang.Object" (list)]
+ (list)
+ (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) &common;value-field &common;$Object)
+ ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list))
+ (|>. valueI
+ ($i;PUTSTATIC bytecode-name &common;value-field &common;$Object)
+ $i;RETURN))))]
+ _ (&common;store-class class-name bytecode)
+ class (&common;load-class class-name)
+ valueV (: (Meta Top)
+ (case (do e;Monad<Error>
+ [field (Class.getField [&common;value-field] class)]
+ (Field.get [#;None] field))
+ (#e;Success #;None)
+ (&;throw Invalid-Definition-Value (format current-module ";" def-name))
+
+ (#e;Success (#;Some valueV))
+ (wrap valueV)
+
+ (#e;Error error)
+ (&;fail error)))
+ _ (&module;define [current-module def-name] [valueT metaV valueV])
+ _ (if (meta;type? metaV)
+ (case (meta;declared-tags metaV)
+ #;Nil
+ (wrap [])
-(def: #export (compile-def def-name def-value def-meta)
- (-> Text Code Code (Meta Unit))
- (do Monad<Meta>
- [=def-value (&expr;compile def-value)
- =def-meta (&expr;compile def-meta)]
- (undefined)))
+ tags
+ (&module;declare-tags tags (meta;export? metaV) (:! Type valueV)))
+ (wrap []))
+ #let [_ (log! (format "DEF " current-module ";" def-name))]]
+ (&common;record-artifact bytecode-name bytecode)))
-(def: #export (compile-program prog-args prog-body)
- (-> Text Code (Meta Unit))
- (do Monad<Meta>
- [=prog-body (&scope;with-local [prog-args (type (List Text))]
- (&expr;compile prog-body))]
- (undefined)))
+(def: #export (generate-program program-args programI)
+ (-> Text $;Inst (Meta Unit))
+ (do meta;Monad<Meta>
+ []
+ (&;fail "'lux program' is unimplemented.")))