aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/lux/analyser/host.clj54
-rw-r--r--src/lux/compiler/host.clj36
-rw-r--r--src/lux/host.clj70
-rw-r--r--src/lux/type.clj50
4 files changed, 165 insertions, 45 deletions
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 9d295edda..53ab1de5b 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -425,15 +425,45 @@
_
(fail "[Analyser Error] Wrong syntax for field.")))
+(defn ^:private dummy-method-desc [method]
+ (|case method
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
+ (&/$Cons [_ (&/$TupleS method-modifiers)]
+ (&/$Cons [_ (&/$TupleS method-exs)]
+ (&/$Cons [_ (&/$TupleS method-inputs)]
+ (&/$Cons [_ (&/$TextS method-output)]
+ (&/$Cons method-body
+ (&/$Nil))))))))]
+ (|do [=method-modifiers (analyse-modifiers method-modifiers)
+ =method-exs (&/map% extract-text method-exs)
+ =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)]
+ (return {:name method-name
+ :modifiers =method-modifiers
+ :exceptions =method-exs
+ :inputs (&/|map &/|second =method-inputs)
+ :output method-output}))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for method.")))
+
(defn ^:private analyse-method [analyse owner-class method]
(|case method
- [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
- (&/$Cons [_ (&/$TupleS method-modifiers)]
- (&/$Cons [_ (&/$TupleS method-exs)]
- (&/$Cons [_ (&/$TupleS method-inputs)]
- (&/$Cons [_ (&/$TextS method-output)]
- (&/$Cons method-body
- (&/$Nil))))))))]]
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
+ (&/$Cons [_ (&/$TupleS method-modifiers)]
+ (&/$Cons [_ (&/$TupleS method-exs)]
+ (&/$Cons [_ (&/$TupleS method-inputs)]
+ (&/$Cons [_ (&/$TextS method-output)]
+ (&/$Cons method-body
+ (&/$Nil))))))))]
(|do [=method-modifiers (analyse-modifiers method-modifiers)
=method-exs (&/map% extract-text method-exs)
=method-inputs (&/map% (fn [minput]
@@ -521,8 +551,9 @@
;; :let [_ (prn 'analyse-jvm-class/_0)]
=fields (&/map% analyse-field fields)
;; :let [_ (prn 'analyse-jvm-class/_1)]
- _ (&host/use-dummy-class name super-class interfaces =fields)
- =methods (&/map% (partial analyse-method analyse full-name) (&/enumerate methods))
+ =method-descs (&/map% dummy-method-desc methods)
+ _ (&host/use-dummy-class name super-class interfaces =fields =method-descs)
+ =methods (&/map% (partial analyse-method analyse full-name) methods)
;; :let [_ (prn 'analyse-jvm-class/_2)]
_ (check-method-completion (&/Cons$ super-class interfaces) =methods)
;; :let [_ (prn 'analyse-jvm-class/_3)]
@@ -557,8 +588,9 @@
:let [name (&host/location (&/|tail scope))
anon-class (str module "." name)]
;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)]
- _ (&host/use-dummy-class name super-class interfaces (&/|list))
- =methods (&/map% (partial analyse-method analyse anon-class) (&/enumerate methods))
+ =method-descs (&/map% dummy-method-desc methods)
+ _ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs)
+ =methods (&/map% (partial analyse-method analyse anon-class) 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)]
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index b4858d789..95d63b0fb 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -410,6 +410,36 @@
(&&/wrap-boolean))]]
(return nil)))
+(defn ^:private compile-method-return [writer output]
+ (case output
+ "void" (.visitInsn writer Opcodes/RETURN)
+ "boolean" (doto writer
+ &&/unwrap-boolean
+ (.visitInsn Opcodes/IRETURN))
+ "byte" (doto writer
+ &&/unwrap-byte
+ (.visitInsn Opcodes/IRETURN))
+ "short" (doto writer
+ &&/unwrap-short
+ (.visitInsn Opcodes/IRETURN))
+ "int" (doto writer
+ &&/unwrap-int
+ (.visitInsn Opcodes/IRETURN))
+ "long" (doto writer
+ &&/unwrap-long
+ (.visitInsn Opcodes/LRETURN))
+ "float" (doto writer
+ &&/unwrap-float
+ (.visitInsn Opcodes/FRETURN))
+ "double" (doto writer
+ &&/unwrap-double
+ (.visitInsn Opcodes/DRETURN))
+ "char" (doto writer
+ &&/unwrap-char
+ (.visitInsn Opcodes/IRETURN))
+ ;; else
+ (.visitInsn writer Opcodes/ARETURN)))
+
(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)))
@@ -421,12 +451,12 @@
(:name method)
signature
nil
- (->> (:exceptions method) &/->seq (into-array java.lang.String)))
+ (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (.visitCode =method)]
_ (compile (:body method))
:let [_ (doto =method
- (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN))
+ (compile-method-return (:output method))
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil)))))
@@ -434,7 +464,7 @@
(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 (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) &/->seq (into-array java.lang.String)))))
+ (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))))
(let [clo-field-sig (&host/->type-signature "java.lang.Object")
<init>-return "V"]
diff --git a/src/lux/host.clj b/src/lux/host.clj
index d2ade63c7..b05c30ad3 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -68,14 +68,15 @@
(class->type (.getReturnType method)))
;; [Resources]
-(defn ^String ->class [class]
- (string/replace class (-> class-name-separator Pattern/quote re-pattern) class-separator))
-
-(defn ^String ->class-name [module]
- (string/replace module (-> module-separator Pattern/quote re-pattern) class-name-separator))
-
-(defn ^String ->module-class [module-name]
- (string/replace module-name (-> module-separator Pattern/quote re-pattern) class-separator))
+(do-template [<name> <old-sep> <new-sep>]
+ (let [regex (-> <old-sep> Pattern/quote re-pattern)]
+ (defn <name> [old]
+ (string/replace old regex <new-sep>)))
+
+ ^String ->class class-name-separator class-separator
+ ^String ->class-name module-separator class-name-separator
+ ^String ->module-class module-separator class-separator
+ )
(def ->package ->module-class)
@@ -206,7 +207,45 @@
;; else
0)))
-(defn use-dummy-class [name super-class interfaces fields]
+(let [object-real-class (->class "java.lang.Object")]
+ (defn ^:private dummy-return [writer name output]
+ (case output
+ "void" (if (= "<init>" name)
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL object-real-class "<init>" "()V")
+ (.visitInsn Opcodes/RETURN))
+ (.visitInsn writer Opcodes/RETURN))
+ "boolean" (doto writer
+ (.visitLdcInsn false)
+ (.visitInsn Opcodes/IRETURN))
+ "byte" (doto writer
+ (.visitLdcInsn (byte 0))
+ (.visitInsn Opcodes/IRETURN))
+ "short" (doto writer
+ (.visitLdcInsn (short 0))
+ (.visitInsn Opcodes/IRETURN))
+ "int" (doto writer
+ (.visitLdcInsn (int 0))
+ (.visitInsn Opcodes/IRETURN))
+ "long" (doto writer
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LRETURN))
+ "float" (doto writer
+ (.visitLdcInsn (float 0.0))
+ (.visitInsn Opcodes/FRETURN))
+ "double" (doto writer
+ (.visitLdcInsn (double 0.0))
+ (.visitInsn Opcodes/DRETURN))
+ "char" (doto writer
+ (.visitLdcInsn (char 0))
+ (.visitInsn Opcodes/IRETURN))
+ ;; else
+ (doto writer
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitInsn Opcodes/ARETURN)))))
+
+(defn use-dummy-class [name super-class interfaces fields methods]
(|do [module &/get-module-name
:let [full-name (str module "/" name)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
@@ -217,6 +256,19 @@
(->type-signature (:type field)) nil nil)
(.visitEnd)))
fields)
+ _ (&/|map (fn [method]
+ (|let [signature (str "(" (&/fold str "" (&/|map ->type-signature (:inputs method))) ")"
+ (->type-signature (:output method)))]
+ (doto (.visitMethod =class (modifiers->int (:modifiers method))
+ (:name method)
+ signature
+ nil
+ (->> (:exceptions method) (&/|map ->class) &/->seq (into-array java.lang.String)))
+ .visitCode
+ (dummy-return (:name method) (:output method))
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+ methods)
bytecode (.toByteArray (doto =class .visitEnd))]
loader &/loader
!classes &/classes
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 24486c85a..0495e6b02 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -663,31 +663,37 @@
(|do [actual* (apply-type actual $arg)]
(check* class-loader fixpoints invariant?? expected actual*))))
- [(&/$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)))
-
[(&/$DataT e!name e!params) (&/$DataT a!name a!params)]
- (let [e!name (as-obj e!name)
- a!name (as-obj a!name)]
- (cond (and (.equals ^Object e!name a!name)
- (= (&/|length e!params) (&/|length a!params)))
- (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)]
- (return (&/T fixpoints nil)))
-
- (and (not invariant??)
- ;; (do (println '[Data Data] [e!name a!name]
- ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")
- ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")])
- ;; true)
- (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))))
+ (cond (= "#Null" a!name)
+ (if (not (contains? primitive-types e!name))
(return (&/T fixpoints nil))
+ (fail (check-error expected actual)))
- :else
- (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))
+ (= "#Null" e!name)
+ (if (= "#Null" a!name)
+ (return (&/T fixpoints nil))
+ (fail (check-error expected actual)))
+
+ :else
+ (let [e!name (as-obj e!name)
+ a!name (as-obj a!name)]
+ (cond (and (.equals ^Object e!name a!name)
+ (= (&/|length e!params) (&/|length a!params)))
+ (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)]
+ (return (&/T fixpoints nil)))
+
+ (and (not invariant??)
+ ;; (do (println '[Data Data] [e!name a!name]
+ ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")
+ ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")])
+ ;; true)
+ (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
+ (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))))
[(&/$LambdaT eI eO) (&/$LambdaT aI aO)]
(|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 11:43:05 +0000