aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorEduardo Julian2016-02-04 20:58:24 -0400
committerEduardo Julian2016-02-04 20:58:24 -0400
commite372a04ae4db506e51bbe446b283aabf1028e7fb (patch)
treeb67febb821b71427299a8ae37231c6dc534c6ab5 /src
parent3dfb1a097f44a66fe734831b3770e7016fda78be (diff)
- Fixed some bugs regarding the handling of sums & products.
- Added the capacity to specify access modifiers to both class fields & methods. - No longer including "META-INF/MANIFEST.MF" files of imported jars.
Diffstat (limited to 'src')
-rw-r--r--src/lux/analyser/case.clj38
-rw-r--r--src/lux/analyser/host.clj12
-rw-r--r--src/lux/analyser/parser.clj65
-rw-r--r--src/lux/base.clj7
-rw-r--r--src/lux/compiler/host.clj53
-rw-r--r--src/lux/host.clj6
-rw-r--r--src/lux/packager/program.clj2
-rw-r--r--src/lux/type.clj18
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)]