From 296d087530cb142efec1dea159770346bb43c3c0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Nov 2017 19:51:33 -0400 Subject: - Heavy refactoring. --- new-luxc/source/luxc/base.lux | 245 ------------- new-luxc/source/luxc/eval.lux | 18 - new-luxc/source/luxc/host.jvm.lux | 185 ---------- new-luxc/source/luxc/host/jvm.lux | 130 ------- new-luxc/source/luxc/host/jvm/def.lux | 288 ---------------- new-luxc/source/luxc/host/jvm/inst.lux | 383 --------------------- new-luxc/source/luxc/host/jvm/type.lux | 138 -------- new-luxc/source/luxc/host/macro.lux | 37 -- new-luxc/source/luxc/io.jvm.lux | 3 +- new-luxc/source/luxc/lang.lux | 245 +++++++++++++ new-luxc/source/luxc/lang/analysis/case.lux | 8 +- .../source/luxc/lang/analysis/case/coverage.lux | 2 +- new-luxc/source/luxc/lang/analysis/common.lux | 2 +- new-luxc/source/luxc/lang/analysis/expression.lux | 12 +- new-luxc/source/luxc/lang/analysis/function.lux | 8 +- new-luxc/source/luxc/lang/analysis/inference.lux | 2 +- new-luxc/source/luxc/lang/analysis/primitive.lux | 2 +- new-luxc/source/luxc/lang/analysis/procedure.lux | 2 +- .../source/luxc/lang/analysis/procedure/common.lux | 2 +- .../luxc/lang/analysis/procedure/host.jvm.lux | 6 +- new-luxc/source/luxc/lang/analysis/reference.lux | 8 +- new-luxc/source/luxc/lang/analysis/structure.lux | 12 +- new-luxc/source/luxc/lang/analysis/type.lux | 2 +- new-luxc/source/luxc/lang/eval.lux | 18 + new-luxc/source/luxc/lang/host.jvm.lux | 185 ++++++++++ new-luxc/source/luxc/lang/host/jvm.lux | 130 +++++++ new-luxc/source/luxc/lang/host/jvm/def.lux | 288 ++++++++++++++++ new-luxc/source/luxc/lang/host/jvm/inst.lux | 383 +++++++++++++++++++++ new-luxc/source/luxc/lang/host/jvm/type.lux | 138 ++++++++ new-luxc/source/luxc/lang/host/macro.lux | 37 ++ new-luxc/source/luxc/lang/module.lux | 173 ++++++++++ new-luxc/source/luxc/lang/scope.lux | 173 ++++++++++ new-luxc/source/luxc/lang/synthesis/expression.lux | 3 +- new-luxc/source/luxc/lang/translation.lux | 42 +-- new-luxc/source/luxc/lang/translation/case.jvm.lux | 12 +- .../source/luxc/lang/translation/common.jvm.lux | 10 +- new-luxc/source/luxc/lang/translation/eval.jvm.lux | 12 +- .../luxc/lang/translation/expression.jvm.lux | 10 +- .../source/luxc/lang/translation/function.jvm.lux | 14 +- new-luxc/source/luxc/lang/translation/loop.jvm.lux | 14 +- .../source/luxc/lang/translation/primitive.jvm.lux | 12 +- .../source/luxc/lang/translation/procedure.jvm.lux | 6 +- .../luxc/lang/translation/procedure/common.jvm.lux | 14 +- .../luxc/lang/translation/procedure/host.jvm.lux | 14 +- .../source/luxc/lang/translation/reference.jvm.lux | 12 +- .../source/luxc/lang/translation/runtime.jvm.lux | 14 +- .../source/luxc/lang/translation/statement.jvm.lux | 16 +- .../source/luxc/lang/translation/structure.jvm.lux | 14 +- new-luxc/source/luxc/module.lux | 173 ---------- new-luxc/source/luxc/scope.lux | 173 ---------- 50 files changed, 1912 insertions(+), 1918 deletions(-) delete mode 100644 new-luxc/source/luxc/base.lux delete mode 100644 new-luxc/source/luxc/eval.lux delete mode 100644 new-luxc/source/luxc/host.jvm.lux delete mode 100644 new-luxc/source/luxc/host/jvm.lux delete mode 100644 new-luxc/source/luxc/host/jvm/def.lux delete mode 100644 new-luxc/source/luxc/host/jvm/inst.lux delete mode 100644 new-luxc/source/luxc/host/jvm/type.lux delete mode 100644 new-luxc/source/luxc/host/macro.lux create mode 100644 new-luxc/source/luxc/lang.lux create mode 100644 new-luxc/source/luxc/lang/eval.lux create mode 100644 new-luxc/source/luxc/lang/host.jvm.lux create mode 100644 new-luxc/source/luxc/lang/host/jvm.lux create mode 100644 new-luxc/source/luxc/lang/host/jvm/def.lux create mode 100644 new-luxc/source/luxc/lang/host/jvm/inst.lux create mode 100644 new-luxc/source/luxc/lang/host/jvm/type.lux create mode 100644 new-luxc/source/luxc/lang/host/macro.lux create mode 100644 new-luxc/source/luxc/lang/module.lux create mode 100644 new-luxc/source/luxc/lang/scope.lux delete mode 100644 new-luxc/source/luxc/module.lux delete mode 100644 new-luxc/source/luxc/scope.lux (limited to 'new-luxc/source') diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux deleted file mode 100644 index 373c6b12b..000000000 --- a/new-luxc/source/luxc/base.lux +++ /dev/null @@ -1,245 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - [product] - ["e" error] - [text "text/" Eq] - text/format - (coll [list])) - [meta] - (meta (type ["tc" check]) - ["s" syntax #+ syntax:])) - (luxc (lang ["la" analysis]))) - -(type: #export Eval - (-> Type Code (Meta Top))) - -(type: #export Analyser - (-> Code (Meta la;Analysis))) - -(def: #export version Text "0.6.0") - -(def: #export (fail message) - (All [a] (-> Text (Meta a))) - (do meta;Monad - [[file line col] meta;cursor - #let [location (format file - "," (|> line nat-to-int %i) - "," (|> col nat-to-int %i))]] - (meta;fail (format message "\n\n" - "@ " location)))) - -(def: #export (throw exception message) - (All [a] (-> ex;Exception Text (Meta a))) - (fail (exception message))) - -(syntax: #export (assert exception message test) - (wrap (list (` (if (~ test) - (:: meta;Monad (~' wrap) []) - (;;throw (~ exception) (~ message))))))) - -(def: #export (with-expected-type expected action) - (All [a] (-> Type (Meta a) (Meta a))) - (function [compiler] - (case (action (set@ #;expected (#;Some expected) compiler)) - (#e;Success [compiler' output]) - (let [old-expected (get@ #;expected compiler)] - (#e;Success [(set@ #;expected old-expected compiler') - output])) - - (#e;Error error) - (#e;Error error)))) - -(def: #export (with-type-env action) - (All [a] (-> (tc;Check a) (Meta a))) - (function [compiler] - (case (action (get@ #;type-context compiler)) - (#e;Error error) - ((fail error) compiler) - - (#e;Success [context' output]) - (#e;Success [(set@ #;type-context context' compiler) - output])))) - -(def: #export (with-fresh-type-env action) - (All [a] (-> (Meta a) (Meta a))) - (function [compiler] - (let [old (get@ #;type-context compiler)] - (case (action (set@ #;type-context tc;fresh-context compiler)) - (#e;Success [compiler' output]) - (#e;Success [(set@ #;type-context old compiler') - output]) - - output - output)))) - -(def: #export (infer actualT) - (-> Type (Meta Unit)) - (do meta;Monad - [expectedT meta;expected-type] - (with-type-env - (tc;check expectedT actualT)))) - -(def: #export (pl-get key table) - (All [a] (-> Text (List [Text a]) (Maybe a))) - (case table - #;Nil - #;None - - (#;Cons [k' v'] table') - (if (text/= key k') - (#;Some v') - (pl-get key table')))) - -(def: #export (pl-contains? key table) - (All [a] (-> Text (List [Text a]) Bool)) - (case (pl-get key table) - (#;Some _) - true - - #;None - false)) - -(def: #export (pl-put key val table) - (All [a] (-> Text a (List [Text a]) (List [Text a]))) - (case table - #;Nil - (list [key val]) - - (#;Cons [k' v'] table') - (if (text/= key k') - (#;Cons [key val] - table') - (#;Cons [k' v'] - (pl-put key val table'))))) - -(def: #export (pl-update key f table) - (All [a] (-> Text (-> a a) (List [Text a]) (List [Text a]))) - (case table - #;Nil - #;Nil - - (#;Cons [k' v'] table') - (if (text/= key k') - (#;Cons [k' (f v')] table') - (#;Cons [k' v'] (pl-update key f table'))))) - -(def: #export (with-source-code source action) - (All [a] (-> Source (Meta a) (Meta a))) - (function [compiler] - (let [old-source (get@ #;source compiler)] - (case (action (set@ #;source source compiler)) - (#e;Error error) - (#e;Error error) - - (#e;Success [compiler' output]) - (#e;Success [(set@ #;source old-source compiler') - output]))))) - -(def: #export (with-stacked-errors handler action) - (All [a] (-> (-> [] Text) (Meta a) (Meta a))) - (function [compiler] - (case (action compiler) - (#e;Success [compiler' output]) - (#e;Success [compiler' output]) - - (#e;Error error) - (#e;Error (if (text/= "" error) - (handler []) - (format (handler []) "\n\n-----------------------------------------\n\n" error)))))) - -(def: fresh-bindings - (All [k v] (Bindings k v)) - {#;counter +0 - #;mappings (list)}) - -(def: fresh-scope - Scope - {#;name (list) - #;inner +0 - #;locals fresh-bindings - #;captured fresh-bindings}) - -(def: #export (with-scope action) - (All [a] (-> (Meta a) (Meta [Scope a]))) - (function [compiler] - (case (action (update@ #;scopes (|>. (#;Cons fresh-scope)) compiler)) - (#e;Success [compiler' output]) - (case (get@ #;scopes compiler') - #;Nil - (#e;Error "Impossible error: Drained scopes!") - - (#;Cons head tail) - (#e;Success [(set@ #;scopes tail compiler') - [head output]])) - - (#e;Error error) - (#e;Error error)))) - -(def: #export (with-current-module name action) - (All [a] (-> Text (Meta a) (Meta a))) - (function [compiler] - (case (action (set@ #;current-module (#;Some name) compiler)) - (#e;Success [compiler' output]) - (#e;Success [(set@ #;current-module - (get@ #;current-module compiler) - compiler') - output]) - - (#e;Error error) - (#e;Error error)))) - -(def: #export (with-cursor cursor action) - (All [a] (-> Cursor (Meta a) (Meta a))) - (if (text/= "" (product;left cursor)) - action - (function [compiler] - (let [old-cursor (get@ #;cursor compiler)] - (case (action (set@ #;cursor cursor compiler)) - (#e;Success [compiler' output]) - (#e;Success [(set@ #;cursor old-cursor compiler') - output]) - - (#e;Error error) - (#e;Error error)))))) - -(def: (normalize-char char) - (-> Nat Text) - (case char - (^ (char "*")) "_ASTER_" - (^ (char "+")) "_PLUS_" - (^ (char "-")) "_DASH_" - (^ (char "/")) "_SLASH_" - (^ (char "\\")) "_BSLASH_" - (^ (char "_")) "_UNDERS_" - (^ (char "%")) "_PERCENT_" - (^ (char "$")) "_DOLLAR_" - (^ (char "'")) "_QUOTE_" - (^ (char "`")) "_BQUOTE_" - (^ (char "@")) "_AT_" - (^ (char "^")) "_CARET_" - (^ (char "&")) "_AMPERS_" - (^ (char "=")) "_EQ_" - (^ (char "!")) "_BANG_" - (^ (char "?")) "_QM_" - (^ (char ":")) "_COLON_" - (^ (char ".")) "_PERIOD_" - (^ (char ",")) "_COMMA_" - (^ (char "<")) "_LT_" - (^ (char ">")) "_GT_" - (^ (char "~")) "_TILDE_" - (^ (char "|")) "_PIPE_" - _ - (text;from-code char))) - -(def: underflow Nat (n.dec +0)) - -(def: #export (normalize-name name) - (-> Text Text) - (loop [idx (n.dec (text;size name)) - output ""] - (if (n.= underflow idx) - output - (recur (n.dec idx) (format (|> (text;nth idx name) maybe;assume normalize-char) output))))) diff --git a/new-luxc/source/luxc/eval.lux b/new-luxc/source/luxc/eval.lux deleted file mode 100644 index 6431b59d6..000000000 --- a/new-luxc/source/luxc/eval.lux +++ /dev/null @@ -1,18 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - [meta]) - (luxc (lang (analysis [";A" expression]) - (synthesis [";S" expression]) - (translation [";T" expression] - [";T" eval]))) - [../base]) - -(def: #export (eval type exprC) - ../base;Eval - (do meta;Monad - [exprA (../base;with-expected-type type - (expressionA;analyser eval exprC)) - #let [exprS (expressionS;synthesize exprA)] - exprI (expressionT;translate exprS)] - (evalT;eval exprI))) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux deleted file mode 100644 index e8dc4e17a..000000000 --- a/new-luxc/source/luxc/host.jvm.lux +++ /dev/null @@ -1,185 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - pipe) - (concurrency ["A" atom]) - (data ["e" error] - [text] - text/format - (coll [dict] - [array])) - [meta #+ Monad] - [host #+ do-to object] - [io]) - (luxc ["&" base] - (lang [";L" variable #+ Register] - (translation [";T" common])))) - -(host;import org.objectweb.asm.Label) - -(host;import java.lang.reflect.AccessibleObject - (setAccessible [boolean] void)) - -(host;import java.lang.reflect.Method - (invoke [Object (Array Object)] #try Object)) - -(host;import (java.lang.Class a) - (getDeclaredMethod [String (Array (Class Object))] #try Method)) - -(host;import java.lang.Object - (getClass [] (Class Object))) - -(host;import java.lang.Integer - (#static TYPE (Class Integer))) - -(host;import java.lang.ClassLoader) - -(def: ClassLoader::defineClass - Method - (case (Class.getDeclaredMethod ["defineClass" - (|> (host;array (Class Object) +4) - (host;array-write +0 (:! (Class Object) (host;class-for String))) - (host;array-write +1 (Object.getClass [] (host;array byte +0))) - (host;array-write +2 (:! (Class Object) Integer.TYPE)) - (host;array-write +3 (:! (Class Object) Integer.TYPE)))] - (host;class-for java.lang.ClassLoader)) - (#e;Success method) - (do-to method - (AccessibleObject.setAccessible [true])) - - (#e;Error error) - (error! error))) - -(def: (define-class class-name byte-code loader) - (-> Text commonT;Bytecode ClassLoader (e;Error Object)) - (Method.invoke [loader - (array;from-list (list (:! Object class-name) - (:! Object byte-code) - (:! Object (host;l2i 0)) - (:! Object (host;l2i (nat-to-int (host;array-length byte-code))))))] - ClassLoader::defineClass)) - -(def: (fetch-byte-code class-name store) - (-> Text commonT;Class-Store (Maybe commonT;Bytecode)) - (|> store A;get io;run (dict;get class-name))) - -(def: (memory-class-loader store) - (-> commonT;Class-Store ClassLoader) - (object ClassLoader [] - [] - (ClassLoader (findClass [class-name String]) Class - (case (fetch-byte-code class-name store) - (#;Some bytecode) - (case (define-class class-name bytecode (:! ClassLoader _jvm_this)) - (#e;Success class) - (:!! class) - - (#e;Error error) - (error! (format "Class definition error: " class-name "\n" - error))) - - #;None - (error! (format "Class not found: " class-name)))))) - -(def: #export init-host - (io;IO commonT;Host) - (io;io (let [store (: commonT;Class-Store - (A;atom (dict;new text;Hash)))] - {#commonT;loader (memory-class-loader store) - #commonT;store store - #commonT;artifacts (dict;new text;Hash) - #commonT;context ["" +0] - #commonT;anchor #;None}))) - -(def: #export (with-anchor anchor expr) - (All [a] (-> [Label Register] (Meta a) (Meta a))) - (;function [compiler] - (let [old (:! commonT;Host (get@ #;host compiler))] - (case (expr (set@ #;host - (:! Void (set@ #commonT;anchor (#;Some anchor) old)) - compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! commonT;Host) - (set@ #commonT;anchor (get@ #commonT;anchor old)) - (:! Void)) - compiler') - output]) - - (#e;Error error) - (#e;Error error))))) - -(exception: #export No-Anchor) - -(def: #export anchor - (Meta [Label Register]) - (;function [compiler] - (case (|> compiler (get@ #;host) (:! commonT;Host) (get@ #commonT;anchor)) - (#;Some anchor) - (#e;Success [compiler - anchor]) - - #;None - ((&;throw No-Anchor "") compiler)))) - -(def: #export (with-context name expr) - (All [a] (-> Text (Meta a) (Meta a))) - (;function [compiler] - (let [old (:! commonT;Host (get@ #;host compiler))] - (case (expr (set@ #;host - (:! Void (set@ #commonT;context [(&;normalize-name name) +0] old)) - compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! commonT;Host) - (set@ #commonT;context (get@ #commonT;context old)) - (:! Void)) - compiler') - output]) - - (#e;Error error) - (#e;Error error))))) - -(def: #export (with-sub-context expr) - (All [a] (-> (Meta a) (Meta [Text a]))) - (;function [compiler] - (let [old (:! commonT;Host (get@ #;host compiler)) - [old-name old-sub] (get@ #commonT;context old) - new-name (format old-name "$" (%i (nat-to-int old-sub)))] - (case (expr (set@ #;host - (:! Void (set@ #commonT;context [new-name +0] old)) - compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! commonT;Host) - (set@ #commonT;context [old-name (n.inc old-sub)]) - (:! Void)) - compiler') - [new-name output]]) - - (#e;Error error) - (#e;Error error))))) - -(def: #export context - (Meta Text) - (;function [compiler] - (#e;Success [compiler - (|> (get@ #;host compiler) - (:! commonT;Host) - (get@ #commonT;context) - (let> [name sub] - name))]))) - -(def: #export class-loader - (Meta ClassLoader) - (function [compiler] - (#e;Success [compiler - (|> compiler - (get@ #;host) - (:! commonT;Host) - (get@ #commonT;loader))]))) - -(def: #export runtime-class Text "LuxRuntime") -(def: #export function-class Text "LuxFunction") -(def: #export unit Text "\u0000") diff --git a/new-luxc/source/luxc/host/jvm.lux b/new-luxc/source/luxc/host/jvm.lux deleted file mode 100644 index 24d4a9ea9..000000000 --- a/new-luxc/source/luxc/host/jvm.lux +++ /dev/null @@ -1,130 +0,0 @@ -(;module: - [lux #- Type Def] - (lux (control monad - ["p" parser]) - (data (coll [list "list/" Functor])) - [meta] - (meta [code] - ["s" syntax #+ syntax:]) - [host])) - -## [Host] -(host;import org.objectweb.asm.MethodVisitor) - -(host;import org.objectweb.asm.ClassWriter) - -(host;import #long org.objectweb.asm.Label - (new [])) - -## [Type] -(type: #export Bound - #Upper - #Lower) - -(type: #export Primitive - #Boolean - #Byte - #Short - #Int - #Long - #Float - #Double - #Char) - -(type: #export #rec Generic - (#Var Text) - (#Wildcard (Maybe [Bound Generic])) - (#Class Text (List Generic))) - -(type: #export Class - [Text (List Generic)]) - -(type: #export Parameter - [Text Class (List Class)]) - -(type: #export #rec Type - (#Primitive Primitive) - (#Generic Generic) - (#Array Type)) - -(type: #export Method - {#args (List Type) - #return (Maybe Type) - #exceptions (List Generic)}) - -(type: #export Def - (-> ClassWriter ClassWriter)) - -(type: #export Inst - (-> MethodVisitor MethodVisitor)) - -(type: #export Label - org.objectweb.asm.Label) - -(type: #export Register Nat) - -(type: #export Visibility - #Public - #Protected - #Private - #Default) - -(type: #export Version - #V1.1 - #V1.2 - #V1.3 - #V1.4 - #V1.5 - #V1.6 - #V1.7 - #V1.8) - -## [Values] -(syntax: (config: [type s;local-symbol] - [none s;local-symbol] - [++ s;local-symbol] - [options (s;tuple (p;many s;local-symbol))]) - (let [g!type (code;local-symbol type) - g!none (code;local-symbol none) - g!tags+ (list/map code;local-tag options) - g!_left (code;local-symbol "_left") - g!_right (code;local-symbol "_right") - g!options+ (list/map (function [option] - (` (def: (~' #export) (~ (code;local-symbol option)) - (~ g!type) - (|> (~ g!none) - (set@ (~ (code;local-tag option)) true))))) - options)] - (wrap (list& (` (type: (~' #export) (~ g!type) - (~ (code;record (list/map (function [tag] - [tag (` ;Bool)]) - g!tags+))))) - - (` (def: (~' #export) (~ g!none) - (~ g!type) - (~ (code;record (list/map (function [tag] - [tag (` false)]) - g!tags+))))) - - (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right)) - (-> (~ g!type) (~ g!type) (~ g!type)) - (~ (code;record (list/map (function [tag] - [tag (` (or (get@ (~ tag) (~ g!_left)) - (get@ (~ tag) (~ g!_right))))]) - g!tags+))))) - - g!options+)))) - -## Configs -(config: Class-Config noneC ++C [finalC]) -(config: Method-Config noneM ++M [finalM staticM synchronizedM strictM]) -(config: Field-Config noneF ++F [finalF staticF transientF volatileF]) - -## Labels -(def: #export new-label - (-> Unit Label) - org.objectweb.asm.Label.new) - -(def: #export (simple-class name) - (-> Text Class) - [name (list)]) diff --git a/new-luxc/source/luxc/host/jvm/def.lux b/new-luxc/source/luxc/host/jvm/def.lux deleted file mode 100644 index 60009fb5c..000000000 --- a/new-luxc/source/luxc/host/jvm/def.lux +++ /dev/null @@ -1,288 +0,0 @@ -(;module: - lux - (lux (data [text] - text/format - [product] - (coll ["a" array] - [list "list/" Functor])) - [host #+ do-to]) - ["$" ..] - (.. ["$t" type])) - -## [Host] -(host;import #long java.lang.Object) -(host;import #long java.lang.String) - -(host;import org.objectweb.asm.Opcodes - (#static ACC_PUBLIC int) - (#static ACC_PROTECTED int) - (#static ACC_PRIVATE int) - - (#static ACC_TRANSIENT int) - (#static ACC_VOLATILE int) - - (#static ACC_ABSTRACT int) - (#static ACC_FINAL int) - (#static ACC_STATIC int) - (#static ACC_SYNCHRONIZED int) - (#static ACC_STRICT int) - - (#static ACC_SUPER int) - (#static ACC_INTERFACE int) - - (#static V1_1 int) - (#static V1_2 int) - (#static V1_3 int) - (#static V1_4 int) - (#static V1_5 int) - (#static V1_6 int) - (#static V1_7 int) - (#static V1_8 int) - ) - -(host;import org.objectweb.asm.FieldVisitor - (visitEnd [] void)) - -(host;import org.objectweb.asm.MethodVisitor - (visitCode [] void) - (visitMaxs [int int] void) - (visitEnd [] void)) - -(host;import org.objectweb.asm.ClassWriter - (#static COMPUTE_MAXS int) - (#static COMPUTE_FRAMES int) - (new [int]) - (visit [int int String String String (Array String)] void) - (visitEnd [] void) - (visitField [int String String String Object] FieldVisitor) - (visitMethod [int String String String (Array String)] MethodVisitor) - (toByteArray [] (Array byte))) - -## [Defs] -(def: (string-array values) - (-> (List Text) (Array Text)) - (let [output (host;array String (list;size values))] - (exec (list/map (function [[idx value]] - (host;array-write idx value output)) - (list;enumerate values)) - output))) - -(def: exceptions-array - (-> $;Method (Array Text)) - (|>. (get@ #$;exceptions) - (list/map (|>. #$;Generic $t;descriptor)) - string-array)) - -(def: (version-flag version) - (-> $;Version Int) - (case version - #$;V1.1 Opcodes.V1_1 - #$;V1.2 Opcodes.V1_2 - #$;V1.3 Opcodes.V1_3 - #$;V1.4 Opcodes.V1_4 - #$;V1.5 Opcodes.V1_5 - #$;V1.6 Opcodes.V1_6 - #$;V1.7 Opcodes.V1_7 - #$;V1.8 Opcodes.V1_8)) - -(def: (visibility-flag visibility) - (-> $;Visibility Int) - (case visibility - #$;Public Opcodes.ACC_PUBLIC - #$;Protected Opcodes.ACC_PROTECTED - #$;Private Opcodes.ACC_PRIVATE - #$;Default 0)) - -(def: (class-flags config) - (-> $;Class-Config Int) - ($_ i.+ - (if (get@ #$;finalC config) Opcodes.ACC_FINAL 0))) - -(def: (method-flags config) - (-> $;Method-Config Int) - ($_ i.+ - (if (get@ #$;staticM config) Opcodes.ACC_STATIC 0) - (if (get@ #$;finalM config) Opcodes.ACC_FINAL 0) - (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0) - (if (get@ #$;strictM config) Opcodes.ACC_STRICT 0))) - -(def: (field-flags config) - (-> $;Field-Config Int) - ($_ i.+ - (if (get@ #$;staticF config) Opcodes.ACC_STATIC 0) - (if (get@ #$;finalF config) Opcodes.ACC_FINAL 0) - (if (get@ #$;transientF config) Opcodes.ACC_TRANSIENT 0) - (if (get@ #$;volatileF config) Opcodes.ACC_VOLATILE 0))) - -(def: class-to-type - (-> $;Class $;Type) - (|>. #$;Class #$;Generic)) - -(def: param-signature - (-> $;Class Text) - (|>. class-to-type $t;signature (format ":"))) - -(def: (formal-param [name super interfaces]) - (-> $;Parameter Text) - (format name - (param-signature super) - (|> interfaces - (list/map param-signature) - (text;join-with "")))) - -(def: (parameters-signature parameters super interfaces) - (-> (List $;Parameter) $;Class (List $;Class) - Text) - (let [formal-params (if (list;empty? parameters) - "" - (format "<" - (|> parameters - (list/map formal-param) - (text;join-with "")) - ">"))] - (format formal-params - (|> super class-to-type $t;signature) - (|> interfaces - (list/map (|>. class-to-type $t;signature)) - (text;join-with ""))))) - -(def: class-computes - Int - ($_ i.+ - ClassWriter.COMPUTE_MAXS - ## ClassWriter.COMPUTE_FRAMES - )) - -(do-template [ ] - [(def: #export ( version visibility config name parameters super interfaces - definitions) - (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def - (host;type (Array byte))) - (let [writer (|> (do-to (ClassWriter.new class-computes) - (ClassWriter.visit [(version-flag version) - ($_ i.+ - Opcodes.ACC_SUPER - - (visibility-flag visibility) - (class-flags config)) - ($t;binary-name name) - (parameters-signature parameters super interfaces) - (|> super product;left $t;binary-name) - (|> interfaces - (list/map (|>. product;left $t;binary-name)) - string-array)])) - definitions) - _ (ClassWriter.visitEnd [] writer)] - (ClassWriter.toByteArray [] writer)))] - - [class 0] - [abstract Opcodes.ACC_ABSTRACT] - ) - -(def: $Object $;Class ["java.lang.Object" (list)]) - -(def: #export (interface version visibility config name parameters interfaces - definitions) - (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def - (host;type (Array byte))) - (let [writer (|> (do-to (ClassWriter.new class-computes) - (ClassWriter.visit [(version-flag version) - ($_ i.+ - Opcodes.ACC_SUPER - Opcodes.ACC_INTERFACE - (visibility-flag visibility) - (class-flags config)) - ($t;binary-name name) - (parameters-signature parameters $Object interfaces) - (|> $Object product;left $t;binary-name) - (|> interfaces - (list/map (|>. product;left $t;binary-name)) - string-array)])) - definitions) - _ (ClassWriter.visitEnd [] writer)] - (ClassWriter.toByteArray [] writer))) - -(def: #export (method visibility config name type then) - (-> $;Visibility $;Method-Config Text $;Method $;Inst - $;Def) - (function [writer] - (let [=method (ClassWriter.visitMethod [($_ i.+ - (visibility-flag visibility) - (method-flags config)) - ($t;binary-name name) - ($t;method-descriptor type) - ($t;method-signature type) - (exceptions-array type)] - writer) - _ (MethodVisitor.visitCode [] =method) - _ (then =method) - _ (MethodVisitor.visitMaxs [0 0] =method) - _ (MethodVisitor.visitEnd [] =method)] - writer))) - -(def: #export (abstract-method visibility config name type) - (-> $;Visibility $;Method-Config Text $;Method - $;Def) - (function [writer] - (let [=method (ClassWriter.visitMethod [($_ i.+ - (visibility-flag visibility) - (method-flags config) - Opcodes.ACC_ABSTRACT) - ($t;binary-name name) - ($t;method-descriptor type) - ($t;method-signature type) - (exceptions-array type)] - writer) - _ (MethodVisitor.visitEnd [] =method)] - writer))) - -(def: #export (field visibility config name type) - (-> $;Visibility $;Field-Config Text $;Type $;Def) - (function [writer] - (let [=field (do-to (ClassWriter.visitField [($_ i.+ - (visibility-flag visibility) - (field-flags config)) - ($t;binary-name name) - ($t;descriptor type) - ($t;signature type) - (host;null)] writer) - (FieldVisitor.visitEnd []))] - writer))) - -(do-template [ ] - [(def: #export ( visibility config name value) - (-> $;Visibility $;Field-Config Text $;Def) - (function [writer] - (let [=field (do-to (ClassWriter.visitField [($_ i.+ - (visibility-flag visibility) - (field-flags config)) - ($t;binary-name name) - ($t;descriptor ) - ($t;signature ) - ( value)] - writer) - (FieldVisitor.visitEnd []))] - writer)))] - - [boolean-field Bool $t;boolean id] - [byte-field Int $t;byte host;l2b] - [short-field Int $t;short host;l2s] - [int-field Int $t;int host;l2i] - [long-field Int $t;long id] - [float-field Frac $t;float host;d2f] - [double-field Frac $t;double id] - [char-field Nat $t;char (|>. nat-to-int host;l2i host;i2c)] - [string-field Text ($t;class "java.lang.String" (list)) id] - ) - -(def: #export (fuse defs) - (-> (List $;Def) $;Def) - (case defs - #;Nil - id - - (#;Cons singleton #;Nil) - singleton - - (#;Cons head tail) - (. (fuse tail) head))) diff --git a/new-luxc/source/luxc/host/jvm/inst.lux b/new-luxc/source/luxc/host/jvm/inst.lux deleted file mode 100644 index 37ab75020..000000000 --- a/new-luxc/source/luxc/host/jvm/inst.lux +++ /dev/null @@ -1,383 +0,0 @@ -(;module: - [lux #- char] - (lux (control monad - ["p" parser]) - (data [maybe] - ["e" error] - text/format - (coll [list "L/" Functor])) - [host #+ do-to] - [meta] - (meta [code] - ["s" syntax #+ syntax:])) - ["$" ..] - (.. ["$t" type])) - -## [Host] -(host;import #long java.lang.Object) -(host;import #long java.lang.String) - -(syntax: (declare [codes (p;many s;local-symbol)]) - (|> codes - (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int))))) - wrap)) - -(`` (host;import org.objectweb.asm.Opcodes - (#static NOP int) - - ## Conversion - (~~ (declare D2F D2I D2L - F2D F2I F2L - I2B I2C I2D I2F I2L I2S - L2D L2F L2I)) - - ## Primitive - (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE - T_BYTE T_SHORT T_INT T_LONG)) - - ## Class - (~~ (declare CHECKCAST NEW INSTANCEOF)) - - ## Stack - (~~ (declare DUP DUP_X1 DUP_X2 - DUP2 DUP2_X1 DUP2_X2 - POP POP2 - SWAP)) - - ## Jump - (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL - IFEQ IFNE IFLT IFLE IFGT IFGE - GOTO)) - - (#static ACONST_NULL int) - - ## Var - (~~ (declare ILOAD LLOAD DLOAD ALOAD - ISTORE LSTORE ASTORE)) - - ## Arithmetic - (~~ (declare IADD ISUB IMUL IDIV IREM - LADD LSUB LMUL LDIV LREM LCMP - FADD FSUB FMUL FDIV FREM FCMPG FCMPL - DADD DSUB DMUL DDIV DREM DCMPG DCMPL)) - - ## Bit-wise - (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR - LAND LOR LXOR LSHL LSHR LUSHR)) - - ## Array - (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY - AALOAD AASTORE - BALOAD BASTORE - SALOAD SASTORE - IALOAD IASTORE - LALOAD LASTORE - FALOAD FASTORE - DALOAD DASTORE - CALOAD CASTORE)) - - ## Member - (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD - INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE)) - - (#static ATHROW int) - - ## Concurrency - (~~ (declare MONITORENTER MONITOREXIT)) - - ## Return - (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN)) - )) - -(host;import org.objectweb.asm.FieldVisitor - (visitEnd [] void)) - -(host;import org.objectweb.asm.Label - (new [])) - -(host;import org.objectweb.asm.MethodVisitor - (visitCode [] void) - (visitMaxs [int int] void) - (visitEnd [] void) - (visitInsn [int] void) - (visitLdcInsn [Object] void) - (visitFieldInsn [int String String String] void) - (visitTypeInsn [int String] void) - (visitVarInsn [int int] void) - (visitIntInsn [int int] void) - (visitMethodInsn [int String String String boolean] void) - (visitLabel [Label] void) - (visitJumpInsn [int Label] void) - (visitTryCatchBlock [Label Label Label String] void) - (visitTableSwitchInsn [int int Label (Array Label)] void) - ) - -## [Insts] -(def: #export make-label - (Meta Label) - (function [compiler] - (#e;Success [compiler (Label.new [])]))) - -(def: #export (with-label action) - (-> (-> Label $;Inst) $;Inst) - (action (Label.new []))) - -(do-template [ ] - [(def: #export ( value) - (-> $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitLdcInsn [( value)]))))] - - [boolean Bool id] - [int Int host;l2i] - [long Int id] - [double Frac id] - [char Nat (|>. nat-to-int host;l2i host;i2c)] - [string Text id] - ) - -(syntax: (prefix [base s;local-symbol]) - (wrap (list (code;local-symbol (format "Opcodes." base))))) - -(def: #export NULL - $;Inst - (function [visitor] - (do-to visitor - (MethodVisitor.visitInsn [(prefix ACONST_NULL)])))) - -(do-template [] - [(def: #export - $;Inst - (function [visitor] - (do-to visitor - (MethodVisitor.visitInsn [(prefix )]))))] - - [NOP] - - ## Stack - [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2] - [POP] [POP2] - [SWAP] - - ## Conversions - [D2F] [D2I] [D2L] - [F2D] [F2I] [F2L] - [I2B] [I2C] [I2D] [I2F] [I2L] [I2S] - [L2D] [L2F] [L2I] - - ## Integer arithmetic - [IADD] [ISUB] [IMUL] [IDIV] [IREM] - - ## Integer bitwise - [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR] - - ## Long arithmetic - [LADD] [LSUB] [LMUL] [LDIV] [LREM] - [LCMP] - - ## Long bitwise - [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR] - - ## Float arithmetic - [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FCMPG] [FCMPL] - - ## Double arithmetic - [DADD] [DSUB] [DMUL] [DDIV] [DREM] - [DCMPG] [DCMPL] - - ## Array - [ARRAYLENGTH] - [AALOAD] [AASTORE] - [BALOAD] [BASTORE] - [SALOAD] [SASTORE] - [IALOAD] [IASTORE] - [LALOAD] [LASTORE] - [FALOAD] [FASTORE] - [DALOAD] [DASTORE] - [CALOAD] [CASTORE] - - ## Exceptions - [ATHROW] - - ## Concurrency - [MONITORENTER] [MONITOREXIT] - - ## Return - [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN] - ) - -(do-template [] - [(def: #export ( register) - (-> Nat $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitVarInsn [(prefix ) (nat-to-int register)]))))] - - [ILOAD] [LLOAD] [DLOAD] [ALOAD] - [ISTORE] [LSTORE] [ASTORE] - ) - -(do-template [ ] - [(def: #export ( class field type) - (-> Text Text $;Type $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitFieldInsn [ ($t;binary-name class) field ($t;descriptor type)]))))] - - [GETSTATIC Opcodes.GETSTATIC] - [PUTSTATIC Opcodes.PUTSTATIC] - - [PUTFIELD Opcodes.PUTFIELD] - [GETFIELD Opcodes.GETFIELD] - ) - -(do-template [ ] - [(def: #export ( class) - (-> Text $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitTypeInsn [ ($t;binary-name class)]))))] - - [CHECKCAST Opcodes.CHECKCAST] - [NEW Opcodes.NEW] - [INSTANCEOF Opcodes.INSTANCEOF] - [ANEWARRAY Opcodes.ANEWARRAY] - ) - -(def: #export (NEWARRAY type) - (-> $;Primitive $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type - #$;Boolean Opcodes.T_BOOLEAN - #$;Byte Opcodes.T_BYTE - #$;Short Opcodes.T_SHORT - #$;Int Opcodes.T_INT - #$;Long Opcodes.T_LONG - #$;Float Opcodes.T_FLOAT - #$;Double Opcodes.T_DOUBLE - #$;Char Opcodes.T_CHAR)])))) - -(do-template [ ] - [(def: #export ( class method-name method-signature interface?) - (-> Text Text $;Method Bool $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitMethodInsn [ ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))] - - [INVOKESTATIC Opcodes.INVOKESTATIC] - [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL] - [INVOKESPECIAL Opcodes.INVOKESPECIAL] - [INVOKEINTERFACE Opcodes.INVOKEINTERFACE] - ) - -(do-template [] - [(def: #export ( @where) - (-> $;Label $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitJumpInsn [(prefix ) @where]))))] - - [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] [IF_ACMPEQ] [IFNULL] - [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE] - [GOTO] - ) - -(def: #export (TABLESWITCH min max default labels) - (-> Int Int $;Label (List $;Label) $;Inst) - (function [visitor] - (let [num-labels (list;size labels) - labels-array (host;array Label num-labels) - _ (loop [idx +0] - (if (n.< num-labels idx) - (exec (host;array-write idx - (maybe;assume (list;nth idx labels)) - labels-array) - (recur (n.inc idx))) - []))] - (do-to visitor - (MethodVisitor.visitTableSwitchInsn [min max default labels-array]))))) - -(def: #export (try @from @to @handler exception) - (-> $;Label $;Label $;Label Text $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitTryCatchBlock [@from @to @handler ($t;binary-name exception)])))) - -(def: #export (label @label) - (-> $;Label $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitLabel [@label])))) - -(def: #export (array type) - (-> $;Type $;Inst) - (case type - (#$;Primitive prim) - (NEWARRAY prim) - - (#$;Generic generic) - (let [elem-class (case generic - (#$;Class class params) - ($t;binary-name class) - - _ - ($t;binary-name "java.lang.Object"))] - (ANEWARRAY elem-class)) - - _ - (ANEWARRAY ($t;descriptor type)))) - -(def: (primitive-wrapper type) - (-> $;Primitive Text) - (case type - #$;Boolean "java.lang.Boolean" - #$;Byte "java.lang.Byte" - #$;Short "java.lang.Short" - #$;Int "java.lang.Integer" - #$;Long "java.lang.Long" - #$;Float "java.lang.Float" - #$;Double "java.lang.Double" - #$;Char "java.lang.Character")) - -(def: (primitive-unwrap type) - (-> $;Primitive Text) - (case type - #$;Boolean "booleanValue" - #$;Byte "byteValue" - #$;Short "shortValue" - #$;Int "intValue" - #$;Long "longValue" - #$;Float "floatValue" - #$;Double "doubleValue" - #$;Char "charValue")) - -(def: #export (wrap type) - (-> $;Primitive $;Inst) - (let [class (primitive-wrapper type)] - (|>. (INVOKESTATIC class "valueOf" - ($t;method (list (#$;Primitive type)) - (#;Some ($t;class class (list))) - (list)) - false)))) - -(def: #export (unwrap type) - (-> $;Primitive $;Inst) - (let [class (primitive-wrapper type)] - (|>. (CHECKCAST class) - (INVOKEVIRTUAL class (primitive-unwrap type) - ($t;method (list) (#;Some (#$;Primitive type)) (list)) - false)))) - -(def: #export (fuse insts) - (-> (List $;Inst) $;Inst) - (case insts - #;Nil - id - - (#;Cons singleton #;Nil) - singleton - - (#;Cons head tail) - (. (fuse tail) head))) diff --git a/new-luxc/source/luxc/host/jvm/type.lux b/new-luxc/source/luxc/host/jvm/type.lux deleted file mode 100644 index 3825d443b..000000000 --- a/new-luxc/source/luxc/host/jvm/type.lux +++ /dev/null @@ -1,138 +0,0 @@ -(;module: - [lux #- char] - (lux (data [text] - text/format - (coll [list "L/" Functor]))) - ["$" ..]) - -## Types -(do-template [ ] - [(def: #export $;Type (#$;Primitive ))] - - [boolean #$;Boolean] - [byte #$;Byte] - [short #$;Short] - [int #$;Int] - [long #$;Long] - [float #$;Float] - [double #$;Double] - [char #$;Char] - ) - -(def: #export (class name params) - (-> Text (List $;Generic) $;Type) - (#$;Generic (#$;Class name params))) - -(def: #export (var name) - (-> Text $;Type) - (#$;Generic (#$;Var name))) - -(def: #export (wildcard bound) - (-> (Maybe [$;Bound $;Generic]) $;Type) - (#$;Generic (#$;Wildcard bound))) - -(def: #export (array depth elemT) - (-> Nat $;Type $;Type) - (case depth - +0 elemT - _ (#$;Array (array (n.dec depth) elemT)))) - -(def: #export (binary-name class) - (-> Text Text) - (text;replace-all "." "/" class)) - -(def: #export (descriptor type) - (-> $;Type Text) - (case type - (#$;Primitive prim) - (case prim - #$;Boolean "Z" - #$;Byte "B" - #$;Short "S" - #$;Int "I" - #$;Long "J" - #$;Float "F" - #$;Double "D" - #$;Char "C") - - (#$;Array sub) - (format "[" (descriptor sub)) - - (#$;Generic generic) - (case generic - (#$;Class class params) - (format "L" (binary-name class) ";") - - (^or (#$;Var name) (#$;Wildcard ?bound)) - (descriptor (#$;Generic (#$;Class "java.lang.Object" (list))))) - )) - -(def: #export (signature type) - (-> $;Type Text) - (case type - (#$;Primitive prim) - (case prim - #$;Boolean "Z" - #$;Byte "B" - #$;Short "S" - #$;Int "I" - #$;Long "J" - #$;Float "F" - #$;Double "D" - #$;Char "C") - - (#$;Array sub) - (format "[" (signature sub)) - - (#$;Generic generic) - (case generic - (#$;Class class params) - (let [=params (if (list;empty? params) - "" - (format "<" - (|> params - (L/map (|>. #$;Generic signature)) - (text;join-with "")) - ">"))] - (format "L" (binary-name class) =params ";")) - - (#$;Var name) - (format "T" name ";") - - (#$;Wildcard #;None) - "*" - - (^template [ ] - (#$;Wildcard (#;Some [ bound])) - (format (signature (#$;Generic bound)))) - ([#$;Upper "+"] - [#$;Lower "-"])) - )) - -## Methods -(def: #export (method args return exceptions) - (-> (List $;Type) (Maybe $;Type) (List $;Generic) $;Method) - {#$;args args #$;return return #$;exceptions exceptions}) - -(def: #export (method-descriptor method) - (-> $;Method Text) - (format "(" (text;join-with "" (L/map descriptor (get@ #$;args method))) ")" - (case (get@ #$;return method) - #;None - "V" - - (#;Some return) - (descriptor return)))) - -(def: #export (method-signature method) - (-> $;Method Text) - (format "(" (|> (get@ #$;args method) (L/map signature) (text;join-with "")) ")" - (case (get@ #$;return method) - #;None - "V" - - (#;Some return) - (signature return)) - (|> (get@ #$;exceptions method) - (L/map (|>. #$;Generic signature (format "^"))) - (text;join-with "")))) diff --git a/new-luxc/source/luxc/host/macro.lux b/new-luxc/source/luxc/host/macro.lux deleted file mode 100644 index 1a3152222..000000000 --- a/new-luxc/source/luxc/host/macro.lux +++ /dev/null @@ -1,37 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (data ["e" error]) - [meta] - [host]) - (luxc [";L" host] - (lang (translation [";T" common])))) - -(for {"JVM" (as-is (host;import java.lang.reflect.Method - (invoke [Object (Array Object)] #try Object)) - (host;import (java.lang.Class c) - (getMethod [String (Array (Class Object))] #try Method)) - (host;import java.lang.Object - (getClass [] (Class Object)) - (toString [] String)) - (def: _object-class (Class Object) (host;class-for Object)) - (def: _apply-args - (Array (Class Object)) - (|> (host;array (Class Object) +2) - (host;array-write +0 _object-class) - (host;array-write +1 _object-class))) - (def: #export (expand macro inputs) - (-> Macro (List Code) (Meta (List Code))) - (do meta;Monad - [class (commonT;load-class hostL;function-class)] - (function [compiler] - (do e;Monad - [apply-method (Class.getMethod ["apply" _apply-args] class) - output (Method.invoke [(:! Object macro) - (|> (host;array Object +2) - (host;array-write +0 (:! Object inputs)) - (host;array-write +1 (:! Object compiler)))] - apply-method)] - (:! (e;Error [Compiler (List Code)]) - output)))))) - }) diff --git a/new-luxc/source/luxc/io.jvm.lux b/new-luxc/source/luxc/io.jvm.lux index 599fde359..a4049de3a 100644 --- a/new-luxc/source/luxc/io.jvm.lux +++ b/new-luxc/source/luxc/io.jvm.lux @@ -11,8 +11,7 @@ [meta] [host] (world [file #+ File] - [blob #+ Blob])) - (luxc ["&" base])) + [blob #+ Blob]))) (host;import java.lang.String (new [(Array byte)])) diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux new file mode 100644 index 000000000..373c6b12b --- /dev/null +++ b/new-luxc/source/luxc/lang.lux @@ -0,0 +1,245 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + [product] + ["e" error] + [text "text/" Eq] + text/format + (coll [list])) + [meta] + (meta (type ["tc" check]) + ["s" syntax #+ syntax:])) + (luxc (lang ["la" analysis]))) + +(type: #export Eval + (-> Type Code (Meta Top))) + +(type: #export Analyser + (-> Code (Meta la;Analysis))) + +(def: #export version Text "0.6.0") + +(def: #export (fail message) + (All [a] (-> Text (Meta a))) + (do meta;Monad + [[file line col] meta;cursor + #let [location (format file + "," (|> line nat-to-int %i) + "," (|> col nat-to-int %i))]] + (meta;fail (format message "\n\n" + "@ " location)))) + +(def: #export (throw exception message) + (All [a] (-> ex;Exception Text (Meta a))) + (fail (exception message))) + +(syntax: #export (assert exception message test) + (wrap (list (` (if (~ test) + (:: meta;Monad (~' wrap) []) + (;;throw (~ exception) (~ message))))))) + +(def: #export (with-expected-type expected action) + (All [a] (-> Type (Meta a) (Meta a))) + (function [compiler] + (case (action (set@ #;expected (#;Some expected) compiler)) + (#e;Success [compiler' output]) + (let [old-expected (get@ #;expected compiler)] + (#e;Success [(set@ #;expected old-expected compiler') + output])) + + (#e;Error error) + (#e;Error error)))) + +(def: #export (with-type-env action) + (All [a] (-> (tc;Check a) (Meta a))) + (function [compiler] + (case (action (get@ #;type-context compiler)) + (#e;Error error) + ((fail error) compiler) + + (#e;Success [context' output]) + (#e;Success [(set@ #;type-context context' compiler) + output])))) + +(def: #export (with-fresh-type-env action) + (All [a] (-> (Meta a) (Meta a))) + (function [compiler] + (let [old (get@ #;type-context compiler)] + (case (action (set@ #;type-context tc;fresh-context compiler)) + (#e;Success [compiler' output]) + (#e;Success [(set@ #;type-context old compiler') + output]) + + output + output)))) + +(def: #export (infer actualT) + (-> Type (Meta Unit)) + (do meta;Monad + [expectedT meta;expected-type] + (with-type-env + (tc;check expectedT actualT)))) + +(def: #export (pl-get key table) + (All [a] (-> Text (List [Text a]) (Maybe a))) + (case table + #;Nil + #;None + + (#;Cons [k' v'] table') + (if (text/= key k') + (#;Some v') + (pl-get key table')))) + +(def: #export (pl-contains? key table) + (All [a] (-> Text (List [Text a]) Bool)) + (case (pl-get key table) + (#;Some _) + true + + #;None + false)) + +(def: #export (pl-put key val table) + (All [a] (-> Text a (List [Text a]) (List [Text a]))) + (case table + #;Nil + (list [key val]) + + (#;Cons [k' v'] table') + (if (text/= key k') + (#;Cons [key val] + table') + (#;Cons [k' v'] + (pl-put key val table'))))) + +(def: #export (pl-update key f table) + (All [a] (-> Text (-> a a) (List [Text a]) (List [Text a]))) + (case table + #;Nil + #;Nil + + (#;Cons [k' v'] table') + (if (text/= key k') + (#;Cons [k' (f v')] table') + (#;Cons [k' v'] (pl-update key f table'))))) + +(def: #export (with-source-code source action) + (All [a] (-> Source (Meta a) (Meta a))) + (function [compiler] + (let [old-source (get@ #;source compiler)] + (case (action (set@ #;source source compiler)) + (#e;Error error) + (#e;Error error) + + (#e;Success [compiler' output]) + (#e;Success [(set@ #;source old-source compiler') + output]))))) + +(def: #export (with-stacked-errors handler action) + (All [a] (-> (-> [] Text) (Meta a) (Meta a))) + (function [compiler] + (case (action compiler) + (#e;Success [compiler' output]) + (#e;Success [compiler' output]) + + (#e;Error error) + (#e;Error (if (text/= "" error) + (handler []) + (format (handler []) "\n\n-----------------------------------------\n\n" error)))))) + +(def: fresh-bindings + (All [k v] (Bindings k v)) + {#;counter +0 + #;mappings (list)}) + +(def: fresh-scope + Scope + {#;name (list) + #;inner +0 + #;locals fresh-bindings + #;captured fresh-bindings}) + +(def: #export (with-scope action) + (All [a] (-> (Meta a) (Meta [Scope a]))) + (function [compiler] + (case (action (update@ #;scopes (|>. (#;Cons fresh-scope)) compiler)) + (#e;Success [compiler' output]) + (case (get@ #;scopes compiler') + #;Nil + (#e;Error "Impossible error: Drained scopes!") + + (#;Cons head tail) + (#e;Success [(set@ #;scopes tail compiler') + [head output]])) + + (#e;Error error) + (#e;Error error)))) + +(def: #export (with-current-module name action) + (All [a] (-> Text (Meta a) (Meta a))) + (function [compiler] + (case (action (set@ #;current-module (#;Some name) compiler)) + (#e;Success [compiler' output]) + (#e;Success [(set@ #;current-module + (get@ #;current-module compiler) + compiler') + output]) + + (#e;Error error) + (#e;Error error)))) + +(def: #export (with-cursor cursor action) + (All [a] (-> Cursor (Meta a) (Meta a))) + (if (text/= "" (product;left cursor)) + action + (function [compiler] + (let [old-cursor (get@ #;cursor compiler)] + (case (action (set@ #;cursor cursor compiler)) + (#e;Success [compiler' output]) + (#e;Success [(set@ #;cursor old-cursor compiler') + output]) + + (#e;Error error) + (#e;Error error)))))) + +(def: (normalize-char char) + (-> Nat Text) + (case char + (^ (char "*")) "_ASTER_" + (^ (char "+")) "_PLUS_" + (^ (char "-")) "_DASH_" + (^ (char "/")) "_SLASH_" + (^ (char "\\")) "_BSLASH_" + (^ (char "_")) "_UNDERS_" + (^ (char "%")) "_PERCENT_" + (^ (char "$")) "_DOLLAR_" + (^ (char "'")) "_QUOTE_" + (^ (char "`")) "_BQUOTE_" + (^ (char "@")) "_AT_" + (^ (char "^")) "_CARET_" + (^ (char "&")) "_AMPERS_" + (^ (char "=")) "_EQ_" + (^ (char "!")) "_BANG_" + (^ (char "?")) "_QM_" + (^ (char ":")) "_COLON_" + (^ (char ".")) "_PERIOD_" + (^ (char ",")) "_COMMA_" + (^ (char "<")) "_LT_" + (^ (char ">")) "_GT_" + (^ (char "~")) "_TILDE_" + (^ (char "|")) "_PIPE_" + _ + (text;from-code char))) + +(def: underflow Nat (n.dec +0)) + +(def: #export (normalize-name name) + (-> Text Text) + (loop [idx (n.dec (text;size name)) + output ""] + (if (n.= underflow idx) + output + (recur (n.dec idx) (format (|> (text;nth idx name) maybe;assume normalize-char) output))))) diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux index ee4d4fcfa..ff328b9de 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -15,12 +15,12 @@ (meta [code] [type] (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis] + (luxc ["&" lang] + (lang ["&;" scope] + ["la" analysis] (analysis [";A" common] [";A" structure] - (case [";A" coverage]))) - ["&;" scope])) + (case [";A" coverage]))))) (exception: #export Cannot-Match-Type-With-Pattern) (exception: #export Sum-Type-Has-No-Case) diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/new-luxc/source/luxc/lang/analysis/case/coverage.lux index 554aea1a8..c41cfb2a4 100644 --- a/new-luxc/source/luxc/lang/analysis/case/coverage.lux +++ b/new-luxc/source/luxc/lang/analysis/case/coverage.lux @@ -10,7 +10,7 @@ (coll [list "list/" Fold] [dict #+ Dict])) [meta "meta/" Monad]) - (luxc ["&" base] + (luxc ["&" lang] (lang ["la" analysis]))) ## The coverage of a pattern-matching expression summarizes how well diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux index 968ebd2ea..5e618d64c 100644 --- a/new-luxc/source/luxc/lang/analysis/common.lux +++ b/new-luxc/source/luxc/lang/analysis/common.lux @@ -7,7 +7,7 @@ [meta] (meta [type] (type ["tc" check]))) - (luxc ["&" base] + (luxc ["&" lang] (lang analysis))) (def: #export (with-unknown-type action) diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index 248248010..afc347248 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -9,12 +9,12 @@ (meta [type] (type ["tc" check])) [host]) - (luxc ["&" base] - [";L" host] - (host [";H" macro]) - (lang ["la" analysis] - (translation [";T" common])) - ["&;" module]) + (luxc ["&" lang] + (lang ["&;" module] + [";L" host] + (host [";H" macro]) + ["la" analysis] + (translation [";T" common]))) (.. [";A" common] [";A" function] [";A" primitive] diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux index 6a4a33e48..5403026cb 100644 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -10,12 +10,12 @@ (meta [code] [type] (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis] + (luxc ["&" lang] + (lang ["&;" scope] + ["la" analysis #+ Analysis] (analysis ["&;" common] ["&;" inference]) - [";L" variable #+ Variable]) - ["&;" scope])) + [";L" variable #+ Variable]))) (exception: #export Invalid-Function-Type) (exception: #export Cannot-Apply-Function) diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux index 8b04ac2b7..080a6c620 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -9,7 +9,7 @@ [meta "meta/" Monad] (meta [type] (type ["tc" check]))) - (luxc ["&" base] + (luxc ["&" lang] (lang ["la" analysis #+ Analysis] (analysis ["&;" common])))) diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux index bb1762f46..792d607c3 100644 --- a/new-luxc/source/luxc/lang/analysis/primitive.lux +++ b/new-luxc/source/luxc/lang/analysis/primitive.lux @@ -4,7 +4,7 @@ [meta] (meta [code] (type ["tc" check]))) - (luxc ["&" base] + (luxc ["&" lang] (lang ["la" analysis #+ Analysis]))) ## [Analysers] diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux index 8ab868036..23e1a102d 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure.lux @@ -6,7 +6,7 @@ [text] text/format (coll [dict]))) - (luxc ["&" base] + (luxc ["&" lang] (lang ["la" analysis])) (. ["./;" common] ["./;" host])) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux index f5756f35b..be77e643c 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux @@ -12,7 +12,7 @@ (meta [code] (type ["tc" check])) [io]) - (luxc ["&" base] + (luxc ["&" lang] (lang ["la" analysis] (analysis ["&;" common] [";A" function] diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux index cd5fdc7bb..c6a456441 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux @@ -20,9 +20,9 @@ [type] (type ["tc" check])) [host]) - (luxc ["&" base] - ["&;" host] - (lang ["la" analysis] + (luxc ["&" lang] + (lang ["&;" host] + ["la" analysis] (analysis ["&;" common] [";A" inference]))) ["@" ../common] diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux index ef02919f4..6ba0325df 100644 --- a/new-luxc/source/luxc/lang/analysis/reference.lux +++ b/new-luxc/source/luxc/lang/analysis/reference.lux @@ -4,10 +4,10 @@ [meta] (meta [code] (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis] - [";L" variable #+ Variable]) - ["&;" scope])) + (luxc ["&" lang] + (lang ["&;" scope] + ["la" analysis #+ Analysis] + [";L" variable #+ Variable]))) ## [Analysers] (def: (analyse-definition def-name) diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index d2107c640..3048d4a4e 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -13,12 +13,12 @@ (meta [code] [type] (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis] + (luxc ["&" lang] + (lang ["&;" scope] + ["&;" module] + ["la" analysis] (analysis ["&;" common] - ["&;" inference])) - ["&;" module] - ["&;" scope])) + ["&;" inference])))) (exception: #export Not-Variant-Type) (exception: #export Not-Tuple-Type) @@ -156,7 +156,7 @@ (do @ [g!tail (meta;gensym "tail")] (&;with-expected-type tailT - (analyse (` ((~' _lux_case) [(~@ tailC)] + (analyse (` ("lux case" [(~@ tailC)] (~ g!tail) (~ g!tail)))))) )))) diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux index 89b25334f..4184dd0c0 100644 --- a/new-luxc/source/luxc/lang/analysis/type.lux +++ b/new-luxc/source/luxc/lang/analysis/type.lux @@ -3,7 +3,7 @@ (lux (control monad) [meta] (meta (type ["tc" check]))) - (luxc ["&" base] + (luxc ["&" lang] (lang ["la" analysis #+ Analysis]))) ## These 2 analysers are somewhat special, since they require the diff --git a/new-luxc/source/luxc/lang/eval.lux b/new-luxc/source/luxc/lang/eval.lux new file mode 100644 index 000000000..20c3acaeb --- /dev/null +++ b/new-luxc/source/luxc/lang/eval.lux @@ -0,0 +1,18 @@ +(;module: + lux + (lux (control [monad #+ do]) + [meta]) + (luxc ["&" lang] + (lang (analysis [";A" expression]) + (synthesis [";S" expression]) + (translation [";T" expression] + [";T" eval])))) + +(def: #export (eval type exprC) + &;Eval + (do meta;Monad + [exprA (&;with-expected-type type + (expressionA;analyser eval exprC)) + #let [exprS (expressionS;synthesize exprA)] + exprI (expressionT;translate exprS)] + (evalT;eval exprI))) diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux new file mode 100644 index 000000000..ae1d29387 --- /dev/null +++ b/new-luxc/source/luxc/lang/host.jvm.lux @@ -0,0 +1,185 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + pipe) + (concurrency ["A" atom]) + (data ["e" error] + [text] + text/format + (coll [dict] + [array])) + [meta #+ Monad] + [host #+ do-to object] + [io]) + (luxc ["&" lang] + (lang [";L" variable #+ Register] + (translation [";T" common])))) + +(host;import org.objectweb.asm.Label) + +(host;import java.lang.reflect.AccessibleObject + (setAccessible [boolean] void)) + +(host;import java.lang.reflect.Method + (invoke [Object (Array Object)] #try Object)) + +(host;import (java.lang.Class a) + (getDeclaredMethod [String (Array (Class Object))] #try Method)) + +(host;import java.lang.Object + (getClass [] (Class Object))) + +(host;import java.lang.Integer + (#static TYPE (Class Integer))) + +(host;import java.lang.ClassLoader) + +(def: ClassLoader::defineClass + Method + (case (Class.getDeclaredMethod ["defineClass" + (|> (host;array (Class Object) +4) + (host;array-write +0 (:! (Class Object) (host;class-for String))) + (host;array-write +1 (Object.getClass [] (host;array byte +0))) + (host;array-write +2 (:! (Class Object) Integer.TYPE)) + (host;array-write +3 (:! (Class Object) Integer.TYPE)))] + (host;class-for java.lang.ClassLoader)) + (#e;Success method) + (do-to method + (AccessibleObject.setAccessible [true])) + + (#e;Error error) + (error! error))) + +(def: (define-class class-name byte-code loader) + (-> Text commonT;Bytecode ClassLoader (e;Error Object)) + (Method.invoke [loader + (array;from-list (list (:! Object class-name) + (:! Object byte-code) + (:! Object (host;l2i 0)) + (:! Object (host;l2i (nat-to-int (host;array-length byte-code))))))] + ClassLoader::defineClass)) + +(def: (fetch-byte-code class-name store) + (-> Text commonT;Class-Store (Maybe commonT;Bytecode)) + (|> store A;get io;run (dict;get class-name))) + +(def: (memory-class-loader store) + (-> commonT;Class-Store ClassLoader) + (object ClassLoader [] + [] + (ClassLoader (findClass [class-name String]) Class + (case (fetch-byte-code class-name store) + (#;Some bytecode) + (case (define-class class-name bytecode (:! ClassLoader _jvm_this)) + (#e;Success class) + (:!! class) + + (#e;Error error) + (error! (format "Class definition error: " class-name "\n" + error))) + + #;None + (error! (format "Class not found: " class-name)))))) + +(def: #export init-host + (io;IO commonT;Host) + (io;io (let [store (: commonT;Class-Store + (A;atom (dict;new text;Hash)))] + {#commonT;loader (memory-class-loader store) + #commonT;store store + #commonT;artifacts (dict;new text;Hash) + #commonT;context ["" +0] + #commonT;anchor #;None}))) + +(def: #export (with-anchor anchor expr) + (All [a] (-> [Label Register] (Meta a) (Meta a))) + (;function [compiler] + (let [old (:! commonT;Host (get@ #;host compiler))] + (case (expr (set@ #;host + (:! Void (set@ #commonT;anchor (#;Some anchor) old)) + compiler)) + (#e;Success [compiler' output]) + (#e;Success [(update@ #;host + (|>. (:! commonT;Host) + (set@ #commonT;anchor (get@ #commonT;anchor old)) + (:! Void)) + compiler') + output]) + + (#e;Error error) + (#e;Error error))))) + +(exception: #export No-Anchor) + +(def: #export anchor + (Meta [Label Register]) + (;function [compiler] + (case (|> compiler (get@ #;host) (:! commonT;Host) (get@ #commonT;anchor)) + (#;Some anchor) + (#e;Success [compiler + anchor]) + + #;None + ((&;throw No-Anchor "") compiler)))) + +(def: #export (with-context name expr) + (All [a] (-> Text (Meta a) (Meta a))) + (;function [compiler] + (let [old (:! commonT;Host (get@ #;host compiler))] + (case (expr (set@ #;host + (:! Void (set@ #commonT;context [(&;normalize-name name) +0] old)) + compiler)) + (#e;Success [compiler' output]) + (#e;Success [(update@ #;host + (|>. (:! commonT;Host) + (set@ #commonT;context (get@ #commonT;context old)) + (:! Void)) + compiler') + output]) + + (#e;Error error) + (#e;Error error))))) + +(def: #export (with-sub-context expr) + (All [a] (-> (Meta a) (Meta [Text a]))) + (;function [compiler] + (let [old (:! commonT;Host (get@ #;host compiler)) + [old-name old-sub] (get@ #commonT;context old) + new-name (format old-name "$" (%i (nat-to-int old-sub)))] + (case (expr (set@ #;host + (:! Void (set@ #commonT;context [new-name +0] old)) + compiler)) + (#e;Success [compiler' output]) + (#e;Success [(update@ #;host + (|>. (:! commonT;Host) + (set@ #commonT;context [old-name (n.inc old-sub)]) + (:! Void)) + compiler') + [new-name output]]) + + (#e;Error error) + (#e;Error error))))) + +(def: #export context + (Meta Text) + (;function [compiler] + (#e;Success [compiler + (|> (get@ #;host compiler) + (:! commonT;Host) + (get@ #commonT;context) + (let> [name sub] + name))]))) + +(def: #export class-loader + (Meta ClassLoader) + (function [compiler] + (#e;Success [compiler + (|> compiler + (get@ #;host) + (:! commonT;Host) + (get@ #commonT;loader))]))) + +(def: #export runtime-class Text "LuxRuntime") +(def: #export function-class Text "LuxFunction") +(def: #export unit Text "\u0000") diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux new file mode 100644 index 000000000..24d4a9ea9 --- /dev/null +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -0,0 +1,130 @@ +(;module: + [lux #- Type Def] + (lux (control monad + ["p" parser]) + (data (coll [list "list/" Functor])) + [meta] + (meta [code] + ["s" syntax #+ syntax:]) + [host])) + +## [Host] +(host;import org.objectweb.asm.MethodVisitor) + +(host;import org.objectweb.asm.ClassWriter) + +(host;import #long org.objectweb.asm.Label + (new [])) + +## [Type] +(type: #export Bound + #Upper + #Lower) + +(type: #export Primitive + #Boolean + #Byte + #Short + #Int + #Long + #Float + #Double + #Char) + +(type: #export #rec Generic + (#Var Text) + (#Wildcard (Maybe [Bound Generic])) + (#Class Text (List Generic))) + +(type: #export Class + [Text (List Generic)]) + +(type: #export Parameter + [Text Class (List Class)]) + +(type: #export #rec Type + (#Primitive Primitive) + (#Generic Generic) + (#Array Type)) + +(type: #export Method + {#args (List Type) + #return (Maybe Type) + #exceptions (List Generic)}) + +(type: #export Def + (-> ClassWriter ClassWriter)) + +(type: #export Inst + (-> MethodVisitor MethodVisitor)) + +(type: #export Label + org.objectweb.asm.Label) + +(type: #export Register Nat) + +(type: #export Visibility + #Public + #Protected + #Private + #Default) + +(type: #export Version + #V1.1 + #V1.2 + #V1.3 + #V1.4 + #V1.5 + #V1.6 + #V1.7 + #V1.8) + +## [Values] +(syntax: (config: [type s;local-symbol] + [none s;local-symbol] + [++ s;local-symbol] + [options (s;tuple (p;many s;local-symbol))]) + (let [g!type (code;local-symbol type) + g!none (code;local-symbol none) + g!tags+ (list/map code;local-tag options) + g!_left (code;local-symbol "_left") + g!_right (code;local-symbol "_right") + g!options+ (list/map (function [option] + (` (def: (~' #export) (~ (code;local-symbol option)) + (~ g!type) + (|> (~ g!none) + (set@ (~ (code;local-tag option)) true))))) + options)] + (wrap (list& (` (type: (~' #export) (~ g!type) + (~ (code;record (list/map (function [tag] + [tag (` ;Bool)]) + g!tags+))))) + + (` (def: (~' #export) (~ g!none) + (~ g!type) + (~ (code;record (list/map (function [tag] + [tag (` false)]) + g!tags+))))) + + (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right)) + (-> (~ g!type) (~ g!type) (~ g!type)) + (~ (code;record (list/map (function [tag] + [tag (` (or (get@ (~ tag) (~ g!_left)) + (get@ (~ tag) (~ g!_right))))]) + g!tags+))))) + + g!options+)))) + +## Configs +(config: Class-Config noneC ++C [finalC]) +(config: Method-Config noneM ++M [finalM staticM synchronizedM strictM]) +(config: Field-Config noneF ++F [finalF staticF transientF volatileF]) + +## Labels +(def: #export new-label + (-> Unit Label) + org.objectweb.asm.Label.new) + +(def: #export (simple-class name) + (-> Text Class) + [name (list)]) diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux new file mode 100644 index 000000000..60009fb5c --- /dev/null +++ b/new-luxc/source/luxc/lang/host/jvm/def.lux @@ -0,0 +1,288 @@ +(;module: + lux + (lux (data [text] + text/format + [product] + (coll ["a" array] + [list "list/" Functor])) + [host #+ do-to]) + ["$" ..] + (.. ["$t" type])) + +## [Host] +(host;import #long java.lang.Object) +(host;import #long java.lang.String) + +(host;import org.objectweb.asm.Opcodes + (#static ACC_PUBLIC int) + (#static ACC_PROTECTED int) + (#static ACC_PRIVATE int) + + (#static ACC_TRANSIENT int) + (#static ACC_VOLATILE int) + + (#static ACC_ABSTRACT int) + (#static ACC_FINAL int) + (#static ACC_STATIC int) + (#static ACC_SYNCHRONIZED int) + (#static ACC_STRICT int) + + (#static ACC_SUPER int) + (#static ACC_INTERFACE int) + + (#static V1_1 int) + (#static V1_2 int) + (#static V1_3 int) + (#static V1_4 int) + (#static V1_5 int) + (#static V1_6 int) + (#static V1_7 int) + (#static V1_8 int) + ) + +(host;import org.objectweb.asm.FieldVisitor + (visitEnd [] void)) + +(host;import org.objectweb.asm.MethodVisitor + (visitCode [] void) + (visitMaxs [int int] void) + (visitEnd [] void)) + +(host;import org.objectweb.asm.ClassWriter + (#static COMPUTE_MAXS int) + (#static COMPUTE_FRAMES int) + (new [int]) + (visit [int int String String String (Array String)] void) + (visitEnd [] void) + (visitField [int String String String Object] FieldVisitor) + (visitMethod [int String String String (Array String)] MethodVisitor) + (toByteArray [] (Array byte))) + +## [Defs] +(def: (string-array values) + (-> (List Text) (Array Text)) + (let [output (host;array String (list;size values))] + (exec (list/map (function [[idx value]] + (host;array-write idx value output)) + (list;enumerate values)) + output))) + +(def: exceptions-array + (-> $;Method (Array Text)) + (|>. (get@ #$;exceptions) + (list/map (|>. #$;Generic $t;descriptor)) + string-array)) + +(def: (version-flag version) + (-> $;Version Int) + (case version + #$;V1.1 Opcodes.V1_1 + #$;V1.2 Opcodes.V1_2 + #$;V1.3 Opcodes.V1_3 + #$;V1.4 Opcodes.V1_4 + #$;V1.5 Opcodes.V1_5 + #$;V1.6 Opcodes.V1_6 + #$;V1.7 Opcodes.V1_7 + #$;V1.8 Opcodes.V1_8)) + +(def: (visibility-flag visibility) + (-> $;Visibility Int) + (case visibility + #$;Public Opcodes.ACC_PUBLIC + #$;Protected Opcodes.ACC_PROTECTED + #$;Private Opcodes.ACC_PRIVATE + #$;Default 0)) + +(def: (class-flags config) + (-> $;Class-Config Int) + ($_ i.+ + (if (get@ #$;finalC config) Opcodes.ACC_FINAL 0))) + +(def: (method-flags config) + (-> $;Method-Config Int) + ($_ i.+ + (if (get@ #$;staticM config) Opcodes.ACC_STATIC 0) + (if (get@ #$;finalM config) Opcodes.ACC_FINAL 0) + (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0) + (if (get@ #$;strictM config) Opcodes.ACC_STRICT 0))) + +(def: (field-flags config) + (-> $;Field-Config Int) + ($_ i.+ + (if (get@ #$;staticF config) Opcodes.ACC_STATIC 0) + (if (get@ #$;finalF config) Opcodes.ACC_FINAL 0) + (if (get@ #$;transientF config) Opcodes.ACC_TRANSIENT 0) + (if (get@ #$;volatileF config) Opcodes.ACC_VOLATILE 0))) + +(def: class-to-type + (-> $;Class $;Type) + (|>. #$;Class #$;Generic)) + +(def: param-signature + (-> $;Class Text) + (|>. class-to-type $t;signature (format ":"))) + +(def: (formal-param [name super interfaces]) + (-> $;Parameter Text) + (format name + (param-signature super) + (|> interfaces + (list/map param-signature) + (text;join-with "")))) + +(def: (parameters-signature parameters super interfaces) + (-> (List $;Parameter) $;Class (List $;Class) + Text) + (let [formal-params (if (list;empty? parameters) + "" + (format "<" + (|> parameters + (list/map formal-param) + (text;join-with "")) + ">"))] + (format formal-params + (|> super class-to-type $t;signature) + (|> interfaces + (list/map (|>. class-to-type $t;signature)) + (text;join-with ""))))) + +(def: class-computes + Int + ($_ i.+ + ClassWriter.COMPUTE_MAXS + ## ClassWriter.COMPUTE_FRAMES + )) + +(do-template [ ] + [(def: #export ( version visibility config name parameters super interfaces + definitions) + (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def + (host;type (Array byte))) + (let [writer (|> (do-to (ClassWriter.new class-computes) + (ClassWriter.visit [(version-flag version) + ($_ i.+ + Opcodes.ACC_SUPER + + (visibility-flag visibility) + (class-flags config)) + ($t;binary-name name) + (parameters-signature parameters super interfaces) + (|> super product;left $t;binary-name) + (|> interfaces + (list/map (|>. product;left $t;binary-name)) + string-array)])) + definitions) + _ (ClassWriter.visitEnd [] writer)] + (ClassWriter.toByteArray [] writer)))] + + [class 0] + [abstract Opcodes.ACC_ABSTRACT] + ) + +(def: $Object $;Class ["java.lang.Object" (list)]) + +(def: #export (interface version visibility config name parameters interfaces + definitions) + (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def + (host;type (Array byte))) + (let [writer (|> (do-to (ClassWriter.new class-computes) + (ClassWriter.visit [(version-flag version) + ($_ i.+ + Opcodes.ACC_SUPER + Opcodes.ACC_INTERFACE + (visibility-flag visibility) + (class-flags config)) + ($t;binary-name name) + (parameters-signature parameters $Object interfaces) + (|> $Object product;left $t;binary-name) + (|> interfaces + (list/map (|>. product;left $t;binary-name)) + string-array)])) + definitions) + _ (ClassWriter.visitEnd [] writer)] + (ClassWriter.toByteArray [] writer))) + +(def: #export (method visibility config name type then) + (-> $;Visibility $;Method-Config Text $;Method $;Inst + $;Def) + (function [writer] + (let [=method (ClassWriter.visitMethod [($_ i.+ + (visibility-flag visibility) + (method-flags config)) + ($t;binary-name name) + ($t;method-descriptor type) + ($t;method-signature type) + (exceptions-array type)] + writer) + _ (MethodVisitor.visitCode [] =method) + _ (then =method) + _ (MethodVisitor.visitMaxs [0 0] =method) + _ (MethodVisitor.visitEnd [] =method)] + writer))) + +(def: #export (abstract-method visibility config name type) + (-> $;Visibility $;Method-Config Text $;Method + $;Def) + (function [writer] + (let [=method (ClassWriter.visitMethod [($_ i.+ + (visibility-flag visibility) + (method-flags config) + Opcodes.ACC_ABSTRACT) + ($t;binary-name name) + ($t;method-descriptor type) + ($t;method-signature type) + (exceptions-array type)] + writer) + _ (MethodVisitor.visitEnd [] =method)] + writer))) + +(def: #export (field visibility config name type) + (-> $;Visibility $;Field-Config Text $;Type $;Def) + (function [writer] + (let [=field (do-to (ClassWriter.visitField [($_ i.+ + (visibility-flag visibility) + (field-flags config)) + ($t;binary-name name) + ($t;descriptor type) + ($t;signature type) + (host;null)] writer) + (FieldVisitor.visitEnd []))] + writer))) + +(do-template [ ] + [(def: #export ( visibility config name value) + (-> $;Visibility $;Field-Config Text $;Def) + (function [writer] + (let [=field (do-to (ClassWriter.visitField [($_ i.+ + (visibility-flag visibility) + (field-flags config)) + ($t;binary-name name) + ($t;descriptor ) + ($t;signature ) + ( value)] + writer) + (FieldVisitor.visitEnd []))] + writer)))] + + [boolean-field Bool $t;boolean id] + [byte-field Int $t;byte host;l2b] + [short-field Int $t;short host;l2s] + [int-field Int $t;int host;l2i] + [long-field Int $t;long id] + [float-field Frac $t;float host;d2f] + [double-field Frac $t;double id] + [char-field Nat $t;char (|>. nat-to-int host;l2i host;i2c)] + [string-field Text ($t;class "java.lang.String" (list)) id] + ) + +(def: #export (fuse defs) + (-> (List $;Def) $;Def) + (case defs + #;Nil + id + + (#;Cons singleton #;Nil) + singleton + + (#;Cons head tail) + (. (fuse tail) head))) diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux new file mode 100644 index 000000000..37ab75020 --- /dev/null +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -0,0 +1,383 @@ +(;module: + [lux #- char] + (lux (control monad + ["p" parser]) + (data [maybe] + ["e" error] + text/format + (coll [list "L/" Functor])) + [host #+ do-to] + [meta] + (meta [code] + ["s" syntax #+ syntax:])) + ["$" ..] + (.. ["$t" type])) + +## [Host] +(host;import #long java.lang.Object) +(host;import #long java.lang.String) + +(syntax: (declare [codes (p;many s;local-symbol)]) + (|> codes + (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int))))) + wrap)) + +(`` (host;import org.objectweb.asm.Opcodes + (#static NOP int) + + ## Conversion + (~~ (declare D2F D2I D2L + F2D F2I F2L + I2B I2C I2D I2F I2L I2S + L2D L2F L2I)) + + ## Primitive + (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE + T_BYTE T_SHORT T_INT T_LONG)) + + ## Class + (~~ (declare CHECKCAST NEW INSTANCEOF)) + + ## Stack + (~~ (declare DUP DUP_X1 DUP_X2 + DUP2 DUP2_X1 DUP2_X2 + POP POP2 + SWAP)) + + ## Jump + (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL + IFEQ IFNE IFLT IFLE IFGT IFGE + GOTO)) + + (#static ACONST_NULL int) + + ## Var + (~~ (declare ILOAD LLOAD DLOAD ALOAD + ISTORE LSTORE ASTORE)) + + ## Arithmetic + (~~ (declare IADD ISUB IMUL IDIV IREM + LADD LSUB LMUL LDIV LREM LCMP + FADD FSUB FMUL FDIV FREM FCMPG FCMPL + DADD DSUB DMUL DDIV DREM DCMPG DCMPL)) + + ## Bit-wise + (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR + LAND LOR LXOR LSHL LSHR LUSHR)) + + ## Array + (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY + AALOAD AASTORE + BALOAD BASTORE + SALOAD SASTORE + IALOAD IASTORE + LALOAD LASTORE + FALOAD FASTORE + DALOAD DASTORE + CALOAD CASTORE)) + + ## Member + (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD + INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE)) + + (#static ATHROW int) + + ## Concurrency + (~~ (declare MONITORENTER MONITOREXIT)) + + ## Return + (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN)) + )) + +(host;import org.objectweb.asm.FieldVisitor + (visitEnd [] void)) + +(host;import org.objectweb.asm.Label + (new [])) + +(host;import org.objectweb.asm.MethodVisitor + (visitCode [] void) + (visitMaxs [int int] void) + (visitEnd [] void) + (visitInsn [int] void) + (visitLdcInsn [Object] void) + (visitFieldInsn [int String String String] void) + (visitTypeInsn [int String] void) + (visitVarInsn [int int] void) + (visitIntInsn [int int] void) + (visitMethodInsn [int String String String boolean] void) + (visitLabel [Label] void) + (visitJumpInsn [int Label] void) + (visitTryCatchBlock [Label Label Label String] void) + (visitTableSwitchInsn [int int Label (Array Label)] void) + ) + +## [Insts] +(def: #export make-label + (Meta Label) + (function [compiler] + (#e;Success [compiler (Label.new [])]))) + +(def: #export (with-label action) + (-> (-> Label $;Inst) $;Inst) + (action (Label.new []))) + +(do-template [ ] + [(def: #export ( value) + (-> $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitLdcInsn [( value)]))))] + + [boolean Bool id] + [int Int host;l2i] + [long Int id] + [double Frac id] + [char Nat (|>. nat-to-int host;l2i host;i2c)] + [string Text id] + ) + +(syntax: (prefix [base s;local-symbol]) + (wrap (list (code;local-symbol (format "Opcodes." base))))) + +(def: #export NULL + $;Inst + (function [visitor] + (do-to visitor + (MethodVisitor.visitInsn [(prefix ACONST_NULL)])))) + +(do-template [] + [(def: #export + $;Inst + (function [visitor] + (do-to visitor + (MethodVisitor.visitInsn [(prefix )]))))] + + [NOP] + + ## Stack + [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2] + [POP] [POP2] + [SWAP] + + ## Conversions + [D2F] [D2I] [D2L] + [F2D] [F2I] [F2L] + [I2B] [I2C] [I2D] [I2F] [I2L] [I2S] + [L2D] [L2F] [L2I] + + ## Integer arithmetic + [IADD] [ISUB] [IMUL] [IDIV] [IREM] + + ## Integer bitwise + [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR] + + ## Long arithmetic + [LADD] [LSUB] [LMUL] [LDIV] [LREM] + [LCMP] + + ## Long bitwise + [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR] + + ## Float arithmetic + [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FCMPG] [FCMPL] + + ## Double arithmetic + [DADD] [DSUB] [DMUL] [DDIV] [DREM] + [DCMPG] [DCMPL] + + ## Array + [ARRAYLENGTH] + [AALOAD] [AASTORE] + [BALOAD] [BASTORE] + [SALOAD] [SASTORE] + [IALOAD] [IASTORE] + [LALOAD] [LASTORE] + [FALOAD] [FASTORE] + [DALOAD] [DASTORE] + [CALOAD] [CASTORE] + + ## Exceptions + [ATHROW] + + ## Concurrency + [MONITORENTER] [MONITOREXIT] + + ## Return + [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN] + ) + +(do-template [] + [(def: #export ( register) + (-> Nat $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitVarInsn [(prefix ) (nat-to-int register)]))))] + + [ILOAD] [LLOAD] [DLOAD] [ALOAD] + [ISTORE] [LSTORE] [ASTORE] + ) + +(do-template [ ] + [(def: #export ( class field type) + (-> Text Text $;Type $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitFieldInsn [ ($t;binary-name class) field ($t;descriptor type)]))))] + + [GETSTATIC Opcodes.GETSTATIC] + [PUTSTATIC Opcodes.PUTSTATIC] + + [PUTFIELD Opcodes.PUTFIELD] + [GETFIELD Opcodes.GETFIELD] + ) + +(do-template [ ] + [(def: #export ( class) + (-> Text $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitTypeInsn [ ($t;binary-name class)]))))] + + [CHECKCAST Opcodes.CHECKCAST] + [NEW Opcodes.NEW] + [INSTANCEOF Opcodes.INSTANCEOF] + [ANEWARRAY Opcodes.ANEWARRAY] + ) + +(def: #export (NEWARRAY type) + (-> $;Primitive $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type + #$;Boolean Opcodes.T_BOOLEAN + #$;Byte Opcodes.T_BYTE + #$;Short Opcodes.T_SHORT + #$;Int Opcodes.T_INT + #$;Long Opcodes.T_LONG + #$;Float Opcodes.T_FLOAT + #$;Double Opcodes.T_DOUBLE + #$;Char Opcodes.T_CHAR)])))) + +(do-template [ ] + [(def: #export ( class method-name method-signature interface?) + (-> Text Text $;Method Bool $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitMethodInsn [ ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))] + + [INVOKESTATIC Opcodes.INVOKESTATIC] + [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL] + [INVOKESPECIAL Opcodes.INVOKESPECIAL] + [INVOKEINTERFACE Opcodes.INVOKEINTERFACE] + ) + +(do-template [] + [(def: #export ( @where) + (-> $;Label $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitJumpInsn [(prefix ) @where]))))] + + [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] [IF_ACMPEQ] [IFNULL] + [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE] + [GOTO] + ) + +(def: #export (TABLESWITCH min max default labels) + (-> Int Int $;Label (List $;Label) $;Inst) + (function [visitor] + (let [num-labels (list;size labels) + labels-array (host;array Label num-labels) + _ (loop [idx +0] + (if (n.< num-labels idx) + (exec (host;array-write idx + (maybe;assume (list;nth idx labels)) + labels-array) + (recur (n.inc idx))) + []))] + (do-to visitor + (MethodVisitor.visitTableSwitchInsn [min max default labels-array]))))) + +(def: #export (try @from @to @handler exception) + (-> $;Label $;Label $;Label Text $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitTryCatchBlock [@from @to @handler ($t;binary-name exception)])))) + +(def: #export (label @label) + (-> $;Label $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitLabel [@label])))) + +(def: #export (array type) + (-> $;Type $;Inst) + (case type + (#$;Primitive prim) + (NEWARRAY prim) + + (#$;Generic generic) + (let [elem-class (case generic + (#$;Class class params) + ($t;binary-name class) + + _ + ($t;binary-name "java.lang.Object"))] + (ANEWARRAY elem-class)) + + _ + (ANEWARRAY ($t;descriptor type)))) + +(def: (primitive-wrapper type) + (-> $;Primitive Text) + (case type + #$;Boolean "java.lang.Boolean" + #$;Byte "java.lang.Byte" + #$;Short "java.lang.Short" + #$;Int "java.lang.Integer" + #$;Long "java.lang.Long" + #$;Float "java.lang.Float" + #$;Double "java.lang.Double" + #$;Char "java.lang.Character")) + +(def: (primitive-unwrap type) + (-> $;Primitive Text) + (case type + #$;Boolean "booleanValue" + #$;Byte "byteValue" + #$;Short "shortValue" + #$;Int "intValue" + #$;Long "longValue" + #$;Float "floatValue" + #$;Double "doubleValue" + #$;Char "charValue")) + +(def: #export (wrap type) + (-> $;Primitive $;Inst) + (let [class (primitive-wrapper type)] + (|>. (INVOKESTATIC class "valueOf" + ($t;method (list (#$;Primitive type)) + (#;Some ($t;class class (list))) + (list)) + false)))) + +(def: #export (unwrap type) + (-> $;Primitive $;Inst) + (let [class (primitive-wrapper type)] + (|>. (CHECKCAST class) + (INVOKEVIRTUAL class (primitive-unwrap type) + ($t;method (list) (#;Some (#$;Primitive type)) (list)) + false)))) + +(def: #export (fuse insts) + (-> (List $;Inst) $;Inst) + (case insts + #;Nil + id + + (#;Cons singleton #;Nil) + singleton + + (#;Cons head tail) + (. (fuse tail) head))) diff --git a/new-luxc/source/luxc/lang/host/jvm/type.lux b/new-luxc/source/luxc/lang/host/jvm/type.lux new file mode 100644 index 000000000..3825d443b --- /dev/null +++ b/new-luxc/source/luxc/lang/host/jvm/type.lux @@ -0,0 +1,138 @@ +(;module: + [lux #- char] + (lux (data [text] + text/format + (coll [list "L/" Functor]))) + ["$" ..]) + +## Types +(do-template [ ] + [(def: #export $;Type (#$;Primitive ))] + + [boolean #$;Boolean] + [byte #$;Byte] + [short #$;Short] + [int #$;Int] + [long #$;Long] + [float #$;Float] + [double #$;Double] + [char #$;Char] + ) + +(def: #export (class name params) + (-> Text (List $;Generic) $;Type) + (#$;Generic (#$;Class name params))) + +(def: #export (var name) + (-> Text $;Type) + (#$;Generic (#$;Var name))) + +(def: #export (wildcard bound) + (-> (Maybe [$;Bound $;Generic]) $;Type) + (#$;Generic (#$;Wildcard bound))) + +(def: #export (array depth elemT) + (-> Nat $;Type $;Type) + (case depth + +0 elemT + _ (#$;Array (array (n.dec depth) elemT)))) + +(def: #export (binary-name class) + (-> Text Text) + (text;replace-all "." "/" class)) + +(def: #export (descriptor type) + (-> $;Type Text) + (case type + (#$;Primitive prim) + (case prim + #$;Boolean "Z" + #$;Byte "B" + #$;Short "S" + #$;Int "I" + #$;Long "J" + #$;Float "F" + #$;Double "D" + #$;Char "C") + + (#$;Array sub) + (format "[" (descriptor sub)) + + (#$;Generic generic) + (case generic + (#$;Class class params) + (format "L" (binary-name class) ";") + + (^or (#$;Var name) (#$;Wildcard ?bound)) + (descriptor (#$;Generic (#$;Class "java.lang.Object" (list))))) + )) + +(def: #export (signature type) + (-> $;Type Text) + (case type + (#$;Primitive prim) + (case prim + #$;Boolean "Z" + #$;Byte "B" + #$;Short "S" + #$;Int "I" + #$;Long "J" + #$;Float "F" + #$;Double "D" + #$;Char "C") + + (#$;Array sub) + (format "[" (signature sub)) + + (#$;Generic generic) + (case generic + (#$;Class class params) + (let [=params (if (list;empty? params) + "" + (format "<" + (|> params + (L/map (|>. #$;Generic signature)) + (text;join-with "")) + ">"))] + (format "L" (binary-name class) =params ";")) + + (#$;Var name) + (format "T" name ";") + + (#$;Wildcard #;None) + "*" + + (^template [ ] + (#$;Wildcard (#;Some [ bound])) + (format (signature (#$;Generic bound)))) + ([#$;Upper "+"] + [#$;Lower "-"])) + )) + +## Methods +(def: #export (method args return exceptions) + (-> (List $;Type) (Maybe $;Type) (List $;Generic) $;Method) + {#$;args args #$;return return #$;exceptions exceptions}) + +(def: #export (method-descriptor method) + (-> $;Method Text) + (format "(" (text;join-with "" (L/map descriptor (get@ #$;args method))) ")" + (case (get@ #$;return method) + #;None + "V" + + (#;Some return) + (descriptor return)))) + +(def: #export (method-signature method) + (-> $;Method Text) + (format "(" (|> (get@ #$;args method) (L/map signature) (text;join-with "")) ")" + (case (get@ #$;return method) + #;None + "V" + + (#;Some return) + (signature return)) + (|> (get@ #$;exceptions method) + (L/map (|>. #$;Generic signature (format "^"))) + (text;join-with "")))) diff --git a/new-luxc/source/luxc/lang/host/macro.lux b/new-luxc/source/luxc/lang/host/macro.lux new file mode 100644 index 000000000..01f8c3bdb --- /dev/null +++ b/new-luxc/source/luxc/lang/host/macro.lux @@ -0,0 +1,37 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data ["e" error]) + [meta] + [host]) + (luxc (lang (translation [";T" common]))) + [..]) + +(for {"JVM" (as-is (host;import java.lang.reflect.Method + (invoke [Object (Array Object)] #try Object)) + (host;import (java.lang.Class c) + (getMethod [String (Array (Class Object))] #try Method)) + (host;import java.lang.Object + (getClass [] (Class Object)) + (toString [] String)) + (def: _object-class (Class Object) (host;class-for Object)) + (def: _apply-args + (Array (Class Object)) + (|> (host;array (Class Object) +2) + (host;array-write +0 _object-class) + (host;array-write +1 _object-class))) + (def: #export (expand macro inputs) + (-> Macro (List Code) (Meta (List Code))) + (do meta;Monad + [class (commonT;load-class ..;function-class)] + (function [compiler] + (do e;Monad + [apply-method (Class.getMethod ["apply" _apply-args] class) + output (Method.invoke [(:! Object macro) + (|> (host;array Object +2) + (host;array-write +0 (:! Object inputs)) + (host;array-write +1 (:! Object compiler)))] + apply-method)] + (:! (e;Error [Compiler (List Code)]) + output)))))) + }) diff --git a/new-luxc/source/luxc/lang/module.lux b/new-luxc/source/luxc/lang/module.lux new file mode 100644 index 000000000..fba337cc3 --- /dev/null +++ b/new-luxc/source/luxc/lang/module.lux @@ -0,0 +1,173 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [text "text/" Eq] + text/format + ["e" error] + (coll [list "list/" Fold Functor])) + [meta] + (meta [code])) + (luxc ["&" lang] + (lang ["&;" scope]))) + +(exception: #export Unknown-Module) +(exception: #export Cannot-Declare-Tag-Twice) +(exception: #export Cannot-Declare-Tags-For-Unnamed-Type) +(exception: #export Cannot-Declare-Tags-For-Foreign-Type) + +(def: (new-module hash) + (-> Nat Module) + {#;module-hash hash + #;module-aliases (list) + #;defs (list) + #;imports (list) + #;tags (list) + #;types (list) + #;module-annotations (' {}) + #;module-state #;Active}) + +(def: #export (define (^@ full-name [module-name def-name]) + definition) + (-> Ident Def (Meta Unit)) + (function [compiler] + (case (&;pl-get module-name (get@ #;modules compiler)) + (#;Some module) + (case (&;pl-get def-name (get@ #;defs module)) + #;None + (#e;Success [(update@ #;modules + (&;pl-put module-name + (update@ #;defs + (: (-> (List [Text Def]) (List [Text Def])) + (|>. (#;Cons [def-name definition]))) + module)) + compiler) + []]) + + (#;Some already-existing) + (#e;Error (format "Cannot re-define definiton: " (%ident full-name)))) + + #;None + (#e;Error (format "Cannot define in unknown module: " module-name))))) + +(def: #export (create hash name) + (-> Nat Text (Meta Module)) + (function [compiler] + (let [module (new-module hash)] + (#e;Success [(update@ #;modules + (&;pl-put name module) + compiler) + module])))) + +(def: #export (with-module hash name action) + (All [a] (-> Nat Text (Meta a) (Meta [Module a]))) + (do meta;Monad + [_ (create hash name) + output (&;with-current-module name + (&scope;with-scope name action)) + module (meta;find-module name)] + (wrap [module output]))) + +(do-template [ ] + [(def: #export ( module-name) + (-> Text (Meta Unit)) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) + (#;Some module) + (let [active? (case (get@ #;module-state module) + #;Active true + _ false)] + (if active? + (#e;Success [(update@ #;modules + (&;pl-put module-name (set@ #;module-state module)) + compiler) + []]) + (#e;Error "Can only change the state of a currently-active module."))) + + #;None + (#e;Error (format "Module does not exist: " module-name))))) + (def: #export ( module-name) + (-> Text (Meta Bool)) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) + (#;Some module) + (#e;Success [compiler + (case (get@ #;module-state module) + true + _ false)]) + + #;None + (#e;Error (format "Module does not exist: " module-name))) + ))] + + [flag-active! active? #;Active] + [flag-compiled! compiled? #;Compiled] + [flag-cached! cached? #;Cached] + ) + +(do-template [ ] + [(def: ( module-name) + (-> Text (Meta )) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) + (#;Some module) + (#e;Success [compiler (get@ module)]) + + #;None + (meta;run compiler (&;throw Unknown-Module module-name))) + ))] + + [tags-by-module #;tags (List [Text [Nat (List Ident) Bool Type]])] + [types-by-module #;types (List [Text [(List Ident) Bool Type]])] + [module-hash #;module-hash Nat] + ) + +(def: (ensure-undeclared-tags module-name tags) + (-> Text (List Text) (Meta Unit)) + (do meta;Monad + [bindings (tags-by-module module-name) + _ (monad;map @ + (function [tag] + (case (&;pl-get tag bindings) + #;None + (wrap []) + + (#;Some _) + (&;throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n" + " Tag: " tag)))) + tags)] + (wrap []))) + +(def: #export (declare-tags tags exported? type) + (-> (List Text) Bool Type (Meta Unit)) + (do meta;Monad + [current-module meta;current-module-name + [type-module type-name] (case type + (#;Named type-ident _) + (wrap type-ident) + + _ + (&;throw Cannot-Declare-Tags-For-Unnamed-Type + (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" + "Type: " (%type type)))) + _ (ensure-undeclared-tags current-module tags) + _ (&;assert Cannot-Declare-Tags-For-Foreign-Type + (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" + "Type: " (%type type)) + (text/= current-module type-module))] + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get current-module)) + (#;Some module) + (let [namespaced-tags (list/map (|>. [current-module]) tags)] + (#e;Success [(update@ #;modules + (&;pl-update current-module + (|>. (update@ #;tags (function [tag-bindings] + (list/fold (function [[idx tag] table] + (&;pl-put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list;enumerate tags)))) + (update@ #;types (&;pl-put type-name [namespaced-tags exported? type])))) + compiler) + []])) + #;None + (meta;run compiler (&;throw Unknown-Module current-module)))))) diff --git a/new-luxc/source/luxc/lang/scope.lux b/new-luxc/source/luxc/lang/scope.lux new file mode 100644 index 000000000..435b8ef61 --- /dev/null +++ b/new-luxc/source/luxc/lang/scope.lux @@ -0,0 +1,173 @@ +(;module: + lux + (lux (control monad) + (data [text "text/" Eq] + text/format + [maybe "maybe/" Monad] + [product] + ["e" error] + (coll [list "list/" Functor Fold Monoid])) + [meta]) + (luxc ["&" lang] + (lang [";L" variable #+ Variable]))) + +(type: Locals (Bindings Text [Type Nat])) +(type: Captured (Bindings Text [Type Ref])) + +(def: (is-local? name scope) + (-> Text Scope Bool) + (|> scope + (get@ [#;locals #;mappings]) + (&;pl-contains? name))) + +(def: (get-local name scope) + (-> Text Scope (Maybe [Type Ref])) + (|> scope + (get@ [#;locals #;mappings]) + (&;pl-get name) + (maybe/map (function [[type value]] + [type (#;Local value)])))) + +(def: (is-captured? name scope) + (-> Text Scope Bool) + (|> scope + (get@ [#;captured #;mappings]) + (&;pl-contains? name))) + +(def: (get-captured name scope) + (-> Text Scope (Maybe [Type Ref])) + (loop [idx +0 + mappings (get@ [#;captured #;mappings] scope)] + (case mappings + #;Nil + #;None + + (#;Cons [_name [_source-type _source-ref]] mappings') + (if (text/= name _name) + (#;Some [_source-type (#;Captured idx)]) + (recur (n.inc idx) mappings'))))) + +(def: (is-ref? name scope) + (-> Text Scope Bool) + (or (is-local? name scope) + (is-captured? name scope))) + +(def: (get-ref name scope) + (-> Text Scope (Maybe [Type Ref])) + (case (get-local name scope) + (#;Some type) + (#;Some type) + + _ + (get-captured name scope))) + +(def: #export (find name) + (-> Text (Meta (Maybe [Type Ref]))) + (function [compiler] + (let [[inner outer] (|> compiler + (get@ #;scopes) + (list;split-with (|>. (is-ref? name) not)))] + (case outer + #;Nil + (#;Right [compiler #;None]) + + (#;Cons top-outer _) + (let [[ref-type init-ref] (maybe;default (undefined) + (get-ref name top-outer)) + [ref inner'] (list/fold (: (-> Scope [Ref (List Scope)] [Ref (List Scope)]) + (function [scope ref+inner] + [(#;Captured (get@ [#;captured #;counter] scope)) + (#;Cons (update@ #;captured + (: (-> Captured Captured) + (|>. (update@ #;counter n.inc) + (update@ #;mappings (&;pl-put name [ref-type (product;left ref+inner)])))) + scope) + (product;right ref+inner))])) + [init-ref #;Nil] + (list;reverse inner)) + scopes (list/compose inner' outer)] + (#;Right [(set@ #;scopes scopes compiler) + (#;Some [ref-type ref])])) + )))) + +(def: #export (with-local [name type] action) + (All [a] (-> [Text Type] (Meta a) (Meta a))) + (function [compiler] + (case (get@ #;scopes compiler) + (#;Cons head tail) + (let [old-mappings (get@ [#;locals #;mappings] head) + new-var-id (get@ [#;locals #;counter] head) + new-head (update@ #;locals + (: (-> Locals Locals) + (|>. (update@ #;counter n.inc) + (update@ #;mappings (&;pl-put name [type new-var-id])))) + head)] + (case (meta;run' (set@ #;scopes (#;Cons new-head tail) compiler) + action) + (#e;Success [compiler' output]) + (case (get@ #;scopes compiler') + (#;Cons head' tail') + (let [scopes' (#;Cons (set@ #;locals (get@ #;locals head) head') + tail')] + (#e;Success [(set@ #;scopes scopes' compiler') + output])) + + _ + (error! "Invalid scope alteration.")) + + (#e;Error error) + (#e;Error error))) + + _ + (#e;Error "Cannot create local binding without a scope.")) + )) + +(do-template [ ] + [(def: + (Bindings Text [Type ]) + {#;counter +0 + #;mappings (list)})] + + [init-locals Nat] + [init-captured Ref] + ) + +(def: (scope parent-name child-name) + (-> (List Text) Text Scope) + {#;name (list& child-name parent-name) + #;inner +0 + #;locals init-locals + #;captured init-captured}) + +(def: #export (with-scope name action) + (All [a] (-> Text (Meta a) (Meta a))) + (function [compiler] + (let [parent-name (case (get@ #;scopes compiler) + #;Nil + (list) + + (#;Cons top _) + (get@ #;name top))] + (case (action (update@ #;scopes + (|>. (#;Cons (scope parent-name name))) + compiler)) + (#e;Error error) + (#e;Error error) + + (#e;Success [compiler' output]) + (#e;Success [(update@ #;scopes + (|>. list;tail (maybe;default (list))) + compiler') + output]) + )) + )) + +(def: #export next-local + (Meta Nat) + (function [compiler] + (case (get@ #;scopes compiler) + #;Nil + (#e;Error "Cannot get next reference when there is no scope.") + + (#;Cons top _) + (#e;Success [compiler (get@ [#;locals #;counter] top)])))) diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux index 30704a2d2..4571a8875 100644 --- a/new-luxc/source/luxc/lang/synthesis/expression.lux +++ b/new-luxc/source/luxc/lang/synthesis/expression.lux @@ -10,8 +10,7 @@ [dict #+ Dict])) (meta [code] ["s" syntax])) - (luxc ["&" base] - (lang ["la" analysis] + (luxc (lang ["la" analysis] ["ls" synthesis] (synthesis [";S" case] [";S" function] diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 5b11a8e39..85eed9ba1 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -12,14 +12,13 @@ [host] [io] (world [file #+ File])) - (luxc ["&" base] - [";L" host] - (host [";H" macro] - ["$" jvm]) + (luxc ["&" lang] ["&;" io] - ["&;" module] - ["&;" eval] - (lang ["&;" syntax] + (lang [";L" module] + [";L" host] + (host [";H" macro] + ["$" jvm]) + ["&;" syntax] (analysis [";A" expression] [";A" common]) (synthesis [";S" expression]) @@ -27,7 +26,8 @@ [";T" statement] [";T" common] [";T" expression] - [";T" eval])) + [";T" eval]) + ["&;" eval]) )) (def: analyse @@ -160,7 +160,7 @@ [#let [init-cursor [file-name +1 +0]] output (&;with-source-code [init-cursor +0 source-code] action) - _ (&module;flag-compiled! module-name)] + _ (moduleL;flag-compiled! module-name)] (wrap output))) (def: (parse current-module) @@ -174,15 +174,15 @@ (#e;Success [(set@ #;source source' compiler) output])))) -(def: (translate-module source-dirs module-name target-dir compiler) - (-> (List File) Text File Compiler (T;Task Compiler)) +(def: (translate-module source-dirs target-dir module-name compiler) + (-> (List File) File Text Compiler (T;Task Compiler)) (do T;Monad [_ (&io;prepare-module target-dir module-name) [file-name file-content] (&io;read-module source-dirs module-name) #let [module-hash (text/hash file-content)]] (case (meta;run' compiler (do meta;Monad - [[_ artifacts _] (&module;with-module module-hash module-name + [[_ artifacts _] (moduleL;with-module module-hash module-name (commonT;with-artifacts (with-active-compilation [module-name file-name @@ -193,14 +193,10 @@ #let [[cursor _] code]] (&;with-cursor cursor (translate code)))))))] - (wrap artifacts) - ## (&module;translate-descriptor module-name) - )) - (#e;Success [compiler artifacts ## module-descriptor - ]) + (wrap artifacts))) + (#e;Success [compiler artifacts]) (do @ - [## _ (&io;write-module module-name module-descriptor) - _ (monad;map @ (function [[class-name class-bytecode]] + [_ (monad;map @ (function [[class-name class-bytecode]] (&io;write-file target-dir class-name class-bytecode)) (dict;entries artifacts))] (wrap compiler)) @@ -236,8 +232,8 @@ #;scope-type-vars (list) #;host (:! Void host)}) -(def: #export (translate-program program target sources) - (-> Text File (List File) (T;Task Unit)) +(def: #export (translate-program sources target program) + (-> (List File) File Text (T;Task Unit)) (do T;Monad [compiler (|> (case (runtimeT;translate (init-compiler (io;run hostL;init-host))) (#e;Error error) @@ -250,7 +246,7 @@ _ (&io;write-file target hostL;function-class function-bc)] (wrap compiler))) (: (T;Task Compiler)) - (:: @ map (translate-module sources prelude target)) (:: @ join) - (:: @ map (translate-module sources program target)) (:: @ join)) + (:: @ map (translate-module sources target prelude)) (:: @ join) + (:: @ map (translate-module sources target program)) (:: @ join)) #let [_ (log! "Compilation complete!")]] (wrap []))) diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux index cb0aa2198..e3052c77d 100644 --- a/new-luxc/source/luxc/lang/translation/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -4,12 +4,12 @@ ["ex" exception #+ exception:]) (data text/format) [meta "meta/" Monad]) - (luxc ["_" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$i" inst])) - (lang ["ls" synthesis])) + (luxc ["_" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst])) + ["ls" synthesis])) [../runtime]) (def: $Object $;Type ($t;class "java.lang.Object" (list))) diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux index 4ec487d86..49e135709 100644 --- a/new-luxc/source/luxc/lang/translation/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux @@ -10,11 +10,11 @@ [host] (world [blob #+ Blob] [file #+ File])) - (luxc (lang [";L" variable #+ Register]) - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])))) + (luxc (lang [";L" variable #+ Register] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst]))))) (host;import org.objectweb.asm.Opcodes (#static V1_6 int)) diff --git a/new-luxc/source/luxc/lang/translation/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/eval.jvm.lux index 9514741f8..3c4eea048 100644 --- a/new-luxc/source/luxc/lang/translation/eval.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/eval.jvm.lux @@ -4,12 +4,12 @@ (data text/format) [meta] [host #+ do-to]) - (luxc ["&" base] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] + (luxc ["&" lang] + (lang (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] ["ls" synthesis] (translation [";T" common])) )) diff --git a/new-luxc/source/luxc/lang/translation/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/expression.jvm.lux index fa5f54647..d592c5001 100644 --- a/new-luxc/source/luxc/lang/translation/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/expression.jvm.lux @@ -7,9 +7,10 @@ text/format) [meta] (meta ["s" syntax])) - (luxc ["&" base] - (host ["$" jvm]) - (lang ["ls" synthesis] + (luxc ["&" lang] + (lang [";L" variable #+ Variable Register] + (host ["$" jvm]) + ["ls" synthesis] (translation [";T" common] [";T" primitive] [";T" structure] @@ -17,8 +18,7 @@ [";T" procedure] [";T" function] [";T" reference] - [";T" case]) - [";L" variable #+ Variable Register]))) + [";T" case])))) (exception: #export Unrecognized-Synthesis) diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux index 0247b3d7f..d12eca16e 100644 --- a/new-luxc/source/luxc/lang/translation/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux @@ -5,13 +5,13 @@ text/format (coll [list "list/" Functor Monoid])) [meta]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] + (luxc ["&" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] ["ls" synthesis] (translation [";T" common] [";T" runtime] diff --git a/new-luxc/source/luxc/lang/translation/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux index 6e51d7eed..b5497236f 100644 --- a/new-luxc/source/luxc/lang/translation/loop.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/loop.jvm.lux @@ -5,13 +5,13 @@ text/format (coll [list "list/" Functor Monoid])) [meta]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] + (luxc ["&" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] ["ls" synthesis] (translation [";T" common] [";T" runtime] diff --git a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux index f795a2980..f059aa8da 100644 --- a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux @@ -3,12 +3,12 @@ (lux (control monad) (data text/format) [meta "meta/" Monad]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$i" inst] - ["$t" type])) - (lang ["la" analysis] + (luxc ["&" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$i" inst] + ["$t" type])) + ["la" analysis] ["ls" synthesis] (translation [";T" common]))) [../runtime]) diff --git a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux index 733f630d5..917edd78d 100644 --- a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux @@ -5,9 +5,9 @@ (data [maybe] text/format (coll [dict]))) - (luxc ["&" base] - (host ["$" jvm]) - (lang ["ls" synthesis])) + (luxc ["&" lang] + (lang (host ["$" jvm]) + ["ls" synthesis])) (. ["./;" common] ["./;" host])) diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux index 9a01622ae..3cab88e48 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -12,13 +12,13 @@ (meta [code] ["s" syntax #+ syntax:]) [host]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] + (luxc ["&" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] ["ls" synthesis] (translation [";T" runtime] [";T" case] diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux index e45c0b911..8a28e3cf7 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux @@ -14,13 +14,13 @@ (meta [code] ["s" syntax #+ syntax:]) [host]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] + (luxc ["&" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] (analysis (procedure ["&;" host])) ["ls" synthesis])) ["@" ../common]) diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux index e9c445dd4..b714558b8 100644 --- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux @@ -4,12 +4,12 @@ (data [text "text/" Hash] text/format) [meta "meta/" Monad]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$i" inst])) - (lang ["ls" synthesis] + (luxc ["&" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst])) + ["ls" synthesis] [";L" variable #+ Variable] (translation [";T" common])))) diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux index 70450be91..fa6d6dcad 100644 --- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux @@ -6,13 +6,13 @@ [math] [meta] [host]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] + (luxc ["&" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] ["ls" synthesis] (translation [";T" common])))) diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux index 718175df1..232519d8b 100644 --- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux @@ -9,15 +9,15 @@ (coll [list "list/" Functor Fold])) [meta] [host]) - (luxc ["&" base] - ["&;" scope] - ["&;" module] + (luxc ["&" lang] ["&;" io] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang (translation [";T" eval] + (lang (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["&;" scope] + ["&;" module] + (translation [";T" eval] [";T" common])))) (exception: #export Invalid-Definition-Value) diff --git a/new-luxc/source/luxc/lang/translation/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/structure.jvm.lux index 68219b87c..2c04eaa0c 100644 --- a/new-luxc/source/luxc/lang/translation/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/structure.jvm.lux @@ -6,13 +6,13 @@ (coll [list])) [meta] [host #+ do-to]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] + (luxc ["&" lang] + (lang [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] ["ls" synthesis] (translation [";T" common]))) [../runtime]) diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux deleted file mode 100644 index 7b60af8f2..000000000 --- a/new-luxc/source/luxc/module.lux +++ /dev/null @@ -1,173 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [text "text/" Eq] - text/format - ["e" error] - (coll [list "list/" Fold Functor])) - [meta] - (meta [code])) - (luxc ["&" base] - ["&;" scope])) - -(exception: #export Unknown-Module) -(exception: #export Cannot-Declare-Tag-Twice) -(exception: #export Cannot-Declare-Tags-For-Unnamed-Type) -(exception: #export Cannot-Declare-Tags-For-Foreign-Type) - -(def: (new-module hash) - (-> Nat Module) - {#;module-hash hash - #;module-aliases (list) - #;defs (list) - #;imports (list) - #;tags (list) - #;types (list) - #;module-annotations (' {}) - #;module-state #;Active}) - -(def: #export (define (^@ full-name [module-name def-name]) - definition) - (-> Ident Def (Meta Unit)) - (function [compiler] - (case (&;pl-get module-name (get@ #;modules compiler)) - (#;Some module) - (case (&;pl-get def-name (get@ #;defs module)) - #;None - (#e;Success [(update@ #;modules - (&;pl-put module-name - (update@ #;defs - (: (-> (List [Text Def]) (List [Text Def])) - (|>. (#;Cons [def-name definition]))) - module)) - compiler) - []]) - - (#;Some already-existing) - (#e;Error (format "Cannot re-define definiton: " (%ident full-name)))) - - #;None - (#e;Error (format "Cannot define in unknown module: " module-name))))) - -(def: #export (create hash name) - (-> Nat Text (Meta Module)) - (function [compiler] - (let [module (new-module hash)] - (#e;Success [(update@ #;modules - (&;pl-put name module) - compiler) - module])))) - -(def: #export (with-module hash name action) - (All [a] (-> Nat Text (Meta a) (Meta [Module a]))) - (do meta;Monad - [_ (create hash name) - output (&;with-current-module name - (&scope;with-scope name action)) - module (meta;find-module name)] - (wrap [module output]))) - -(do-template [ ] - [(def: #export ( module-name) - (-> Text (Meta Unit)) - (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl-get module-name)) - (#;Some module) - (let [active? (case (get@ #;module-state module) - #;Active true - _ false)] - (if active? - (#e;Success [(update@ #;modules - (&;pl-put module-name (set@ #;module-state module)) - compiler) - []]) - (#e;Error "Can only change the state of a currently-active module."))) - - #;None - (#e;Error (format "Module does not exist: " module-name))))) - (def: #export ( module-name) - (-> Text (Meta Bool)) - (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl-get module-name)) - (#;Some module) - (#e;Success [compiler - (case (get@ #;module-state module) - true - _ false)]) - - #;None - (#e;Error (format "Module does not exist: " module-name))) - ))] - - [flag-active! active? #;Active] - [flag-compiled! compiled? #;Compiled] - [flag-cached! cached? #;Cached] - ) - -(do-template [ ] - [(def: ( module-name) - (-> Text (Meta )) - (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl-get module-name)) - (#;Some module) - (#e;Success [compiler (get@ module)]) - - #;None - (meta;run compiler (&;throw Unknown-Module module-name))) - ))] - - [tags-by-module #;tags (List [Text [Nat (List Ident) Bool Type]])] - [types-by-module #;types (List [Text [(List Ident) Bool Type]])] - [module-hash #;module-hash Nat] - ) - -(def: (ensure-undeclared-tags module-name tags) - (-> Text (List Text) (Meta Unit)) - (do meta;Monad - [bindings (tags-by-module module-name) - _ (monad;map @ - (function [tag] - (case (&;pl-get tag bindings) - #;None - (wrap []) - - (#;Some _) - (&;throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n" - " Tag: " tag)))) - tags)] - (wrap []))) - -(def: #export (declare-tags tags exported? type) - (-> (List Text) Bool Type (Meta Unit)) - (do meta;Monad - [current-module meta;current-module-name - [type-module type-name] (case type - (#;Named type-ident _) - (wrap type-ident) - - _ - (&;throw Cannot-Declare-Tags-For-Unnamed-Type - (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" - "Type: " (%type type)))) - _ (ensure-undeclared-tags current-module tags) - _ (&;assert Cannot-Declare-Tags-For-Foreign-Type - (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" - "Type: " (%type type)) - (text/= current-module type-module))] - (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl-get current-module)) - (#;Some module) - (let [namespaced-tags (list/map (|>. [current-module]) tags)] - (#e;Success [(update@ #;modules - (&;pl-update current-module - (|>. (update@ #;tags (function [tag-bindings] - (list/fold (function [[idx tag] table] - (&;pl-put tag [idx namespaced-tags exported? type] table)) - tag-bindings - (list;enumerate tags)))) - (update@ #;types (&;pl-put type-name [namespaced-tags exported? type])))) - compiler) - []])) - #;None - (meta;run compiler (&;throw Unknown-Module current-module)))))) diff --git a/new-luxc/source/luxc/scope.lux b/new-luxc/source/luxc/scope.lux deleted file mode 100644 index 165399c8f..000000000 --- a/new-luxc/source/luxc/scope.lux +++ /dev/null @@ -1,173 +0,0 @@ -(;module: - lux - (lux (control monad) - (data [text "text/" Eq] - text/format - [maybe "maybe/" Monad] - [product] - ["e" error] - (coll [list "list/" Functor Fold Monoid])) - [meta]) - (luxc ["&" base] - (lang [";L" variable #+ Variable]))) - -(type: Locals (Bindings Text [Type Nat])) -(type: Captured (Bindings Text [Type Ref])) - -(def: (is-local? name scope) - (-> Text Scope Bool) - (|> scope - (get@ [#;locals #;mappings]) - (&;pl-contains? name))) - -(def: (get-local name scope) - (-> Text Scope (Maybe [Type Ref])) - (|> scope - (get@ [#;locals #;mappings]) - (&;pl-get name) - (maybe/map (function [[type value]] - [type (#;Local value)])))) - -(def: (is-captured? name scope) - (-> Text Scope Bool) - (|> scope - (get@ [#;captured #;mappings]) - (&;pl-contains? name))) - -(def: (get-captured name scope) - (-> Text Scope (Maybe [Type Ref])) - (loop [idx +0 - mappings (get@ [#;captured #;mappings] scope)] - (case mappings - #;Nil - #;None - - (#;Cons [_name [_source-type _source-ref]] mappings') - (if (text/= name _name) - (#;Some [_source-type (#;Captured idx)]) - (recur (n.inc idx) mappings'))))) - -(def: (is-ref? name scope) - (-> Text Scope Bool) - (or (is-local? name scope) - (is-captured? name scope))) - -(def: (get-ref name scope) - (-> Text Scope (Maybe [Type Ref])) - (case (get-local name scope) - (#;Some type) - (#;Some type) - - _ - (get-captured name scope))) - -(def: #export (find name) - (-> Text (Meta (Maybe [Type Ref]))) - (function [compiler] - (let [[inner outer] (|> compiler - (get@ #;scopes) - (list;split-with (|>. (is-ref? name) not)))] - (case outer - #;Nil - (#;Right [compiler #;None]) - - (#;Cons top-outer _) - (let [[ref-type init-ref] (maybe;default (undefined) - (get-ref name top-outer)) - [ref inner'] (list/fold (: (-> Scope [Ref (List Scope)] [Ref (List Scope)]) - (function [scope ref+inner] - [(#;Captured (get@ [#;captured #;counter] scope)) - (#;Cons (update@ #;captured - (: (-> Captured Captured) - (|>. (update@ #;counter n.inc) - (update@ #;mappings (&;pl-put name [ref-type (product;left ref+inner)])))) - scope) - (product;right ref+inner))])) - [init-ref #;Nil] - (list;reverse inner)) - scopes (list/compose inner' outer)] - (#;Right [(set@ #;scopes scopes compiler) - (#;Some [ref-type ref])])) - )))) - -(def: #export (with-local [name type] action) - (All [a] (-> [Text Type] (Meta a) (Meta a))) - (function [compiler] - (case (get@ #;scopes compiler) - (#;Cons head tail) - (let [old-mappings (get@ [#;locals #;mappings] head) - new-var-id (get@ [#;locals #;counter] head) - new-head (update@ #;locals - (: (-> Locals Locals) - (|>. (update@ #;counter n.inc) - (update@ #;mappings (&;pl-put name [type new-var-id])))) - head)] - (case (meta;run' (set@ #;scopes (#;Cons new-head tail) compiler) - action) - (#e;Success [compiler' output]) - (case (get@ #;scopes compiler') - (#;Cons head' tail') - (let [scopes' (#;Cons (set@ #;locals (get@ #;locals head) head') - tail')] - (#e;Success [(set@ #;scopes scopes' compiler') - output])) - - _ - (error! "Invalid scope alteration.")) - - (#e;Error error) - (#e;Error error))) - - _ - (#e;Error "Cannot create local binding without a scope.")) - )) - -(do-template [ ] - [(def: - (Bindings Text [Type ]) - {#;counter +0 - #;mappings (list)})] - - [init-locals Nat] - [init-captured Ref] - ) - -(def: (scope parent-name child-name) - (-> (List Text) Text Scope) - {#;name (list& child-name parent-name) - #;inner +0 - #;locals init-locals - #;captured init-captured}) - -(def: #export (with-scope name action) - (All [a] (-> Text (Meta a) (Meta a))) - (function [compiler] - (let [parent-name (case (get@ #;scopes compiler) - #;Nil - (list) - - (#;Cons top _) - (get@ #;name top))] - (case (action (update@ #;scopes - (|>. (#;Cons (scope parent-name name))) - compiler)) - (#e;Error error) - (#e;Error error) - - (#e;Success [compiler' output]) - (#e;Success [(update@ #;scopes - (|>. list;tail (maybe;default (list))) - compiler') - output]) - )) - )) - -(def: #export next-local - (Meta Nat) - (function [compiler] - (case (get@ #;scopes compiler) - #;Nil - (#e;Error "Cannot get next reference when there is no scope.") - - (#;Cons top _) - (#e;Success [compiler (get@ [#;locals #;counter] top)])))) -- cgit v1.2.3