diff options
| -rw-r--r-- | src/lux/analyser/case.clj | 38 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 12 | ||||
| -rw-r--r-- | src/lux/analyser/parser.clj | 65 | ||||
| -rw-r--r-- | src/lux/base.clj | 7 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 53 | ||||
| -rw-r--r-- | src/lux/host.clj | 6 | ||||
| -rw-r--r-- | src/lux/packager/program.clj | 2 | ||||
| -rw-r--r-- | src/lux/type.clj | 18 |
8 files changed, 142 insertions, 59 deletions
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 85d4dbb1a..c4372b4a1 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -75,34 +75,36 @@ (adjust-type* up =type)) (&/$ProdT ?left ?right) - (|do [(&/$ProdT =left =right) (&/fold% (fn [_abody ena] - (|let [[_aenv _aidx (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] - (&type/clean* _avar _abody)))) - type - up) + (|do [=type (&/fold% (fn [_abody ena] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] + (&type/clean* _avar _abody)))) + type + up) :let [distributor (fn [v] (&/fold (fn [_abody ena] (|let [[_aenv _aidx _avar] ena] (&/V &/$UnivQ (&/T [_aenv _abody])))) v - up))]] - (return (&type/Prod$ (distributor =left) (distributor =right)))) + up)) + adjusted-type (&type/Tuple$ (&/|map distributor (&type/flatten-prod =type)))]] + (return adjusted-type)) (&/$SumT ?left ?right) - (|do [(&/$SumT =left =right) (&/fold% (fn [_abody ena] - (|let [[_aenv _aidx (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] - (&type/clean* _avar _abody)))) - type - up) + (|do [=type (&/fold% (fn [_abody ena] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] + (&type/clean* _avar _abody)))) + type + up) :let [distributor (fn [v] (&/fold (fn [_abody ena] (|let [[_aenv _aidx _avar] ena] (&/V &/$UnivQ (&/T [_aenv _abody])))) v - up))]] - (return (&type/Sum$ (distributor =left) (distributor =right)))) + up)) + adjusted-type (&type/Variant$ (&/|map distributor (&type/flatten-sum =type)))]] + (return adjusted-type)) (&/$AppT ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] @@ -187,7 +189,9 @@ (&/$ProdT _) (|case (&type/tuple-types-for (&/|length ?members) value-type*) (&/$None) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "]" " -- " (&/show-ast pattern))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "]" + " -- " (&/show-ast pattern) + " " (&type/show-type value-type*) " " (&type/show-type value-type))) (&/$Some ?member-types*) (|do [[=tests =kont] (&/fold (fn [kont* vm] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 0bdb82d21..bce75bea7 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -562,7 +562,7 @@ (|let [[?cname ?cparams] class-decl class-type (&/V &/$DataT (&/T [?cname (&/|map &/|second class-env)]))] (|case method - (&/$ConstructorMethodSyntax ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (&/$ConstructorMethodSyntax =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) (|do [method-env (&/map% (fn [gvar] (|do [ex &type/existential] (return (&/T [gvar ex])))) @@ -584,9 +584,9 @@ body*))) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs))))] - (return (&/V &/$ConstructorMethodAnalysis (&/T [?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) + (return (&/V &/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) - (&/$VirtualMethodSyntax ?name ?anns ?gvars ?exceptions ?inputs ?output ?body) + (&/$VirtualMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output ?body) (|do [method-env (&/map% (fn [gvar] (|do [ex &type/existential] (return (&/T [gvar ex])))) @@ -602,7 +602,7 @@ body*))) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs))))] - (return (&/V &/$VirtualMethodAnalysis (&/T [?name ?anns ?gvars ?exceptions ?inputs ?output =body])))) + (return (&/V &/$VirtualMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output =body])))) (&/$OverridenMethodSyntax ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output ?body) (|do [super-env (gen-super-env class-env all-supers ?class-decl) @@ -693,7 +693,8 @@ [name [_ (&&/$captured _ _ source)]] source)) -(let [default-<init> (&/V &/$ConstructorMethodSyntax (&/T [(&/|list) +(let [default-<init> (&/V &/$ConstructorMethodSyntax (&/T [(&/V &/$Public &/unit-tag) + (&/|list) (&/|list) (&/|list) (&/|list) @@ -725,6 +726,7 @@ :let [=fields (&/|map (fn [^objects idx+capt] (|let [[idx _] idx+capt] (&/T [(str &c!base/closure-prefix idx) + (&/V &/$Public &/unit-tag) (&/|list) captured-slot-type]))) (&/enumerate =captured))] diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj index f30b73692..3c4d4413d 100644 --- a/src/lux/analyser/parser.clj +++ b/src/lux/analyser/parser.clj @@ -146,21 +146,40 @@ _ (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast))))) +(defn parse-privacy-modifier [ast] + (|case ast + [_ (&/$TextS "default")] + (return (&/V &/$Default &/unit-tag)) + + [_ (&/$TextS "public")] + (return (&/V &/$Public &/unit-tag)) + + [_ (&/$TextS "protected")] + (return (&/V &/$Protected &/unit-tag)) + + [_ (&/$TextS "private")] + (return (&/V &/$Private &/unit-tag)) + + _ + (fail (str "[Analyser Error] Invalid privacy modifier: " (&/show-ast ast))))) + (defn ^:private parse-method-init-def [ast] (|case ast [_ (&/$FormS (&/$Cons [_ (&/$TextS "init")] - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TupleS ?ctor-args)] - (&/$Cons body (&/$Nil)))))))))] - (|do [=anns (&/map% parse-ann anns) + (&/$Cons ?privacy-modifier + (&/$Cons [_ (&/$TupleS anns)] + (&/$Cons [_ (&/$TupleS gvars)] + (&/$Cons [_ (&/$TupleS exceptions)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TupleS ?ctor-args)] + (&/$Cons body (&/$Nil))))))))))] + (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) + =anns (&/map% parse-ann anns) =gvars (&/map% parse-text gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =ctor-args (&/map% parse-ctor-arg ?ctor-args)] - (return (&/V &/$ConstructorMethodSyntax (&/T [=anns =gvars =exceptions =inputs =ctor-args body])))) + (return (&/V &/$ConstructorMethodSyntax (&/T [=privacy-modifier =anns =gvars =exceptions =inputs =ctor-args body])))) _ (fail ""))) @@ -169,18 +188,20 @@ (|case ast [_ (&/$FormS (&/$Cons [_ (&/$TextS "virtual")] (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output - (&/$Cons body (&/$Nil))))))))))] - (|do [=anns (&/map% parse-ann anns) + (&/$Cons ?privacy-modifier + (&/$Cons [_ (&/$TupleS anns)] + (&/$Cons [_ (&/$TupleS gvars)] + (&/$Cons [_ (&/$TupleS exceptions)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons output + (&/$Cons body (&/$Nil)))))))))))] + (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) + =anns (&/map% parse-ann anns) =gvars (&/map% parse-text gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] - (return (&/V &/$VirtualMethodSyntax (&/T [?name =anns =gvars =exceptions =inputs =output body])))) + (return (&/V &/$VirtualMethodSyntax (&/T [?name =privacy-modifier =anns =gvars =exceptions =inputs =output body])))) _ (fail ""))) @@ -218,12 +239,14 @@ (defn parse-field [ast] (|case ast [_ (&/$FormS (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TupleS ?anns)] - (&/$Cons ?type - (&/$Nil)))))] - (|do [=anns (&/map% parse-ann ?anns) + (&/$Cons ?privacy-modifier + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons ?type + (&/$Nil))))))] + (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) + =anns (&/map% parse-ann ?anns) =type (parse-gclass ?type)] - (return (&/T [?name =anns =type]))) + (return (&/T [?name =privacy-modifier =anns =type]))) _ (fail (str "[Analyser Error] Invalid field declaration: " (&/show-ast ast))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 3544c88ec..9bfd60350 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -109,6 +109,13 @@ "GenericArray" "GenericWildcard"]) +;; Privacy Modifiers +(deftags + ["Default" + "Public" + "Private" + "Protected"]) + ;; Methods (deftags ["ConstructorMethodSyntax" diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 95fb2ff34..291d78ee2 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -434,9 +434,21 @@ (.visitEnd)) nil) +(defn ^:private privacy-modifer->flag [privacy-modifier] + "(-> PrivacyModifier Int)" + (|case privacy-modifier + (&/$Public) Opcodes/ACC_PUBLIC + (&/$Private) Opcodes/ACC_PRIVATE + (&/$Protected) Opcodes/ACC_PROTECTED + (&/$Default) 0 + _ (assert false (println-str (&/adt->text privacy-modifier) (&/adt->text (&/V &/$Public nil)))) + )) + (defn ^:private compile-field [^ClassWriter writer field] - (|let [[=name =anns =type] field - =field (.visitField writer Opcodes/ACC_PUBLIC =name + (|let [[=name =privacy-modifier =anns =type] field + =field (.visitField writer + (privacy-modifer->flag =privacy-modifier) + =name (&host-generics/gclass->simple-signature =type) (&host-generics/gclass->signature =type) nil)] (do (&/|map (partial compile-annotation =field) =anns) @@ -493,12 +505,12 @@ (defn ^:private compile-method-def [compile ^ClassWriter class-writer ?super-class method-def] (|case method-def - (&/$ConstructorMethodAnalysis ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (&/$ConstructorMethodAnalysis ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) (|let [?output (&/V &/$GenericClass (&/T ["void" (&/|list)])) =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] (&/with-writer (.visitMethod class-writer - Opcodes/ACC_PUBLIC + (privacy-modifer->flag ?privacy-modifier) init-method simple-signature generic-signature @@ -521,11 +533,11 @@ (.visitEnd))]] (return nil)))) - (&/$VirtualMethodAnalysis ?name ?anns ?gvars ?exceptions ?inputs ?output ?body) + (&/$VirtualMethodAnalysis ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output ?body) (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] (&/with-writer (.visitMethod class-writer - Opcodes/ACC_PUBLIC + (privacy-modifer->flag ?privacy-modifier) ?name simple-signature generic-signature @@ -640,7 +652,7 @@ (defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?anns ?fields ?methods env ??ctor-args] (|do [module &/get-module-name - [file-name _ _] &/cursor + [file-name line column] &/cursor :let [[?name ?params] class-decl class-signature (&host-generics/gclass-decl->signature class-decl (&/Cons$ ?super-class ?interfaces)) full-name (str module "/" ?name) @@ -741,9 +753,12 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd))) - =product_getRight-method (let [$is-last (new Label)] + =product_getRight-method (let [$begin (new Label) + $is-last (new Label) + $must-copy (new Label)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) (.visitCode) + (.visitLabel $begin) (.visitVarInsn Opcodes/ALOAD 0) ;; tuple (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index @@ -751,12 +766,30 @@ (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; + (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; + ;; Must recurse + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/DUP) ;; tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size + (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem + (.visitInsn Opcodes/AALOAD) ;; tuple-tail + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size + (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* + (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail + (.visitVarInsn Opcodes/ASTORE 0) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $must-copy) (.visitVarInsn Opcodes/ALOAD 0) (.visitVarInsn Opcodes/ILOAD 1) (.visitVarInsn Opcodes/ALOAD 0) (.visitInsn Opcodes/ARRAYLENGTH) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)Ljava/lang/Object;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") (.visitInsn Opcodes/ARETURN) (.visitLabel $is-last) ;; tuple-size, index-last-elem (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) diff --git a/src/lux/host.clj b/src/lux/host.clj index 2f3799946..36375ae0f 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -273,7 +273,7 @@ (defn ^:private compile-dummy-method [^ClassWriter =class super-class method-def] (|case method-def - (&/$ConstructorMethodSyntax =anns =gvars =exceptions =inputs =ctor-args body) + (&/$ConstructorMethodSyntax =privacy-modifier =anns =gvars =exceptions =inputs =ctor-args body) (|let [=output (&/V &/$GenericClass (&/T ["void" (&/|list)])) method-decl [init-method-name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] @@ -287,7 +287,7 @@ (.visitMaxs 0 0) (.visitEnd))) - (&/$VirtualMethodSyntax =name =anns =gvars =exceptions =inputs =output body) + (&/$VirtualMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output body) (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class Opcodes/ACC_PUBLIC @@ -329,7 +329,7 @@ (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) _ (&/|map (fn [field] - (|let [[=name =anns =type] field] + (|let [[=name =privacy-modifier =anns =type] field] (doto (.visitField =class Opcodes/ACC_PUBLIC =name (&host-generics/gclass->simple-signature =type) (&host-generics/gclass->signature =type) diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj index 270c11ed7..02a082101 100644 --- a/src/lux/packager/program.clj +++ b/src/lux/packager/program.clj @@ -110,5 +110,5 @@ (not (.endsWith ^String % "tools.nrepl-0.2.3.jar")) (not (.endsWith ^String % "clojure-complete-0.2.3.jar")))) (reduce (fn [s ^String j] (add-jar! (new File ^String j) s out)) - #{})) + #{"META-INF/MANIFEST.MF"})) )) diff --git a/src/lux/type.clj b/src/lux/type.clj index a617a4483..936fe9409 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -366,6 +366,20 @@ &/$ProdT flatten-prod prod-at "Product" ) +(do-template [<name> <ctor> <unit>] + (defn <name> [types] + "(-> (List Type) Type)" + (|case (&/|reverse types) + (&/$Cons last prevs) + (&/fold (fn [right left] (<ctor> left right)) last prevs) + + (&/$Nil) + <unit>)) + + Variant$ Sum$ $Void + Tuple$ Prod$ Unit + ) + (defn show-type [^objects type] (|case type (&/$DataT name params) @@ -383,10 +397,10 @@ "Unit" (&/$ProdT _) - (str "(, " (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + (str "[" (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) "]") (&/$SumT _) - (str "(|| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + (str "(| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] |