diff options
| -rw-r--r-- | source/lux/codata/state.lux | 10 | ||||
| -rw-r--r-- | source/lux/control/enum.lux | 2 | ||||
| -rw-r--r-- | source/lux/data/io.lux | 5 | ||||
| -rw-r--r-- | source/lux/data/number/int.lux | 2 | ||||
| -rw-r--r-- | source/lux/host/jvm.lux | 330 | ||||
| -rw-r--r-- | source/lux/meta/syntax.lux | 15 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 62 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 307 | ||||
| -rw-r--r-- | src/lux/base.clj | 5 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 24 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 166 | ||||
| -rw-r--r-- | src/lux/host.clj | 69 | ||||
| -rw-r--r-- | src/lux/type.clj | 6 |
13 files changed, 607 insertions, 396 deletions
diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index de7220a45..311fce320 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -23,11 +23,17 @@ (Monad (State s))) (def _functor State/Functor) - (def (wrap x) + (def (wrap a) (lambda [state] - [state x])) + [state a])) (def (join mma) (lambda [state] (let [[state' ma] (mma state)] (ma state'))))) + +## [Functions] +(def #export (run-state state action) + (All [s a] (-> s (State s a) a)) + (let [[state' output] (action state)] + output)) diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux index c54eab75b..4ce368e96 100644 --- a/source/lux/control/enum.lux +++ b/source/lux/control/enum.lux @@ -13,7 +13,7 @@ (: (-> e e) pred)) ## [Functions] -(def #export (range' <= succ from to) +(def (range' <= succ from to) (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) (if (<= from to) (#;Cons from (range' <= succ (succ from) to)) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index a0bfda3e0..973d37e38 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -35,3 +35,8 @@ (def (join mma) (mma []))) + +## [Functions] +(def #export (run-io io) + (All [a] (-> (IO a) a)) + (io [])) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index 20ea5fced..ea58cac17 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -58,7 +58,7 @@ [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) ## Enum -(defstruct Int/Enum (EN;Enum Int) +(defstruct #export Int/Enum (EN;Enum Int) (def _ord Int/Ord) (def succ (lambda [n] (:: Int/Number (N;+ n 1)))) (def pred (lambda [n] (:: Int/Number (N;- n 1))))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 710bc9a20..1e903ad1d 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -6,98 +6,202 @@ (;import lux (lux (control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do seq%))) + (monad #as M #refer (#only do seq%)) + (enum #as E)) (data (list #refer #all #open ("" List/Functor List/Fold)) - (number/int #refer #all #open ("i:" Int/Ord)) + (number/int #refer #all #open ("i:" Int/Ord Int/Number)) maybe - tuple) + tuple + (text #open ("text:" Text/Monoid))) (meta lux ast syntax))) (open List/Monad "list:") +## [Types] +(defsyntax #export (Array [dimensions (?^ nat^)] type) + (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner))))) + type + (repeat (? 1 dimensions) []))))) + ## [Utils] +## Types +(deftype StackFrame (^ java.lang.StackTraceElement)) +(deftype StackTrace (Array StackFrame)) + +(deftype Modifier Text) +(deftype JvmType Text) + +(deftype MemberDecl + (& #member-modifiers (List Modifier) + #member-name Text)) + +(deftype FieldDecl + JvmType) + +(deftype MethodDecl + (& #method-inputs (List JvmType) + #method-output JvmType)) + +(deftype ArgDecl + (& #arg-name Text + #arg-type JvmType)) + +(deftype MethodDef + (& #method-vars (List ArgDecl) + #return-type JvmType + #return-body AST)) + +(deftype ExpectedInput + (& #opt-input? Bool + #input-type JvmType)) + +(deftype ExpectedOutput + (& #ex-output? Bool + #opt-output? Bool + #output-type JvmType)) + +## Functions +(def (prepare-args args) + (-> (List ExpectedInput) (Lux (, (List AST) (List AST) (List AST) (List Text)))) + (do Lux/Monad + [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) + #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) + (lambda [[[opt? arg-class] var]] + (if opt? + [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) + (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) + (case (~ var) + (#;Some (~ var)) (~ var) + #;None ;_jvm_null))))] + [(` (^ (~ (symbol$ ["" arg-class])))) + (@list)]))) + (zip2 args vars)) + var-types (map first pairings) + var-rebinds (map second pairings) + arg-classes (map second args)]] + (wrap [vars var-types (list:join var-rebinds) arg-classes]))) + ## Parsers +(def member-decl^ + (Parser MemberDecl) + (&^ (*^ local-tag^) local-symbol^)) + (def method-decl^ - (Parser (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^] - (wrap [modifiers name inputs output])))) + (Parser (, MemberDecl MethodDecl)) + (form^ (&^ member-decl^ + (&^ (tuple^ (*^ local-symbol^)) + local-symbol^)))) (def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^] - (wrap [modifiers name class])))) + (Parser (, MemberDecl FieldDecl)) + (form^ (&^ member-decl^ + local-symbol^))) (def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^] - (wrap [arg-name arg-class])))) + (Parser ArgDecl) + (form^ (&^ local-symbol^ local-symbol^))) (def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text AST)) + (Parser (, MemberDecl MethodDef)) (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ + [=member-decl member-decl^ inputs (tuple^ (*^ arg-decl^)) output local-symbol^ body id^] - (wrap [modifiers name inputs output body])))) + (wrap [=member-decl [inputs output body]])))) -(def opt-arg^ - (Parser (, Bool Text)) +(def exp-input^ + (Parser ExpectedInput) (&^ (tag?^ ["" "?"]) local-symbol^)) +(def exp-output^ + (Parser ExpectedOutput) + (do Parser/Monad + [ex? (tag?^ ["" "!"]) + opt? (tag?^ ["" "?"]) + return local-symbol^] + (wrap [ex? opt? return]))) + +## Generators +(def (gen-method-decl [[modifiers name] [inputs output]]) + (-> (, MemberDecl MethodDecl) AST) + (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))) + +(def (gen-field-decl [[modifiers name] class]) + (-> (, MemberDecl FieldDecl) AST) + (` ((~ (text$ name)) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))) + +(def (gen-arg-decl [name type]) + (-> ArgDecl AST) + (form$ (@list (symbol$ ["" name]) (text$ type)))) + +(def (gen-method-def [[modifiers name] [inputs output body]]) + (-> (, MemberDecl MethodDef) AST) + (` ((~ (text$ name)) + [(~@ (map gen-arg-decl inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))) + +(def (gen-expected-output [ex? opt? output] body) + (-> ExpectedOutput AST (, AST AST)) + (let [type (` (^ (~ (symbol$ ["" output])))) + [body type] (if opt? + [(` (;;??? (~ body))) + (` (Maybe (~ type)))] + [body type]) + [body type] (if ex? + [(` (;;try (~ body))) + (` (Either Text (~ type)))] + [body type])] + [body type])) + +## [Functions] +(def (stack-trace->text trace) + (-> StackTrace Text) + (let [size (_jvm_arraylength trace) + idxs (E;range Int/Enum 0 (i:+ -1 size))] + (|> idxs + (map (: (-> Int Text) + (lambda [idx] + (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload "java.lang.StackTraceElement" trace idx) [])))) + (interpose "\n") + (foldL text:++ "") + ))) + +(def (get-stack-trace t) + (-> (^ java.lang.Throwable) StackTrace) + (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t [])) + +(def #export (throwable->text t) + ($ text:++ + (_jvm_invokevirtual "java.lang.Object" "toString" [] t []) + "\n" + (|> t get-stack-trace stack-trace->text))) + ## [Syntax] (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ members'))))))) + (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + (~@ (map gen-method-decl members))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [fields (*^ field-decl^)] [methods (*^ method-def^)]) - (do Lux/Monad - [current-module get-module-name - #let [fields' (map (: (-> (, (List Text) Text Text) AST) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (text$ name)) - (~ (text$ class)) - [(~@ (map text$ modifiers))]))))) - fields) - methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text AST) AST) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (text$ name)) - [(~@ (map (: (-> (, Text Text) AST) - (lambda [in] - (let [[left right] in] - (form$ (@list (symbol$ ["" left]) - (text$ right)))))) - inputs))] - (~ (text$ output)) - [(~@ (map text$ modifiers))] - (~ body)))))) - methods)]] - (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) + (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ (map gen-field-decl fields))] + [(~@ (map gen-method-def methods))]))))) + +(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [methods (*^ method-def^)]) + (emit (@list (` (;_jvm_anon-class (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ (map gen-method-def methods))]))))) (defsyntax #export (program [args symbol^] body) (emit (@list (` (;_jvm_program (~ (symbol$ args)) @@ -105,24 +209,16 @@ (defsyntax #export (??? expr) (do Lux/Monad - [g!val (gensym "")] - (emit (@list (` (let [(~ g!val) (~ expr)] - (if (;_jvm_null? (~ g!val)) + [g!temp (gensym "")] + (wrap (@list (` (let [(~ g!temp) (~ expr)] + (if (;_jvm_null? (~ g!temp)) #;None - (#;Some (~ g!val))))))))) + (#;Some (~ g!temp))))))))) (defsyntax #export (try expr) (emit (@list (` (;_jvm_try (#;Right (~ expr)) (~ (' (_jvm_catch "java.lang.Exception" e - (#;Left (_jvm_invokevirtual "java.lang.Throwable" "getMessage" [] e [])))))))))) - -(defsyntax #export (Array [dimensions (?^ int^)] type) - (let [dimensions (? 1 dimensions)] - (if (i:> dimensions 0) - (emit (@list (foldL (lambda [inner _] (` (#;DataT "Array" (@list (~ inner))))) - type - (repeat dimensions [])))) - (fail "Array must have positive dimension.")))) + (#;Left (throwable->text e)))))))))) (defsyntax #export (instance? [class local-symbol^] obj) (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) @@ -142,64 +238,26 @@ (defsyntax #export (null? obj) (emit (@list (` (;_jvm_null? (~ obj)))))) -(def (prepare-args args) - (-> (List (, Bool Text)) (Lux (, (List AST) (List AST) (List AST) (List Text)))) +(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [ex? (tag?^ ["" "!"])]) (do Lux/Monad - [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) - #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) - (lambda [[[opt? arg-class] var]] - (if opt? - [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) - (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) - (case (~ var) - (#;Some (~ var)) (~ var) - #;None ;_jvm_null))))] - [(` (^ (~ (symbol$ ["" arg-class])))) - (@list)]))) - (zip2 args vars)) - var-types (map first pairings) - var-rebinds (map second pairings) - arg-classes (map second args)]] - (wrap [vars var-types (list:join var-rebinds) arg-classes]))) - -(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ opt-arg^))]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args)] - (case vars - (\ (@list)) - (do Lux/Monad - [g!_ (gensym "")] - (wrap (@list (` (: (-> (,) (^ (~ (symbol$ ["" class])))) - (lambda [(~ g!_)] - (;_jvm_new (~ (text$ class)) [] []))))))) - - _ - (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) - (lambda [[(~@ vars)]] - (let [(~@ var-rebinds)] - (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))))))) - ))) + [[vars var-types var-rebinds arg-classes] (prepare-args args) + #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)])) + new-expr (if ex? + (` (try (~ new-expr))) + new-expr)]] + (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) + (lambda [[(~@ vars)]] + (let [(~@ var-rebinds)] + (~ new-expr))))))))) (do-template [<name> <op>] - [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] - [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) + [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] + [expected-output exp-output^]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) g!self (gensym "self") - g!temp (gensym "temp") - #let [return-type (` (^ (~ (symbol$ ["" return])))) - body (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])) - [body return-type] (if opt? - [(` (let [(~ g!temp) (~ body)] - (if (;_jvm_null? (~ g!temp)) - #;None - (#;Some (~ g!temp))))) - (` (Maybe (~ return-type)))] - [body return-type]) - [body return-type] (if ex? - [(` (try (~ body))) - (` (Either Text (~ return-type)))] - [body return-type])]] + #let [[body return-type] (gen-expected-output expected-output + (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])))]] (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) (lambda [[(~@ vars)] (~ g!self)] (let [(~@ var-rebinds)] @@ -210,24 +268,12 @@ [invoke-interface$ ;_jvm_invokeinterface] ) -(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] - [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) +(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] + [expected-output exp-output^]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) - g!temp (gensym "temp") - #let [return-type (` (^ (~ (symbol$ ["" return])))) - body (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])) - [body return-type] (if opt? - [(` (let [(~ g!temp) (~ body)] - (if (;_jvm_null? (~ g!temp)) - #;None - (#;Some (~ g!temp))))) - (` (Maybe (~ return-type)))] - [body return-type]) - [body return-type] (if ex? - [(` (try (~ body))) - (` (Either Text (~ return-type)))] - [body return-type])]] + #let [[body return-type] (gen-expected-output expected-output + (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])))]] (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) (lambda [[(~@ vars)]] (let [(~@ var-rebinds)] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index a28fa6d27..d47780798 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -13,7 +13,7 @@ (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) (list #refer #all #open ("" List/Fold)) - (number (int #open ("i" Int/Eq)) + (number (int #open ("i" Int/Ord)) (real #open ("r" Real/Eq)))))) ## [Utils] @@ -84,6 +84,19 @@ [ tag^ Ident #;TagS] ) +(def #export (assert v tokens) + (-> Bool (Parser (,))) + (if v + (#;Some [tokens []]) + #;None)) + +(def #export nat^ + (Parser Int) + (do Parser/Monad + [n int^ + _ (assert (i>= n 0))] + (wrap n))) + (do-template [<name> <tag>] [(def #export (<name> tokens) (Parser Text) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 03709b226..a412362d9 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -71,85 +71,85 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) (&&host/analyse-jvm-znewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-zastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-zaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-bnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-bastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-baload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-snewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-sastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-saload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-inewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-iastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-iaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-lnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-lastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-laload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-fnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-fastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-faload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-dnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-dastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-daload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-cnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-castore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-caload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-anewarray analyse ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil))))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))) (&&host/analyse-jvm-aastore analyse ?class ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))) (&&host/analyse-jvm-aaload analyse ?class ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) @@ -173,6 +173,14 @@ (|do [=supers (&/map% extract-text ?supers)] (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil)))))) + (|do [=interfaces (&/map% extract-text ?interfaces)] + (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces ?methods)) + ;; Programs (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] (&/$Cons [_ (&/$SymbolS "" ?args)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index db04a60c0..f6963d8bf 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -12,7 +12,9 @@ [type :as &type] [host :as &host]) (lux.analyser [base :as &&] - [env :as &&env]))) + [lambda :as &&lambda] + [env :as &&env]) + [lux.compiler.base :as &c!base])) ;; [Utils] (defn ^:private extract-text [ast] @@ -65,14 +67,6 @@ output))))) )) -(defn ^:private analyse-1+ [analyse token] - (&type/with-var - (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var token) - :let [[item type] =expr] - =type (&type/clean $var type)] - (return (&/T item =type)))))) - (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" (|case token @@ -215,7 +209,7 @@ (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T class method classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type class object] - (|do [=object (analyse-1+ analyse object) + (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] @@ -258,14 +252,14 @@ (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T class method classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type object] - (|do [=object (analyse-1+ analyse object) + (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null" &/Nil$)] + (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) @@ -280,18 +274,23 @@ (do-template [<class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>] (let [elem-type (&type/Data$ <class> &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type)) + length-type &type/Int + idx-type &type/Int] (defn <new-name> [analyse length] - (return (&/|list (&/T (&/V <new-tag> length) array-type)))) + (|do [=length (&&/analyse-1 analyse length-type length)] + (return (&/|list (&/T (&/V <new-tag> =length) array-type))))) (defn <load-name> [analyse array idx] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V <load-tag> (&/T =array idx)) elem-type))))) + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx)] + (return (&/|list (&/T (&/V <load-tag> (&/T =array =idx)) elem-type))))) (defn <store-name> [analyse array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V <store-tag> (&/T =array idx =elem)) array-type))))) + (return (&/|list (&/T (&/V <store-tag> (&/T =array =idx =elem)) array-type))))) ) "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore @@ -304,30 +303,35 @@ "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore ) -(defn analyse-jvm-anewarray [analyse class length] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class length)) array-type))))) - -(defn analyse-jvm-aaload [analyse class array idx] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array idx)) elem-type)))))) +(let [length-type &type/Int + idx-type &type/Int] + (defn analyse-jvm-anewarray [analyse class length] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=length (&&/analyse-1 analyse length-type length)] + (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class =length)) array-type)))))) + + (defn analyse-jvm-aaload [analyse class array idx] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx)] + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array =idx)) elem-type)))))) -(defn analyse-jvm-aastore [analyse class array idx elem] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array idx =elem)) array-type)))))) + (defn analyse-jvm-aastore [analyse class array idx elem] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem)] + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array =idx =elem)) array-type))))))) (let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] (defn analyse-jvm-arraylength [analyse array] (&type/with-var (fn [$var] (let [elem-type $var - array-type (&type/Data$ "Array" (&/|list elem-type))] + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array)] (return (&/|list (&/T (&/V &&/$jvm-arraylength =array) length-type))))))))) @@ -367,68 +371,85 @@ :concurrency nil} modifiers)) -(defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] - (|do [class-loader &/loader - abstract-methods (&/flat-map% (partial &host/abstract-methods class-loader) (&/Cons$ ?super-class ?interfaces)) - =fields (&/map% (fn [?field] - (|case ?field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Nil)))))] - (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] - (return {:name ?field-name - :modifiers =field-modifiers - :type ?field-type})) - - _ - (fail "[Analyser Error] Wrong syntax for field."))) - ?fields) - =methods (&/map% (fn [?method] - (|case ?method - [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?method-inputs)] - (&/$Cons [_ (&/$TextS ?method-output)] - (&/$Cons [_ (&/$TupleS ?method-modifiers)] - (&/$Cons ?method-body - (&/$Nil)))))))]] - (|do [=method-inputs (&/map% (fn [minput] - (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] - (&/$Cons [_ (&/$TextS ?input-type)] - (&/$Nil))))] - (return (&/T ?input-name ?input-type)) - - _ - (fail "[Analyser Error] Wrong syntax for method input."))) - ?method-inputs) - =method-modifiers (analyse-modifiers ?method-modifiers) - =method-body (&/with-scope (str ?name "_" ?idx) - (&/fold (fn [body* input*] - (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) - body*))) - (if (= "void" ?method-output) - (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) &/Nil$) ?method-body)) - (&/|reverse (if (:static? =method-modifiers) - =method-inputs - (&/Cons$ (&/T "this" ?super-class) - =method-inputs)))))] - (return {:name ?method-name - :modifiers =method-modifiers - :inputs (&/|map &/|second =method-inputs) - :output ?method-output - :body =method-body})) - - _ - (fail "[Analyser Error] Wrong syntax for method."))) - (&/enumerate ?methods)) - ;; Test for method completion +(defn ^:private analyse-field [field] + (|case field + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Nil)))))] + (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] + (return {:name ?field-name + :modifiers =field-modifiers + :type ?field-type})) + + _ + (fail "[Analyser Error] Wrong syntax for field."))) + +(defn ^:private analyse-method [analyse name owner-class method] + (|case method + [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons method-body + (&/$Nil)))))))]] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-inputs (&/map% (fn [minput] + (|case minput + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] + (&/$Cons [_ (&/$TextS input-type)] + (&/$Nil))))] + (return (&/T input-name input-type)) + + _ + (fail "[Analyser Error] Wrong syntax for method input."))) + method-inputs) + =method-body (&/fold (fn [body* input*] + (|let [[iname itype] input*] + (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) + body*))) + (if (= "void" method-output) + (&&/analyse-1+ analyse method-body) + (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body)) + (&/|reverse (&/Cons$ (&/T "this" owner-class) + =method-inputs)))] + (return {:name method-name + :modifiers =method-modifiers + :inputs (&/|map &/|second =method-inputs) + :output method-output + :body =method-body})) + + _ + (fail "[Analyser Error] Wrong syntax for method."))) + +(defn ^:private analyse-method-decl [method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Cons [_ (&/$TupleS modifiers)] + (&/$Nil))))))] + (|do [=inputs (&/map% extract-text inputs) + =modifiers (analyse-modifiers modifiers)] + (return {:name method-name + :modifiers =modifiers + :inputs =inputs + :output output})) + + _ + (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List ClassName) (List MethodDesc) (Lux (,)))" + (|do [abstract-methods (mandatory-methods supers) :let [methods-map (&/fold (fn [mmap mentry] (assoc mmap (:name mentry) mentry)) {} - =methods) + methods) missing-method (&/fold (fn [missing abs-meth] (|let [[am-name am-inputs] abs-meth] (or missing @@ -442,36 +463,74 @@ am-name)) am-name)))) nil - abstract-methods)] - _ (if (nil? missing-method) - (return nil) - (fail (str "[Analyser Error] Missing method: " missing-method))) - _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) - ;; :let [_ (prn 'analyse-jvm-class ?name ?super-class)] - ] - (return &/Nil$))) + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (fail (str "[Analyser Error] Missing method: " missing-method))))) + +(defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods] + (&/with-closure + (|do [module &/get-module-name + ;; :let [_ (prn 'analyse-jvm-class/_0)] + =fields (&/map% analyse-field fields) + ;; :let [_ (prn 'analyse-jvm-class/_1)] + =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + ;; :let [_ (prn 'analyse-jvm-class/_2)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-class/_3)] + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods nil))) + :let [_ (println 'DEF (str module "." name))]] + (return &/Nil$)))) (defn analyse-jvm-interface [analyse compile-token name supers methods] - (|do [=methods (&/map% (fn [method] - (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TextS output)] - (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Nil))))))] - (|do [=inputs (&/map% extract-text inputs) - =modifiers (analyse-modifiers modifiers)] - (return {:name method-name - :modifiers =modifiers - :inputs =inputs - :output output})) - - _ - (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - methods) - _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))] + (|do [module &/get-module-name + =methods (&/map% analyse-method-decl methods) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods))) + :let [_ (println 'DEF (str module "." name))]] (return &/Nil$))) +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [(&&/$captured _ _ source) _]] + source)) + +(let [captured-slot-modifier {:visibility "private" + :static? false + :final? false + :abstract? false + :concurrency nil} + captured-slot-type "java.lang.Object"] + (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods] + (&/with-closure + (|do [;; :let [_ (prn 'analyse-jvm-anon-class/_0 super-class)] + module &/get-module-name + scope &/get-scope-name + ;; :let [_ (prn 'analyse-jvm-anon-class/_1 super-class)] + :let [name (&host/location (&/|tail scope)) + anon-class (str module "." name)] + ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] + =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] + =captured &&env/captured-vars + :let [=fields (&/|map (fn [idx+capt] + {:name (str &c!base/closure-prefix (aget idx+capt 0)) + :modifiers captured-slot-modifier + :type captured-slot-type}) + (&/enumerate =captured)) + ;; _ (prn '=methods (&/adt->text (&/|map :body =methods))) + ;; =methods* (rename-captured-vars) + ] + :let [sources (&/|map captured-source =captured)] + ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] + ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured))) + :let [_ (println 'DEF anon-class)]] + (return (&/|list (&/T (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) (&type/Data$ anon-class (&/|list))))) + ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources) + )))) + (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] @@ -485,19 +544,17 @@ (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally (&/$None) (return &/None$) - (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] - (|do [=ex (analyse-1+ analyse ?ex) - :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable" &/Nil$) _type)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) + (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex)] + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) exo-type))))) (do-template [<name> <tag>] (defn <name> [analyse exo-type ?monitor] - (|do [=monitor (analyse-1+ analyse ?monitor) + (|do [=monitor (&&/analyse-1+ analyse ?monitor) _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 4c5d8ae44..0e164f5d2 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -749,10 +749,11 @@ (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + (let [old-writer (->> state (get$ $host) (get$ $writer)) + output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) + (return* (update$ $host #(set$ $writer old-writer %) ?state) ?value) _ diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index d6bbb17ae..048b9ee1d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -405,23 +405,6 @@ ) )) -(defn ^:private compile-statement [syntax] - (|case syntax - (&a/$def ?name ?body) - (&&lux/compile-def compile-expression ?name ?body) - - (&a/$declare-macro ?module ?name) - (&&lux/compile-declare-macro compile-expression ?module ?name) - - (&a/$jvm-program ?body) - (&&host/compile-jvm-program compile-expression ?body) - - (&a/$jvm-interface ?name ?supers ?methods) - (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) - (defn ^:private compile-token [syntax] (|case syntax (&a/$def ?name ?body) @@ -436,8 +419,8 @@ (&a/$jvm-interface ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) + (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods ??env) + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods ??env) _ (compile-expression syntax))) @@ -483,7 +466,8 @@ (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) + (|do [_ (&&cache/delete name) + _ (&a-module/enter-module name) _ (&/flag-active-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 83c769b4b..2ca613633 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -76,7 +76,7 @@ (&/$DataT "char" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - (&/$DataT _ (&/$Nil)) + (&/$DataT _ _) nil (&/$NamedT ?name ?type) @@ -290,16 +290,18 @@ (do-template [<prim-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>] (do (defn <new-name> [compile *type* ?length] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitIntInsn Opcodes/NEWARRAY <prim-type>))]] + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]] (return nil))) (defn <load-name> [compile *type* ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) (.visitInsn <load-op>) <wrapper>)]] (return nil))) @@ -307,9 +309,10 @@ (defn <store-name> [compile *type* ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] _ (compile ?elem) :let [_ (doto *writer* <unwrapper> @@ -329,25 +332,27 @@ (defn compile-jvm-anewarray [compile *type* ?class ?length] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] (return nil))) (defn compile-jvm-aaload [compile *type* ?class ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) - (.visitInsn Opcodes/AALOAD))]] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) (defn compile-jvm-aastore [compile *type* ?class ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] _ (compile ?elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) @@ -355,6 +360,7 @@ (defn compile-jvm-arraylength [compile *type* ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (doto *writer* (.visitInsn Opcodes/ARRAYLENGTH) (.visitInsn Opcodes/I2L) @@ -417,33 +423,75 @@ (&&/wrap-boolean))]] (return nil))) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] - (|do [module &/get-module-name] - (let [super-class* (&host/->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str module "/" ?name) nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) - (&host/->type-signature (:type field)) nil nil) - (.visitEnd))) - ?fields)] - (|do [_ (&/map% (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) - (:name method) - signature nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (.visitCode =method)] - _ (compile (:body method)) - :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ?methods)] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))))) +(defn ^:private compile-method [compile class-writer method] + ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) + ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) + ;; (prn 'compile-method/_2 (&/adt->text (:output method))) + ;; (prn 'compile-method/_3 (&/adt->text (:body method))) + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (&/with-writer (.visitMethod class-writer (modifiers->int (:modifiers method)) + (:name method) + signature nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (.visitCode =method)] + _ (compile (:body method)) + :let [_ (doto =method + (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + +(defn ^:private compile-method-decl [class-writer method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (.visitMethod class-writer (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + +(let [clo-field-sig (&host/->type-signature "java.lang.Object") + <init>-return "V"] + (defn ^:private anon-class-<init>-signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + <init>-return)) + + (defn ^:private add-anon-class-<init> [class-writer class-name env] + (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "<init>" (anon-class-<init>-signature env) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [(&a/$captured _ ?captured-id ?source) _]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ) + +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods env] + (|do [;; :let [_ (prn 'compile-jvm-class/_0)] + module &/get-module-name + ;; :let [_ (prn 'compile-jvm-class/_1)] + :let [full-name (str module "/" ?name) + super-class* (&host/->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil) + (.visitEnd))) + ?fields)] + ;; :let [_ (prn 'compile-jvm-class/_2)] + _ (&/map% (partial compile-method compile =class) ?methods) + ;; :let [_ (prn 'compile-jvm-class/_3)] + :let [_ (when env + (add-anon-class-<init> =class full-name env))] + ;; :let [_ (prn 'compile-jvm-class/_4)] + ] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) (defn compile-jvm-interface [compile ?name ?supers ?methods] ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) @@ -451,11 +499,7 @@ (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) - _ (do (&/|map (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) - ?methods) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) @@ -467,14 +511,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -501,12 +545,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 9137f3874..eafd6a1ac 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -19,21 +19,45 @@ (def module-separator "/") (def class-name-separator ".") (def class-separator "/") +(def array-data-tag "#Array") +(def null-data-tag "#Null") ;; [Utils] +(def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") + +(comment + (let [class (class (to-array []))] + (str (if-let [pkg (.getPackage class)] + (str (.getName pkg) ".") + "") + (.getSimpleName class))) + + (.getName String) "java.lang.String" + + (.getName (class (to-array []))) "[Ljava.lang.Object;" + + (re-find class-name-re "java.lang.String") + ["java.lang.String" "java.lang.String" nil nil "java.lang.String"] + + (re-find class-name-re "[Ljava.lang.Object;") + ["[Ljava.lang.Object;" "[Ljava.lang.Object;" "[" "java.lang.Object" nil] + ) + (defn ^:private class->type [^Class class] "(-> Class Type)" - (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class)))] - (if (.equals "void" base) - &type/Unit - (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base) - &/Nil$) - ))) + (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + ;; (prn 'class->type/_1 class base arr-brackets) + (let [output-type (if (.equals "void" base) + &type/Unit + (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (&type/Data$ base &/Nil$) + (range (count (or arr-brackets "")))) + )] + ;; (prn 'class->type/_2 class (&type/show-type output-type)) + output-type) + )))) (defn ^:private method->type [^Method method] "(-> Method Type)" @@ -70,11 +94,31 @@ (str "L" class* ";"))) )) +(defn unfold-array [type] + "(-> Type (, Int Type))" + (|case type + (&/$DataT "#Array" (&/$Cons param (&/$Nil))) + (|let [[count inner] (unfold-array param)] + (&/T (inc count) inner)) + + _ + (&/T 0 type))) + (defn ->java-sig [^objects type] "(-> Type Text)" (|case type (&/$DataT ?name params) - (->type-signature ?name) + (cond (= array-data-tag ?name) (|let [[level base] (unfold-array type) + base-sig (|case base + (&/$DataT base-class _) + (->class base-class) + + _ + (->java-sig base))] + (str (->> (&/|repeat level "[") (&/fold str "")) + "L" base-sig ";")) + (= null-data-tag ?name) (->type-signature "java.lang.Object") + :else (->type-signature ?name)) (&/$LambdaT _ _) (->type-signature function-class) @@ -123,6 +167,7 @@ ) (defn lookup-constructor [class-loader target args] + ;; (prn 'lookup-constructor class-loader target (&type/as-obj target)) (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] (and (= (&/|length args) (&/|length param-types)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 8a1e11bed..baf834ee6 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -862,7 +862,7 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT "null" (&/$Nil))] + [(&/$DataT e!name e!params) (&/$DataT "#Null" (&/$Nil))] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) @@ -880,7 +880,9 @@ ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) ;; true) - (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) + (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) + (catch Exception e + (prn 'FAILED_HERE e!name a!name)))) (return (&/T fixpoints nil)) :else |