diff options
Diffstat (limited to 'new-luxc/source/luxc/generator')
| -rw-r--r-- | new-luxc/source/luxc/generator/common.jvm.lux | 56 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/eval.jvm.lux | 11 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/expr.jvm.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm.lux | 4 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/reference.jvm.lux | 12 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/runtime.jvm.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/statement.jvm.lux | 97 |
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."))) |