aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/generator')
-rw-r--r--new-luxc/source/luxc/generator/common.jvm.lux56
-rw-r--r--new-luxc/source/luxc/generator/eval.jvm.lux11
-rw-r--r--new-luxc/source/luxc/generator/expr.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/host/jvm.lux4
-rw-r--r--new-luxc/source/luxc/generator/reference.jvm.lux12
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux8
-rw-r--r--new-luxc/source/luxc/generator/statement.jvm.lux97
7 files changed, 150 insertions, 44 deletions
diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux
index 150e68e4f..4439ae51d 100644
--- a/new-luxc/source/luxc/generator/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/common.jvm.lux
@@ -4,8 +4,11 @@
[io]
(concurrency ["A" atom])
(data ["e" error]
- (coll ["d" dict]))
- [host])
+ [text]
+ text/format
+ (coll [dict #+ Dict]))
+ [host]
+ (world [blob #+ Blob]))
(luxc (generator (host ["$" jvm]
(jvm ["$t" type]
["$d" def]
@@ -23,16 +26,52 @@
(type: #export Bytecode (host;type (Array byte)))
-(type: #export Class-Store (A;Atom (d;Dict Text Bytecode)))
+(type: #export Class-Store (A;Atom (Dict Text Bytecode)))
+
+(type: #export Artifacts (Dict Text Blob))
(type: #export Host
{#loader ClassLoader
#store Class-Store
- #function-class (Maybe Text)})
+ #function-class (Maybe Text)
+ #artifacts Artifacts})
(exception: Unknown-Class)
(exception: Class-Already-Stored)
(exception: No-Function-Being-Compiled)
+(exception: Cannot-Overwrite-Artifact)
+
+(def: #export (with-artifacts action)
+ (All [a] (-> (Meta a) (Meta [Artifacts a])))
+ (;function [compiler]
+ (case (action (update@ #;host
+ (|>. (:! Host)
+ (set@ #artifacts (dict;new text;Hash<Text>))
+ (:! Void))
+ compiler))
+ (#e;Success [compiler' output])
+ (#e;Success [(update@ #;host
+ (|>. (:! Host)
+ (set@ #artifacts (|> (get@ #;host compiler) (:! Host) (get@ #artifacts)))
+ (:! Void))
+ compiler')
+ [(|> compiler' (get@ #;host) (:! Host) (get@ #artifacts))
+ output]])
+
+ (#e;Error error)
+ (#e;Error error))))
+
+(def: #export (record-artifact name content)
+ (-> Text Blob (Meta Unit))
+ (;function [compiler]
+ (if (|> compiler (get@ #;host) (:! Host) (get@ #artifacts) (dict;contains? name))
+ (ex;throw Cannot-Overwrite-Artifact name)
+ (#e;Success [(update@ #;host
+ (|>. (:! Host)
+ (update@ #artifacts (dict;put name content))
+ (:! Void))
+ compiler)
+ []]))))
(def: #export (store-class name byte-code)
(-> Text Bytecode (Meta Unit))
@@ -40,9 +79,9 @@
(let [store (|> (get@ #;host compiler)
(:! Host)
(get@ #store))]
- (if (d;contains? name (|> store A;get io;run))
+ (if (dict;contains? name (|> store A;get io;run))
(ex;throw Class-Already-Stored name)
- (#e;Success [compiler (io;run (A;update (d;put name byte-code) store))])
+ (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))])
))))
(def: #export (load-class name)
@@ -50,7 +89,7 @@
(;function [compiler]
(let [host (:! Host (get@ #;host compiler))
store (|> host (get@ #store) A;get io;run)]
- (if (d;contains? name store)
+ (if (dict;contains? name store)
(#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
(ex;throw Unknown-Class name)))))
@@ -87,3 +126,6 @@
(#e;Success [compiler function-class])))))
(def: #export bytecode-version Int Opcodes.V1_6)
+
+(def: #export value-field Text "_value")
+(def: #export $Object $;Type ($t;class "java.lang.Object" (list)))
diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux
index 20c02af4c..842199a47 100644
--- a/new-luxc/source/luxc/generator/eval.jvm.lux
+++ b/new-luxc/source/luxc/generator/eval.jvm.lux
@@ -56,9 +56,6 @@
(visitMethod [int String String String (Array String)] MethodVisitor)
(toByteArray [] (Array byte)))
-(def: eval-field Text "_value")
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
(def: #export (eval valueI)
(-> $;Inst (Meta Top))
(do Monad<Meta>
@@ -70,17 +67,17 @@
(host;null)
"java/lang/Object"
(host;null)]))
- ($d;field #$;Public $;staticF
- eval-field $Object)
+ ($d;field #$;Public ($_ $;++F $;finalF $;staticF)
+ &common;value-field &common;$Object)
($d;method #$;Public ($_ $;++M $;staticM $;strictM)
"<clinit>"
($t;method (list) #;None (list))
(|>. valueI
- ($i;PUTSTATIC class-name eval-field $Object)
+ ($i;PUTSTATIC class-name &common;value-field &common;$Object)
$i;RETURN)))
bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
_ (&common;store-class class-name bytecode)
class (&common;load-class class-name)]
(wrap (|> class
- (Class.getField [eval-field])
+ (Class.getField [&common;value-field])
(Field.get (host;null))))))
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index c7fdcf2af..116c29fb5 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -44,6 +44,9 @@
(&reference;generate-captured var)
(&reference;generate-variable var))
+ (#ls;Definition definition)
+ (&reference;generate-definition definition)
+
(#ls;Function arity env body)
(&function;generate-function generate env arity body)
@@ -54,7 +57,8 @@
(&procedure;generate-procedure generate name args)
_
- (meta;fail "Unrecognized synthesis.")))
+ (meta;fail "Unrecognized synthesis.")
+ ))
## (def: #export (eval type code)
## (-> Type Code (Meta Top))
diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux
index c985efc9a..24d4a9ea9 100644
--- a/new-luxc/source/luxc/generator/host/jvm.lux
+++ b/new-luxc/source/luxc/generator/host/jvm.lux
@@ -109,8 +109,8 @@
(` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right))
(-> (~ g!type) (~ g!type) (~ g!type))
(~ (code;record (list/map (function [tag]
- [tag (` (and (get@ (~ tag) (~ g!_left))
- (get@ (~ tag) (~ g!_right))))])
+ [tag (` (or (get@ (~ tag) (~ g!_left))
+ (get@ (~ tag) (~ g!_right))))])
g!tags+)))))
g!options+))))
diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux
index 063994bac..0e77b1819 100644
--- a/new-luxc/source/luxc/generator/reference.jvm.lux
+++ b/new-luxc/source/luxc/generator/reference.jvm.lux
@@ -3,15 +3,14 @@
(lux (control [monad #+ do])
(data text/format)
[meta "meta/" Monad<Meta>])
- (luxc (lang ["ls" synthesis])
+ (luxc ["&" base]
+ (lang ["ls" synthesis])
(generator [";G" common]
[";G" function]
(host ["$" jvm]
(jvm ["$t" type]
["$i" inst])))))
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
(def: #export (generate-captured variable)
(-> ls;Variable (Meta $;Inst))
(do meta;Monad<Meta>
@@ -19,8 +18,13 @@
(wrap (|>. ($i;ALOAD +0)
($i;GETFIELD function-class
(|> variable i.inc (i.* -1) int-to-nat functionG;captured)
- $Object)))))
+ commonG;$Object)))))
(def: #export (generate-variable variable)
(-> ls;Variable (Meta $;Inst))
(meta/wrap ($i;ALOAD (int-to-nat variable))))
+
+(def: #export (generate-definition [def-module def-name])
+ (-> Ident (Meta $;Inst))
+ (let [bytecode-name (format def-module "/" (&;normalize-name def-name))]
+ (meta/wrap ($i;GETSTATIC bytecode-name commonG;value-field commonG;$Object))))
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index 32e792638..66dd43019 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -504,8 +504,8 @@
(wrap bytecode)))
(def: #export generate
- (Meta Unit)
+ (Meta [&common;Bytecode &common;Bytecode])
(do Monad<Meta>
- [_ generate-runtime
- _ generate-function]
- (wrap [])))
+ [runtime-bc generate-runtime
+ function-bc generate-function]
+ (wrap [runtime-bc function-bc])))
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.")))