aboutsummaryrefslogtreecommitdiff
path: root/luxc/src/lux
diff options
context:
space:
mode:
Diffstat (limited to 'luxc/src/lux')
-rw-r--r--luxc/src/lux/analyser.clj2
-rw-r--r--luxc/src/lux/analyser/lux.clj54
-rw-r--r--luxc/src/lux/base.clj192
-rw-r--r--luxc/src/lux/compiler/cache.clj2
-rw-r--r--luxc/src/lux/compiler/core.clj4
-rw-r--r--luxc/src/lux/compiler/js.clj2
-rw-r--r--luxc/src/lux/compiler/js/base.clj49
-rw-r--r--luxc/src/lux/compiler/js/lux.clj3
-rw-r--r--luxc/src/lux/compiler/jvm.clj32
-rw-r--r--luxc/src/lux/type.clj89
10 files changed, 212 insertions, 217 deletions
diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj
index e2aa64590..280085777 100644
--- a/luxc/src/lux/analyser.clj
+++ b/luxc/src/lux/analyser.clj
@@ -57,7 +57,7 @@
(return (&&/|meta =output-type ?output-cursor ?output-term))))
))))
-(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token]
+(defn ^:private analyse-ast [optimize eval! compile-module ^"[Ljava.lang.Object;" compilers exo-type ?token]
(|let [analyse (partial analyse-ast optimize eval! compile-module compilers)
[cursor token] ?token
compile-def (aget compilers 0)
diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj
index af7f0f3f9..aee46a9cc 100644
--- a/luxc/src/lux/analyser/lux.clj
+++ b/luxc/src/lux/analyser/lux.clj
@@ -376,35 +376,33 @@
)))))
(defn analyse-apply [analyse cursor exo-type macro-caller =fn ?args]
- (|do [loader &/loader
- :let [[[=fn-type =fn-cursor] =fn-form] =fn]]
- (|case =fn-form
- (&&/$var (&/$Global ?module ?name))
- (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)]
- (|case (&&meta/meta-get &&meta/macro?-tag ?meta)
- (&/$Some _)
- (|do [macro-expansion (fn [state]
- (|case (macro-caller ?value ?args state)
- (&/$Right state* output)
- (&/$Right (&/T [state* output]))
-
- (&/$Left error)
- ((&/fail-with-loc error) state)))
- ;; module-name &/get-module-name
- ;; :let [[r-prefix r-name] real-name
- ;; _ (->> (&/|map &/show-ast macro-expansion)
- ;; (&/|interpose "\n")
- ;; (&/fold str "")
- ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name))]
- ]
- (&/flat-map% (partial analyse exo-type) macro-expansion))
+ (|case =fn
+ [_ (&&/$var (&/$Global ?module ?name))]
+ (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)]
+ (|case (&&meta/meta-get &&meta/macro?-tag ?meta)
+ (&/$Some _)
+ (|do [macro-expansion (fn [state]
+ (|case (macro-caller ?value ?args state)
+ (&/$Right state* output)
+ (&/$Right (&/T [state* output]))
+
+ (&/$Left error)
+ ((&/fail-with-loc error) state)))
+ ;; module-name &/get-module-name
+ ;; :let [[r-prefix r-name] real-name
+ ;; _ (->> (&/|map &/show-ast macro-expansion)
+ ;; (&/|interpose "\n")
+ ;; (&/fold str "")
+ ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name))]
+ ]
+ (&/flat-map% (partial analyse exo-type) macro-expansion))
- _
- (do-analyse-apply analyse exo-type =fn ?args)))
-
- _
- (do-analyse-apply analyse exo-type =fn ?args))
- ))
+ _
+ (do-analyse-apply analyse exo-type =fn ?args)))
+
+ _
+ (do-analyse-apply analyse exo-type =fn ?args))
+ )
(defn analyse-case [analyse exo-type ?value ?branches]
(|do [:let [num-branches (&/|length ?branches)]
diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj
index bbb5f3888..df4fb293f 100644
--- a/luxc/src/lux/base.clj
+++ b/luxc/src/lux/base.clj
@@ -137,6 +137,11 @@
["compiler-version"
"compiler-mode"])
+;; Hosts
+(defvariant
+ ("Jvm" 1)
+ ("Js" 1))
+
(deftuple
["info"
"source"
@@ -221,7 +226,6 @@
;; [Exports]
(def ^:const value-field "_value")
-(def ^:const eval-field "_eval")
(def ^:const module-class-name "_")
(def ^:const +name-separator+ ";")
@@ -659,6 +663,18 @@
(return* state unit-tag)
(fail* msg)))))
+(defn |some [f xs]
+ "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))"
+ (|case xs
+ ($Nil)
+ $None
+
+ ($Cons x xs*)
+ (|case (f x)
+ ($None) (|some f xs*)
+ output output)
+ ))
+
(defn ^:private normalize-char [char]
(case char
\* "_ASTER_"
@@ -690,10 +706,6 @@
(defn normalize-name [ident]
(reduce str "" (map normalize-char ident)))
-(def classes
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $classes)))))
-
(def +init-bindings+
(T [;; "lux;counter"
0
@@ -711,9 +723,85 @@
+init-bindings+]
))
-(def loader
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $loader)))))
+(do-template [<tag> <host> <ask> <change> <with>]
+ (do (def <host>
+ (fn [compiler]
+ (|case (get$ $host compiler)
+ (<tag> host-data)
+ (return* compiler host-data)
+
+ _
+ (fail* "[Error] Wrong host."))))
+
+ (def <ask>
+ (fn [compiler]
+ (|case (get$ $host compiler)
+ (<tag> host-data)
+ (return* compiler true)
+
+ _
+ (return* compiler false))))
+
+ (defn <change> [slot updater]
+ (|do [host <host>]
+ (fn [compiler]
+ (return* (set$ $host (<tag> (update$ slot updater host)) compiler)
+ (get$ slot host)))))
+
+ (defn <with> [slot updater body]
+ (|do [old-val (<change> slot updater)
+ ?output-val body
+ new-val (<change> slot (fn [_] old-val))]
+ (return ?output-val))))
+
+ $Jvm jvm-host jvm? change-jvm-host-slot with-jvm-host-slot
+ $Js js-host js? change-js-host-slot with-js-host-slot
+ )
+
+(do-template [<name> <slot>]
+ (def <name>
+ (|do [host jvm-host]
+ (return (get$ <slot> host))))
+
+ loader $loader
+ classes $classes
+ get-type-env $type-env
+ )
+
+(def get-writer
+ (|do [host jvm-host]
+ (|case (get$ $writer host)
+ ($Some writer)
+ (return writer)
+
+ _
+ (fail-with-loc "[Error] Writer hasn't been set."))))
+
+(defn with-writer [writer body]
+ (with-jvm-host-slot $writer (fn [_] ($Some writer)) body))
+
+(defn with-type-env [type-env body]
+ "(All [a] (-> TypeEnv (Lux a) (Lux a)))"
+ (with-jvm-host-slot $type-env (partial |++ type-env) body))
+
+(defn push-dummy-name [real-name store-name]
+ (change-jvm-host-slot $dummy-mappings (partial $Cons (T [real-name store-name]))))
+
+(def pop-dummy-name
+ (change-jvm-host-slot $dummy-mappings |tail))
+
+(defn de-alias-class [class-name]
+ (|do [host jvm-host]
+ (return (|case (|some #(|let [[real-name store-name] %]
+ (if (= real-name class-name)
+ ($Some store-name)
+ $None))
+ (get$ $dummy-mappings host))
+ ($Some store-name)
+ store-name
+
+ _
+ class-name))))
(defn with-no-catches [body]
"(All [a] (-> (Lux a) (Lux a)))"
@@ -800,16 +888,6 @@
(fn [state]
(return* state (->> state (get$ $info) (get$ $compiler-mode)))))
-(def get-writer
- (fn [state]
- (let [writer* (->> state (get$ $host) (get$ $writer))]
- (|case writer*
- ($Some datum)
- (return* state datum)
-
- _
- ((fail-with-loc "[Error] Writer hasn't been set.") state)))))
-
(def get-top-local-env
(fn [state]
(try (let [top (|head (get$ $scopes state))]
@@ -933,18 +1011,6 @@
_
output)))))
-(defn with-writer [writer body]
- (fn [state]
- (let [old-writer (->> state (get$ $host) (get$ $writer))
- output (body (update$ $host #(set$ $writer ($Some writer) %) state))]
- (|case output
- ($Right ?state ?value)
- (return* (update$ $host #(set$ $writer old-writer %) ?state)
- ?value)
-
- _
- output))))
-
(defn with-expected-type [type body]
"(All [a] (-> Type (Lux a)))"
(fn [state]
@@ -1333,40 +1399,6 @@
output
output)))
-(defn |some [f xs]
- "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))"
- (|case xs
- ($Nil)
- $None
-
- ($Cons x xs*)
- (|case (f x)
- ($None) (|some f xs*)
- output output)
- ))
-
-(def get-type-env
- "(Lux TypeEnv)"
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $type-env)))))
-
-(defn with-type-env [type-env body]
- "(All [a] (-> TypeEnv (Lux a) (Lux a)))"
- (fn [state]
- (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %)
- state)]
- (|case (body state*)
- ($Right [state** output])
- ($Right (T [(update$ $host
- #(set$ $type-env
- (->> state (get$ $host) (get$ $type-env))
- %)
- state**)
- output]))
-
- ($Left msg)
- ($Left msg)))))
-
(defn |take [n xs]
(|case (T [n xs])
[0 _] $Nil
@@ -1412,38 +1444,6 @@
($Left msg)
($Left msg))))
-(defn push-dummy-name [real-name store-name]
- (fn [state]
- ($Right (T [(update$ $host
- #(update$ $dummy-mappings
- (partial $Cons (T [real-name store-name]))
- %)
- state)
- nil]))))
-
-(def pop-dummy-name
- (fn [state]
- ($Right (T [(update$ $host
- #(update$ $dummy-mappings
- |tail
- %)
- state)
- nil]))))
-
-(defn de-alias-class [class-name]
- (fn [state]
- ($Right (T [state
- (|case (|some #(|let [[real-name store-name] %]
- (if (= real-name class-name)
- ($Some store-name)
- $None))
- (->> state (get$ $host) (get$ $dummy-mappings)))
- ($Some store-name)
- store-name
-
- _
- class-name)]))))
-
(defn |eitherL [left right]
(fn [compiler]
(|case (run-state left compiler)
diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj
index 77e4221e8..7299b7166 100644
--- a/luxc/src/lux/compiler/cache.clj
+++ b/luxc/src/lux/compiler/cache.clj
@@ -23,7 +23,7 @@
:when (not (.isDirectory f))]
(.delete f)))
-(defn ^:private module-path [module]
+(defn ^:private ^String module-path [module]
(str @&&core/!output-dir
java.io.File/separator
(.replace ^String (&host/->module-class module) "/" java.io.File/separator)))
diff --git a/luxc/src/lux/compiler/core.clj b/luxc/src/lux/compiler/core.clj
index 6dacb4e54..15f03ea6e 100644
--- a/luxc/src/lux/compiler/core.clj
+++ b/luxc/src/lux/compiler/core.clj
@@ -4,9 +4,7 @@
[clojure.java.io :as io]
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail*]]
- [type :as &type]
- [host :as &host])
+ (lux [base :as & :refer [|let |do return* return fail*]])
(lux.analyser [base :as &a]
[module :as &a-module])
(lux.compiler.cache [type :as &&&type]
diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj
index 18b91f5bc..b43ab5b4d 100644
--- a/luxc/src/lux/compiler/js.clj
+++ b/luxc/src/lux/compiler/js.clj
@@ -137,7 +137,7 @@
(if module-exists?
(&/fail-with-loc (str "[Compiler Error] Can't re-define a module: " name))
(|do [_ (&&cache/delete name)
- _ &&/init-buffer
+ _ (&&/init-buffer)
_ (&a-module/create-module name file-hash)
_ (&a-module/flag-active-module name)
_ (if (= "lux" name)
diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj
index 50ece15e6..329252798 100644
--- a/luxc/src/lux/compiler/js/base.clj
+++ b/luxc/src/lux/compiler/js/base.clj
@@ -24,49 +24,40 @@
"buffer"])
(defn js-host []
- (&/T [;; "interpreter"
- (.getScriptEngine (new NashornScriptEngineFactory))
- ;; "buffer"
- &/$None
- ]))
+ (&/$Js (&/T [;; "interpreter"
+ (.getScriptEngine (new NashornScriptEngineFactory))
+ ;; "buffer"
+ &/$None
+ ])))
(def ^String module-js-name "module.js")
-(def init-buffer
- (fn [compiler-state]
- (&/$Right (&/T [(&/update$ &/$host
- (fn [host]
- (&/set$ $buffer
- (&/$Some (new StringBuilder))
- host))
- compiler-state)
- nil]))))
+(defn init-buffer []
+ (&/change-js-host-slot $buffer (fn [_] (&/$Some (new StringBuilder)))))
(def get-buffer
- (fn [compiler-state]
- (|case (->> compiler-state (&/get$ &/$host) (&/get$ $buffer))
+ (|do [host &/js-host]
+ (|case (&/get$ $buffer host)
(&/$Some _buffer)
- (&/$Right (&/T [compiler-state
- _buffer]))
+ (return _buffer)
(&/$None)
- (&/$Left "[Error] No buffer available."))))
+ (&/fail-with-loc "[Error] No buffer available."))))
(defn run-js! [^String js-code]
- (fn [compiler-state]
- (|let [^NashornScriptEngine interpreter (->> compiler-state (&/get$ &/$host) (&/get$ $interpreter))]
- (try (&/$Right (&/T [compiler-state
- (.eval interpreter js-code)]))
- (catch Exception ex
- (&/$Left (str ex)))))))
+ (|do [host &/js-host
+ :let [interpreter ^NashornScriptEngine (&/get$ $interpreter host)]]
+ (try (return (.eval interpreter js-code))
+ (catch Exception ex
+ (&/fail-with-loc (str ex))))))
(def ^:private lux-obj-class (Class/forName "[Ljava.lang.Object;"))
-(defn ^:private _slice_ [wrap-lux-obj value]
+(defn ^:private _slice_ [wrap-lux-obj ^"[Ljava.lang.Object;" value]
(reify JSObject
(isFunction [self] true)
(call [self this args]
- (let [slice (java.util.Arrays/copyOfRange value (aget args 0) (alength value))]
+ (let [slice (java.util.Arrays/copyOfRange value ^int (aget args 0) ^int (alength value))]
(wrap-lux-obj slice)))))
(defn ^:private _toString_ [obj]
@@ -102,7 +93,7 @@
;; else
(assert false (str "encode-char#getMember = " member))))))
-(deftype LuxJsObject [obj]
+(deftype LuxJsObject [^"[Ljava.lang.Object;" obj]
JSObject
(isFunction [self] false)
(getSlot [self idx]
@@ -139,7 +130,7 @@
(.hasMember js-object "C"))
(defn ^:private decode-char [^ScriptObjectMirror js-object]
- (-> (.getMember js-object "C")
+ (-> ^String (.getMember js-object "C")
(.charAt 0)))
(defn ^:private parse-int64 [^ScriptObjectMirror js-object]
diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj
index 0f86d8a33..5103b2d2b 100644
--- a/luxc/src/lux/compiler/js/lux.clj
+++ b/luxc/src/lux/compiler/js/lux.clj
@@ -314,8 +314,7 @@
";})(" (->> =env-values (&/|interpose ",") (&/fold str "")) ")"))))
(defn compile-def [compile ?name ?body def-meta]
- (|do [module-name &/get-module-name
- class-loader &/loader]
+ (|do [module-name &/get-module-name]
(|case (&a-meta/meta-get &a-meta/alias-tag def-meta)
(&/$Some (&/$IdentA [r-module r-name]))
(if (= 1 (&/|length def-meta))
diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj
index f09224c90..5cc3c1f79 100644
--- a/luxc/src/lux/compiler/jvm.clj
+++ b/luxc/src/lux/compiler/jvm.clj
@@ -140,7 +140,7 @@
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
class-name nil "java/lang/Object" nil)
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/value-field "Ljava/lang/Object;" nil nil)
(doto (.visitEnd)))
(.visitSource file-name nil))]
_ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
@@ -148,7 +148,7 @@
:let [_ (.visitCode *writer*)]
_ (compile-expression nil expr)
:let [_ (doto *writer*
- (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;")
+ (.visitFieldInsn Opcodes/PUTSTATIC class-name &/value-field "Ljava/lang/Object;")
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))]]
@@ -158,7 +158,7 @@
_ (&&/save-class! (str id) bytecode)
loader &/loader]
(-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id))
- (.getField &/eval-field)
+ (.getField &/value-field)
(.get nil)
return))))
@@ -228,19 +228,19 @@
(defn jvm-host []
(let [store (atom {})]
- (&/T [;; "lux;writer"
- &/$None
- ;; "lux;loader"
- (memory-class-loader store)
- ;; "lux;classes"
- store
- ;; "lux;module-states"
- (&/|table)
- ;; lux;type-env
- (&/|table)
- ;; lux;dummy-mappings
- (&/|table)
- ])))
+ (&/$Jvm (&/T [;; "lux;writer"
+ &/$None
+ ;; "lux;loader"
+ (memory-class-loader store)
+ ;; "lux;classes"
+ store
+ ;; "lux;module-states"
+ (&/|table)
+ ;; lux;type-env
+ (&/|table)
+ ;; lux;dummy-mappings
+ (&/|table)
+ ]))))
(let [!err! *err*]
(defn compile-program [mode program-module resources-dir source-dirs target-dir]
diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj
index d3805cabc..ad185e284 100644
--- a/luxc/src/lux/type.clj
+++ b/luxc/src/lux/type.clj
@@ -649,7 +649,7 @@
(def ^:private init-fixpoints &/$Nil)
-(defn ^:private check* [class-loader fixpoints invariant?? expected actual]
+(defn ^:private check* [fixpoints invariant?? expected actual]
(if (clojure.lang.Util/identical expected actual)
(return fixpoints)
(&/with-attempt
@@ -677,13 +677,13 @@
(return fixpoints))
[(&/$Some etype) (&/$None _)]
- (check* class-loader fixpoints invariant?? etype actual)
+ (check* fixpoints invariant?? etype actual)
[(&/$None _) (&/$Some atype)]
- (check* class-loader fixpoints invariant?? expected atype)
+ (check* fixpoints invariant?? expected atype)
[(&/$Some etype) (&/$Some atype)]
- (check* class-loader fixpoints invariant?? etype atype))))
+ (check* fixpoints invariant?? etype atype))))
[(&/$VarT ?id) _]
(fn [state]
@@ -693,7 +693,7 @@
(&/$Left _)
((|do [bound (deref ?id)]
- (check* class-loader fixpoints invariant?? bound actual))
+ (check* fixpoints invariant?? bound actual))
state)))
[_ (&/$VarT ?id)]
@@ -704,18 +704,18 @@
(&/$Left _)
((|do [bound (deref ?id)]
- (check* class-loader fixpoints invariant?? expected bound))
+ (check* fixpoints invariant?? expected bound))
state)))
[(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)]
(if (= eid aid)
- (check* class-loader fixpoints invariant?? eA aA)
+ (check* fixpoints invariant?? eA aA)
(check-error "" expected actual))
[(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)]
(fn [state]
(|case ((|do [F1 (deref ?id)]
- (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual))
+ (check* fixpoints invariant?? (&/$AppT F1 A1) actual))
state)
(&/$Right state* output)
(return* state* output)
@@ -724,34 +724,34 @@
(|case F2
(&/$UnivQ (&/$Cons _) _)
((|do [actual* (apply-type F2 A2)]
- (check* class-loader fixpoints invariant?? expected actual*))
+ (check* fixpoints invariant?? expected actual*))
state)
(&/$ExT _)
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)]
- (check* class-loader fixpoints* invariant?? A1 A2))
+ ((|do [fixpoints* (check* fixpoints invariant?? (&/$VarT ?id) F2)]
+ (check* fixpoints* invariant?? A1 A2))
state)
_
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)
+ ((|do [fixpoints* (check* fixpoints invariant?? (&/$VarT ?id) F2)
e* (apply-type F2 A1)
a* (apply-type F2 A2)]
- (check* class-loader fixpoints* invariant?? e* a*))
+ (check* fixpoints* invariant?? e* a*))
state))))
[(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)]
(fn [state]
(|case ((|do [F2 (deref ?id)]
- (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2)))
+ (check* fixpoints invariant?? expected (&/$AppT F2 A2)))
state)
(&/$Right state* output)
(return* state* output)
(&/$Left _)
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id))
+ ((|do [fixpoints* (check* fixpoints invariant?? F1 (&/$VarT ?id))
e* (apply-type F1 A1)
a* (apply-type F1 A2)]
- (check* class-loader fixpoints* invariant?? e* a*))
+ (check* fixpoints* invariant?? e* a*))
state)))
[(&/$AppT F A) _]
@@ -773,25 +773,25 @@
(&/$None)
(|do [expected* (apply-type F A)]
- (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual))))
+ (check* (fp-put fp-pair true fixpoints) invariant?? expected* actual))))
[_ (&/$AppT (&/$ExT aid) A)]
(check-error "" expected actual)
[_ (&/$AppT F A)]
(|do [actual* (apply-type F A)]
- (check* class-loader fixpoints invariant?? expected actual*))
+ (check* fixpoints invariant?? expected actual*))
[(&/$UnivQ _) _]
(|do [$arg existential
expected* (apply-type expected $arg)]
- (check* class-loader fixpoints invariant?? expected* actual))
+ (check* fixpoints invariant?? expected* actual))
[_ (&/$UnivQ _)]
(with-var
(fn [$arg]
(|do [actual* (apply-type actual $arg)
- =output (check* class-loader fixpoints invariant?? expected actual*)
+ =output (check* fixpoints invariant?? expected actual*)
_ (clean $arg expected)]
(return =output))))
@@ -799,24 +799,34 @@
(with-var
(fn [$arg]
(|do [expected* (apply-type expected $arg)
- =output (check* class-loader fixpoints invariant?? expected* actual)
+ =output (check* fixpoints invariant?? expected* actual)
_ (clean $arg actual)]
(return =output))))
[_ (&/$ExQ a!env a!def)]
(|do [$arg existential
actual* (apply-type actual $arg)]
- (check* class-loader fixpoints invariant?? expected actual*))
+ (check* fixpoints invariant?? expected actual*))
[(&/$HostT e!data) (&/$HostT a!data)]
- (&&host/check-host-types (partial check* class-loader fixpoints true)
- check-error
- fixpoints
- existential
- class-loader
- invariant??
- e!data
- a!data)
+ (|do [? &/jvm?]
+ (if ?
+ (|do [class-loader &/loader]
+ (&&host/check-host-types (partial check* fixpoints true)
+ check-error
+ fixpoints
+ existential
+ class-loader
+ invariant??
+ e!data
+ a!data))
+ (|let [[e!name e!params] e!data
+ [a!name a!params] a!data]
+ (if (and (= e!name a!name)
+ (= (&/|length e!params) (&/|length a!params)))
+ (|do [_ (&/map2% (partial check* fixpoints true) e!params a!params)]
+ (return fixpoints))
+ (check-error "" expected actual)))))
[(&/$VoidT) (&/$VoidT)]
(return fixpoints)
@@ -825,16 +835,16 @@
(return fixpoints)
[(&/$LambdaT eI eO) (&/$LambdaT aI aO)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? aI eI)]
- (check* class-loader fixpoints* invariant?? eO aO))
+ (|do [fixpoints* (check* fixpoints invariant?? aI eI)]
+ (check* fixpoints* invariant?? eO aO))
[(&/$ProdT eL eR) (&/$ProdT aL aR)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)]
- (check* class-loader fixpoints* invariant?? eR aR))
+ (|do [fixpoints* (check* fixpoints invariant?? eL aL)]
+ (check* fixpoints* invariant?? eR aR))
[(&/$SumT eL eR) (&/$SumT aL aR)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)]
- (check* class-loader fixpoints* invariant?? eR aR))
+ (|do [fixpoints* (check* fixpoints invariant?? eL aL)]
+ (check* fixpoints* invariant?? eR aR))
[(&/$ExT e!id) (&/$ExT a!id)]
(if (= e!id a!id)
@@ -842,10 +852,10 @@
(check-error "" expected actual))
[(&/$NamedT _ ?etype) _]
- (check* class-loader fixpoints invariant?? ?etype actual)
+ (check* fixpoints invariant?? ?etype actual)
[_ (&/$NamedT _ ?atype)]
- (check* class-loader fixpoints invariant?? expected ?atype)
+ (check* fixpoints invariant?? expected ?atype)
[_ _]
(&/fail ""))
@@ -853,8 +863,7 @@
(check-error err expected actual)))))
(defn check [expected actual]
- (|do [class-loader &/loader
- _ (check* class-loader init-fixpoints false expected actual)]
+ (|do [_ (check* init-fixpoints false expected actual)]
(return nil)))
(defn actual-type [type]
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 01:11:47 +0000