aboutsummaryrefslogtreecommitdiff
path: root/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser/proc/common.clj39
-rw-r--r--luxc/src/lux/compiler/jvm/proc/common.clj69
-rw-r--r--luxc/src/lux/type.clj25
-rw-r--r--luxc/src/lux/type/host.clj72
4 files changed, 144 insertions, 61 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj
index 9ab01801f..51e0f3528 100644
--- a/luxc/src/lux/analyser/proc/common.clj
+++ b/luxc/src/lux/analyser/proc/common.clj
@@ -404,6 +404,38 @@
^:private analyse-math-pow "pow"
)
+(defn ^:private analyse-atom-new [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons ?init (&/$Nil)) ?values]
+ =init (&&/analyse-1 analyse $var ?init)
+ _ (&type/check exo-type (&type/Atom $var))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["atom" "new"]) (&/|list =init) (&/|list)))))))))
+
+(defn ^:private analyse-atom-get [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values]
+ =atom (&&/analyse-1 analyse (&type/Atom $var) ?atom)
+ _ (&type/check exo-type $var)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["atom" "get"]) (&/|list =atom) (&/|list)))))))))
+
+(defn ^:private analyse-atom-compare-and-swap [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values]
+ =atom (&&/analyse-1 analyse (&type/Atom $var) ?atom)
+ =old (&&/analyse-1 analyse $var ?old)
+ =new (&&/analyse-1 analyse $var ?new)
+ _ (&type/check exo-type &type/Bool)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["atom" "compare-and-swap"]) (&/|list =atom =old =new) (&/|list)))))))))
+
(defn analyse-proc [analyse exo-type category proc ?values]
(case category
"lux"
@@ -556,6 +588,13 @@
"atan2" (analyse-math-atan2 analyse exo-type ?values)
"pow" (analyse-math-pow analyse exo-type ?values)
)
+
+ "atom"
+ (case proc
+ "new" (analyse-atom-new analyse exo-type ?values)
+ "get" (analyse-atom-get analyse exo-type ?values)
+ "compare-and-swap" (analyse-atom-compare-and-swap analyse exo-type ?values)
+ )
;; else
(&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))
diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj
index 63e7b9e76..dd59a41f0 100644
--- a/luxc/src/lux/compiler/jvm/proc/common.clj
+++ b/luxc/src/lux/compiler/jvm/proc/common.clj
@@ -792,19 +792,53 @@
&&/wrap-double)]]
(return nil)))
-(defn compile-proc [compile proc-category proc-name ?values special-args]
- (case proc-category
+(defn ^:private compile-atom-new [compile ?values special-args]
+ (|do [:let [(&/$Cons ?init (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW "java/util/concurrent/atomic/AtomicReference")
+ (.visitInsn Opcodes/DUP))]
+ _ (compile ?init)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/util/concurrent/atomic/AtomicReference" "<init>" "(Ljava/lang/Object;)V"))]]
+ (return nil)))
+
+(defn ^:private compile-atom-get [compile ?values special-args]
+ (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?atom)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/util/concurrent/atomic/AtomicReference"))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/atomic/AtomicReference" "get" "()Ljava/lang/Object;"))]]
+ (return nil)))
+
+(defn ^:private compile-atom-compare-and-swap [compile ?values special-args]
+ (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?atom)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/util/concurrent/atomic/AtomicReference"))]
+ _ (compile ?old)
+ _ (compile ?new)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/atomic/AtomicReference" "compareAndSet" "(Ljava/lang/Object;Ljava/lang/Object;)Z")
+ &&/wrap-boolean)]]
+ (return nil)))
+
+(defn compile-proc [compile category proc ?values special-args]
+ (case category
"lux"
- (case proc-name
+ (case proc
"is" (compile-lux-is compile ?values special-args))
"io"
- (case proc-name
+ (case proc
"log" (compile-io-log compile ?values special-args)
"error" (compile-io-error compile ?values special-args))
"text"
- (case proc-name
+ (case proc
"=" (compile-text-eq compile ?values special-args)
"<" (compile-text-lt compile ?values special-args)
"append" (compile-text-append compile ?values special-args)
@@ -822,7 +856,7 @@
)
"bit"
- (case proc-name
+ (case proc
"count" (compile-bit-count compile ?values special-args)
"and" (compile-bit-and compile ?values special-args)
"or" (compile-bit-or compile ?values special-args)
@@ -832,7 +866,7 @@
"unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args))
"array"
- (case proc-name
+ (case proc
"new" (compile-array-new compile ?values special-args)
"get" (compile-array-get compile ?values special-args)
"put" (compile-array-put compile ?values special-args)
@@ -840,7 +874,7 @@
"size" (compile-array-size compile ?values special-args))
"nat"
- (case proc-name
+ (case proc
"+" (compile-nat-add compile ?values special-args)
"-" (compile-nat-sub compile ?values special-args)
"*" (compile-nat-mul compile ?values special-args)
@@ -857,7 +891,7 @@
)
"deg"
- (case proc-name
+ (case proc
"+" (compile-deg-add compile ?values special-args)
"-" (compile-deg-sub compile ?values special-args)
"*" (compile-deg-mul compile ?values special-args)
@@ -874,7 +908,7 @@
)
"int"
- (case proc-name
+ (case proc
"+" (compile-int-add compile ?values special-args)
"-" (compile-int-sub compile ?values special-args)
"*" (compile-int-mul compile ?values special-args)
@@ -891,7 +925,7 @@
)
"real"
- (case proc-name
+ (case proc
"+" (compile-real-add compile ?values special-args)
"-" (compile-real-sub compile ?values special-args)
"*" (compile-real-mul compile ?values special-args)
@@ -912,7 +946,7 @@
)
"char"
- (case proc-name
+ (case proc
"=" (compile-char-eq compile ?values special-args)
"<" (compile-char-lt compile ?values special-args)
"to-nat" (compile-char-to-nat compile ?values special-args)
@@ -920,7 +954,7 @@
)
"math"
- (case proc-name
+ (case proc
"e" (compile-math-e compile ?values special-args)
"pi" (compile-math-pi compile ?values special-args)
"cos" (compile-math-cos compile ?values special-args)
@@ -944,6 +978,13 @@
"atan2" (compile-math-atan2 compile ?values special-args)
"pow" (compile-math-pow compile ?values special-args)
)
+
+ "atom"
+ (case proc
+ "new" (compile-atom-new compile ?values special-args)
+ "get" (compile-atom-get compile ?values special-args)
+ "compare-and-swap" (compile-atom-compare-and-swap compile ?values special-args)
+ )
;; else
- (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [proc-category proc-name]))))
+ (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc]))))
diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj
index ad185e284..94c4e2ae7 100644
--- a/luxc/src/lux/type.clj
+++ b/luxc/src/lux/type.clj
@@ -23,17 +23,22 @@
(def empty-env &/$Nil)
-(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)))
+(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "#Bool" &/$Nil)))
(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil)))
(def Deg (&/$NamedT (&/T ["lux" "Deg"]) (&/$HostT &&host/deg-data-tag &/$Nil)))
-(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil)))
-(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil)))
-(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil)))
-(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil)))
+(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "#Int" &/$Nil)))
+(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "#Real" &/$Nil)))
+(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "#Char" &/$Nil)))
+(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "#Text" &/$Nil)))
(def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text)))
-(defn Array [elem-type]
- (&/$HostT "#Array" (&/|list elem-type)))
+(do-template [<name> <tag>]
+ (defn <name> [elem-type]
+ (&/$HostT <tag> (&/|list elem-type)))
+
+ Array "#Array"
+ Atom "#Atom"
+ )
(def Bottom
(&/$NamedT (&/T ["lux" "Bottom"])
@@ -205,7 +210,7 @@
(&/$None)
(return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %)
- ts))
+ ts))
state)
nil))
((&/fail-with-loc (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))
@@ -215,7 +220,7 @@
(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))
+ ts))
state)
nil)
((&/fail-with-loc (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))
@@ -225,7 +230,7 @@
(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))
+ ts))
state)
nil)
((&/fail-with-loc (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))
diff --git a/luxc/src/lux/type/host.clj b/luxc/src/lux/type/host.clj
index b255f97c5..40a3373f0 100644
--- a/luxc/src/lux/type/host.clj
+++ b/luxc/src/lux/type/host.clj
@@ -250,45 +250,43 @@
(defn primitive-type? [type-name]
(contains? primitive-types type-name)))
+(def ^:private lux-jvm-type-combos
+ #{#{"java.lang.Boolean" "#Bool"}
+ #{"java.lang.Long" "#Int"}
+ #{"java.lang.Double" "#Real"}
+ #{"java.lang.Character" "#Char"}
+ #{"java.lang.String" "#Text"}})
+
+(defn ^:private lux-type? [^String class-name]
+ (.startsWith class-name "#"))
+
(defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual]
- (|let [[e!name e!params] expected
- [a!name a!params] actual]
- ;; TODO: Delete first branch. It smells like a hack...
- (try (cond (or (= "java.lang.Object" e!name)
- (and (= nat-data-tag e!name)
- (= nat-data-tag a!name))
- (and (= deg-data-tag e!name)
- (= deg-data-tag a!name))
- (and (= null-data-tag e!name)
- (= null-data-tag a!name))
- (and (not (primitive-type? e!name))
- (= null-data-tag a!name)))
- (return fixpoints)
-
- (or (and (= array-data-tag e!name)
- (not= array-data-tag a!name))
- (= nat-data-tag e!name) (= nat-data-tag a!name)
- (= deg-data-tag e!name) (= deg-data-tag a!name)
- (= null-data-tag e!name) (= null-data-tag a!name))
- (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))
-
- :else
- (let [e!name (as-obj e!name)
- a!name (as-obj a!name)]
- (cond (= e!name a!name)
- (if (= (&/|length e!params) (&/|length a!params))
- (|do [_ (&/map2% check e!params a!params)]
- (return fixpoints))
- (&/fail-with-loc (str "[Type Error] Amounts of generic parameters don't match: " e!name "(" (&/|length e!params) ")" " vs " a!name "(" (&/|length a!params) ")")))
-
- (not invariant??)
- (|do [actual* (->super-type existential class-loader e!name a!name a!params)]
- (check (&/$HostT e!name e!params) actual*))
-
- :else
- (&/fail-with-loc (str "[Type Error] Names don't match: " e!name " =/= " a!name)))))
+ (|let [[^String e!name e!params] expected
+ [^String a!name a!params] actual]
+ (try (let [e!name (as-obj e!name)
+ a!name (as-obj a!name)]
+ (cond (= e!name a!name)
+ (if (= (&/|length e!params) (&/|length a!params))
+ (|do [_ (&/map2% check e!params a!params)]
+ (return fixpoints))
+ (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)))
+
+ (or (lux-type? e!name)
+ (lux-type? a!name))
+ (if (or (= "java.lang.Object" e!name)
+ (contains? lux-jvm-type-combos #{e!name a!name})
+ (and (not (primitive-type? e!name))
+ (= null-data-tag a!name)))
+ (return fixpoints)
+ (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)))
+
+ (not invariant??)
+ (|do [actual* (->super-type existential class-loader e!name a!name a!params)]
+ (check (&/$HostT e!name e!params) actual*))
+
+ :else
+ (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))))
(catch Exception e
- (prn 'check-host-types e [e!name a!name])
(throw e)))))
(defn gtype->gclass [gtype]
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 02:35:52 +0000