aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lux/analyser.clj10
-rw-r--r--src/lux/analyser/host.clj46
-rw-r--r--src/lux/analyser/lux.clj7
-rw-r--r--src/lux/base.clj11
-rw-r--r--src/lux/compiler/cache.clj2
-rw-r--r--src/lux/compiler/host.clj63
-rw-r--r--src/lux/type.clj54
7 files changed, 120 insertions, 73 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 80c8ef2ec..42d92b859 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -668,12 +668,14 @@
(|case [?var ?output-type]
[(&/$VarT ?e-id) (&/$VarT ?a-id)]
(if (= ?e-id ?a-id)
- (|do [?output-type* (&type/deref ?e-id)]
- (return (&&/|meta ?output-type* ?output-cursor ?output-term)))
- (return (&&/|meta ?output-type ?output-cursor ?output-term)))
+ (|do [=output-type (&type/clean ?var ?output-type)]
+ (return (&&/|meta =output-type ?output-cursor ?output-term)))
+ (|do [=output-type (&type/clean ?var ?var)]
+ (return (&&/|meta =output-type ?output-cursor ?output-term))))
[_ _]
- (return (&&/|meta ?output-type ?output-cursor ?output-term)))
+ (|do [=output-type (&type/clean ?var ?output-type)]
+ (return (&&/|meta =output-type ?output-cursor ?output-term))))
))))
(defn ^:private analyse-ast [eval! compile-module compile-token exo-type token]
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index d431ddb9f..a2d6fd592 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -575,6 +575,28 @@
(return (&/T [gvar-name ex]))))
type-params))
+(defn ^:private double-register-gclass? [gclass]
+ (|case gclass
+ (&/$GenericClass name _)
+ (|case name
+ "long" true
+ "double" true
+ _ false)
+
+ _
+ false))
+
+(defn ^:private method-input-folder [full-env]
+ (fn [body* input*]
+ (|do [:let [[iname itype*] input*]
+ itype (generic-class->type full-env itype*)]
+ (if (double-register-gclass? itype*)
+ (&&env/with-local iname itype
+ (&&env/with-local "" &/$VoidT
+ body*))
+ (&&env/with-local iname itype
+ body*)))))
+
(defn ^:private analyse-method [analyse class-decl class-env all-supers method]
"(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))"
(|let [[?cname ?cparams] class-decl
@@ -592,11 +614,7 @@
?ctor-args)
=body (&/with-type-env full-env
(&&env/with-local &&/jvm-this class-type
- (&/fold (fn [body* input*]
- (|do [:let [[iname itype*] input*]
- itype (generic-class->type full-env itype*)]
- (&&env/with-local iname itype
- body*)))
+ (&/fold (method-input-folder full-env)
(&&/analyse-1 analyse output-type ?body)
(&/|reverse ?inputs))))]
(return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body]))))
@@ -607,11 +625,7 @@
output-type (generic-class->type full-env ?output)
=body (&/with-type-env full-env
(&&env/with-local &&/jvm-this class-type
- (&/fold (fn [body* input*]
- (|do [:let [[iname itype*] input*]
- itype (generic-class->type full-env itype*)]
- (&&env/with-local iname itype
- body*)))
+ (&/fold (method-input-folder full-env)
(&&/analyse-1 analyse output-type ?body)
(&/|reverse ?inputs))))]
(return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body]))))
@@ -623,11 +637,7 @@
output-type (generic-class->type full-env ?output)
=body (&/with-type-env full-env
(&&env/with-local &&/jvm-this class-type
- (&/fold (fn [body* input*]
- (|do [:let [[iname itype*] input*]
- itype (generic-class->type full-env itype*)]
- (&&env/with-local iname itype
- body*)))
+ (&/fold (method-input-folder full-env)
(&&/analyse-1 analyse output-type ?body)
(&/|reverse ?inputs))))]
(return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body]))))
@@ -637,11 +647,7 @@
:let [full-env method-env]
output-type (generic-class->type full-env ?output)
=body (&/with-type-env full-env
- (&/fold (fn [body* input*]
- (|do [:let [[iname itype*] input*]
- itype (generic-class->type full-env itype*)]
- (&&env/with-local iname itype
- body*)))
+ (&/fold (method-input-folder full-env)
(&&/analyse-1 analyse output-type ?body)
(&/|reverse ?inputs)))]
(return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body]))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 88fc2f4ee..4ffa7a9c2 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -339,8 +339,9 @@
(|do [? (&type/bound? ?id)
type** (if ?
(&type/clean $var =output-t)
- (|do [_ (&type/set-var ?id (&/$BoundT 1))]
- (&type/clean $var =output-t)))]
+ (|do [_ (&type/set-var ?id (next-bound-type =output-t))]
+ (&type/clean $var =output-t)))
+ _ (&type/clean $var exo-type)]
(return (&/T [type** ==args])))
))))
@@ -385,7 +386,7 @@
(throw e))))))
module-name &/get-module-name
;; :let [[r-prefix r-name] real-name
- ;; _ (when (or (= "jvm-import" r-name)
+ ;; _ (when (or (= "get@" r-name)
;; ;; (= "defclass" r-name)
;; )
;; (->> (&/|map &/show-ast macro-expansion)
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 4074efae7..56a59e31b 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -693,16 +693,9 @@
(proxy [java.lang.ClassLoader]
[]
(findClass [^String class-name]
- ;; (prn 'findClass class-name)
(if-let [^bytes bytecode (get @store class-name)]
- (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))]))
- (catch java.lang.reflect.InvocationTargetException e
- ;; (prn 'InvocationTargetException (.getCause e))
- ;; (prn 'InvocationTargetException (.getTargetException e))
- ;; (prn 'memory-class-loader/findClass class-name (get @store class-name))
- (throw e)))
- (do ;; (prn 'memory-class-loader/store class-name (keys @store))
- (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))))
+ (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))]))
+ (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))
;; (deftype Host
;; (& #writer (^ org.objectweb.asm.ClassWriter)
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
index acbe2e6b9..8ae2eb113 100644
--- a/src/lux/compiler/cache.clj
+++ b/src/lux/compiler/cache.clj
@@ -108,6 +108,8 @@
(let [real-name (second (re-find #"^(.*)\.class$" file-name))
bytecode (read-file file)]
(swap! !classes assoc (str module* "." real-name) bytecode)))
+ ;; (doseq [_class-name_ (keys @!classes)]
+ ;; (&&/load-class! loader _class-name_))
(let [defs (string/split (get-field &/defs-field module-meta) def-separator-re)
tag-groups (let [all-tags (get-field &/tags-field module-meta)]
(if (= "" all-tags)
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 88cb1ee6e..79658e6d5 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -193,9 +193,9 @@
(.visitLabel $end))]]
(return nil)))
- compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J"
- compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J"
- compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J"
+ compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J"
+ compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J"
+ compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J"
compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F"
compile-jvm-flt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F"
@@ -203,7 +203,7 @@
compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D"
compile-jvm-dlt Opcodes/DCMPG -1 "java.lang.Double" "doubleValue" "()D"
- compile-jvm-dgt Opcodes/FCMPG 1 "java.lang.Double" "doubleValue" "()D"
+ compile-jvm-dgt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D"
)
(defn compile-jvm-invokestatic [compile ?class ?method ?classes ?args ?output-type]
@@ -515,65 +515,66 @@
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-boolean
(.visitVarInsn Opcodes/ASTORE idx))
- (return (&host-generics/gclass->class-name (&/$GenericClass name params))))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))])))
"byte" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-byte
(.visitVarInsn Opcodes/ASTORE idx))
- (return (&host-generics/gclass->class-name (&/$GenericClass name params))))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))])))
"short" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-short
(.visitVarInsn Opcodes/ASTORE idx))
- (return (&host-generics/gclass->class-name (&/$GenericClass name params))))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))])))
"int" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-int
(.visitVarInsn Opcodes/ASTORE idx))
- (return Opcodes/INTEGER))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))])))
"long" (do (doto method-visitor
(.visitVarInsn Opcodes/LLOAD idx)
&&/wrap-long
(.visitVarInsn Opcodes/ASTORE idx))
- (return Opcodes/LONG))
+ (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)])))
"float" (do (doto method-visitor
(.visitVarInsn Opcodes/FLOAD idx)
&&/wrap-float
(.visitVarInsn Opcodes/ASTORE idx))
- (return Opcodes/FLOAT))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))])))
"double" (do (doto method-visitor
(.visitVarInsn Opcodes/DLOAD idx)
&&/wrap-double
(.visitVarInsn Opcodes/ASTORE idx))
- (return Opcodes/DOUBLE))
+ (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)])))
"char" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-char
(.visitVarInsn Opcodes/ASTORE idx))
- (return (&host-generics/gclass->class-name (&/$GenericClass name params))))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))])))
;; else
- (return (&host-generics/gclass->class-name (&/$GenericClass name params))))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))])))
[_ gclass]
- (return (&host-generics/gclass->class-name gclass))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))]))
))
(defn ^:private prepare-method-inputs [idx inputs method-visitor]
"(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))"
(|case inputs
(&/$Nil)
- (return &/unit-tag)
+ (return &/$Nil)
(&/$Cons input inputs*)
- (let [!idx (atom idx)]
- (&/map% (fn [input]
- (|do [output (prepare-method-input @!idx input method-visitor)
- :let [_ (swap! !idx inc)]]
- (return output)))
- inputs))
+ (|do [[_ outputs*] (&/fold% (fn [idx+outputs input]
+ (|do [:let [[_idx _outputs] idx+outputs]
+ [idx* output] (prepare-method-input _idx input method-visitor)]
+ (return (&/T [idx* (&/$Cons output _outputs)]))))
+ (&/T [idx &/$Nil])
+ inputs)]
+ (return (&/list-join (&/|reverse outputs*))))
))
-(defn ^:private compile-method-def [compile ^ClassWriter class-writer ?super-class method-def]
+(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def]
(|case method-def
(&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body)
(|let [?output (&/$GenericClass "void" (&/|list))
@@ -585,7 +586,7 @@
init-method
simple-signature
generic-signature
- (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [[super-class-name super-class-params] ?super-class
init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str ""))
@@ -593,6 +594,7 @@
_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 1 ?inputs =method)
+ :let [_ (.visitFrame =method Opcodes/F_NEW (int (inc (&/|length =input-tags))) (to-array (&/->seq (&/$Cons Opcodes/UNINITIALIZED_THIS =input-tags))) (int 0) (to-array []))]
:let [_ (.visitVarInsn =method Opcodes/ALOAD 0)]
_ (->> ?ctor-args (&/|map &/|second) (&/map% compile))
:let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)]
@@ -613,11 +615,12 @@
?name
simple-signature
generic-signature
- (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 1 ?inputs =method)
+ :let [_ (.visitFrame =method Opcodes/F_NEW (int (inc (&/|length =input-tags))) (to-array (&/->seq (&/$Cons bytecode-class-name =input-tags))) (int 0) (to-array []))]
_ (compile ?body)
:let [_ (doto =method
(compile-method-return ?output)
@@ -634,11 +637,12 @@
?name
simple-signature
generic-signature
- (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 1 ?inputs =method)
+ :let [_ (.visitFrame =method Opcodes/F_NEW (int (inc (&/|length =input-tags))) (to-array (&/->seq (&/$Cons bytecode-class-name =input-tags))) (int 0) (to-array []))]
_ (compile ?body)
:let [_ (doto =method
(compile-method-return ?output)
@@ -656,11 +660,12 @@
?name
simple-signature
generic-signature
- (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 0 ?inputs =method)
+ :let [_ (.visitFrame =method Opcodes/F_NEW (int (&/|length =input-tags)) (to-array (&/->seq =input-tags)) (int 0) (to-array []))]
_ (compile ?body)
:let [_ (doto =method
(compile-method-return ?output)
@@ -677,7 +682,7 @@
?name
simple-signature
generic-signature
- (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitEnd =method)]]
@@ -692,7 +697,7 @@
?name
simple-signature
generic-signature
- (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitEnd =method)]]
@@ -806,7 +811,7 @@
_ (&/|map (partial compile-annotation =class) ?anns)
_ (&/|map (partial compile-field =class)
?fields)]
- _ (&/map% (partial compile-method-def compile =class ?super-class) ?methods)
+ _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods)
_ (|case ??ctor-args
(&/$Some ctor-args)
(add-anon-class-<init> =class compile full-name ?super-class env ctor-args)
diff --git a/src/lux/type.clj b/src/lux/type.clj
index b09db681d..e9ebcc361 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -192,6 +192,24 @@
nil))
(fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))))))
+(defn reset-var [id type]
+ (fn [state]
+ (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
+ (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %)
+ ts))
+ state)
+ nil)
+ (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))))))
+
+(defn unset-var [id]
+ (fn [state]
+ (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
+ (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %)
+ ts))
+ state)
+ nil)
+ (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))))))
+
;; [Exports]
;; Type vars
(def ^:private create-var
@@ -256,7 +274,23 @@
(if ?
(deref ?id)
(return type)))
- (return type))
+ (|do [? (bound? ?id)]
+ (if ?
+ (|do [=type (deref ?id)
+ ==type (clean* ?tid =type)]
+ (|case ==type
+ (&/$VarT =id)
+ (if (.equals ^Object ?tid =id)
+ (|do [_ (unset-var ?id)]
+ (return type))
+ (|do [_ (reset-var ?id ==type)]
+ (return type)))
+
+ _
+ (|do [_ (reset-var ?id ==type)]
+ (return type))))
+ (return type)))
+ )
(&/$DataT ?name ?params)
(|do [=params (&/map% (partial clean* ?tid) ?params)]
@@ -714,17 +748,21 @@
[_ (&/$UnivQ _)]
(with-var
(fn [$arg]
- (|do [actual* (apply-type actual $arg)]
- (check* class-loader fixpoints invariant?? expected actual*))))
+ (|do [actual* (apply-type actual $arg)
+ =output (check* class-loader fixpoints invariant?? expected actual*)
+ _ (clean $arg expected)]
+ (return =output))))
[(&/$ExQ e!env e!def) _]
(with-var
(fn [$arg]
- (|let [expected* (beta-reduce (->> e!env
- (&/$Cons $arg)
- (&/$Cons expected))
- e!def)]
- (check* class-loader fixpoints invariant?? expected* actual))))
+ (|do [:let [expected* (beta-reduce (->> e!env
+ (&/$Cons $arg)
+ (&/$Cons expected))
+ e!def)]
+ =output (check* class-loader fixpoints invariant?? expected* actual)
+ _ (clean $arg actual)]
+ (return =output))))
[_ (&/$ExQ a!env a!def)]
(|do [$arg existential]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 01:00:23 +0000