aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/data/collection/array.lux101
-rw-r--r--stdlib/source/lux/host/jvm/loader.old.lux (renamed from stdlib/source/lux/host/jvm/loader.jvm.lux)0
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux184
3 files changed, 163 insertions, 122 deletions
diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux
index 04b215cf8..4cb89c71b 100644
--- a/stdlib/source/lux/data/collection/array.lux
+++ b/stdlib/source/lux/data/collection/array.lux
@@ -21,42 +21,75 @@
{#.doc "Mutable arrays."}
(#.Primitive ..type-name (#.Cons a #.Nil)))
-(def: #export (new size)
- (All [a] (-> Nat (Array a)))
- (`` (for {(~~ (static host.old))
- (:assume ("jvm anewarray" "(java.lang.Object )" size))})))
+(with-expansions [<elem-type> (primitive "java.lang.Object")
+ <array-type> (type (Array <elem-type>))]
+ (def: #export (new size)
+ (All [a] (-> Nat (Array a)))
+ (`` (for {(~~ (static host.old))
+ (:assume ("jvm anewarray" "(java.lang.Object )" size))
-(def: #export (size xs)
- (All [a] (-> (Array a) Nat))
- (`` (for {(~~ (static host.old))
- ("jvm arraylength" xs)})))
+ (~~ (static host.jvm))
+ (:assume
+ (: (Array (primitive "java.lang.Object"))
+ ("jvm array new" size)))})))
-(def: #export (read i xs)
- (All [a]
- (-> Nat (Array a) (Maybe a)))
- (if (n/< (size xs) i)
+ (def: #export (size array)
+ (All [a] (-> (Array a) Nat))
(`` (for {(~~ (static host.old))
- (let [value ("jvm aaload" xs i)]
- (if ("jvm object null?" value)
- #.None
- (#.Some value)))}))
- #.None))
+ ("jvm arraylength" array)
+
+ (~~ (static host.jvm))
+ ("jvm array length" (:coerce <array-type> array))})))
+
+ (def: #export (read index array)
+ (All [a]
+ (-> Nat (Array a) (Maybe a)))
+ (if (n/< (size array) index)
+ (`` (for {(~~ (static host.old))
+ (let [value ("jvm aaload" array index)]
+ (if ("jvm object null?" value)
+ #.None
+ (#.Some value)))
+
+ (~~ (static host.jvm))
+ (let [value ("jvm array read" index (:coerce <array-type> array))]
+ (if ("jvm object null?" value)
+ #.None
+ (#.Some (:assume value))))}))
+ #.None))
+
+ (def: #export (write index value array)
+ (All [a]
+ (-> Nat a (Array a) (Array a)))
+ (`` (for {(~~ (static host.old))
+ ("jvm aastore" array index value)
+
+ (~~ (static host.jvm))
+ (:assume
+ ("jvm array write" index (:coerce <elem-type> value)
+ (:coerce <array-type> array)))})))
+
+ (def: #export (delete index array)
+ (All [a]
+ (-> Nat (Array a) (Array a)))
+ (if (n/< (size array) index)
+ (`` (for {(~~ (static host.old))
+ (write index (:assume ("jvm object null")) array)
+
+ (~~ (static host.jvm))
+ (write index (:assume (: <elem-type> ("jvm object null"))) array)}))
+ array))
+ )
(def: #export (contains? index array)
(All [a]
(-> Nat (Array a) Bit))
(case (..read index array)
(#.Some _)
- #1
+ true
_
- #0))
-
-(def: #export (write i x xs)
- (All [a]
- (-> Nat a (Array a) (Array a)))
- (`` (for {(~~ (static host.old))
- ("jvm aastore" xs i x)})))
+ false))
(def: #export (update index transform array)
(All [a]
@@ -75,14 +108,6 @@
(|> array (read index) (maybe.default default) transform)
array))
-(def: #export (delete i xs)
- (All [a]
- (-> Nat (Array a) (Array a)))
- (if (n/< (size xs) i)
- (`` (for {(~~ (static host.old))
- (write i (:assume ("jvm object null")) xs)}))
- xs))
-
(def: #export (copy length src-start src-array dest-start dest-array)
(All [a]
(-> Nat Nat (Array a) Nat (Array a)
@@ -221,14 +246,14 @@
(and prev
(case [(read idx xs) (read idx ys)]
[#.None #.None]
- #1
+ true
[(#.Some x) (#.Some y)]
(,@= x y)
_
- #0)))
- #1
+ false)))
+ true
(list.indices sxs))))))
(structure: #export monoid (All [a] (Monoid (Array a)))
@@ -287,6 +312,6 @@
(recur (inc idx)))
<init>))))]
- [every? #1 and]
- [any? #0 or]
+ [every? true and]
+ [any? false or]
)
diff --git a/stdlib/source/lux/host/jvm/loader.jvm.lux b/stdlib/source/lux/host/jvm/loader.old.lux
index 0ca92fa23..0ca92fa23 100644
--- a/stdlib/source/lux/host/jvm/loader.jvm.lux
+++ b/stdlib/source/lux/host/jvm/loader.old.lux
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux
index 13762272e..fe9a63f09 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux
@@ -19,7 +19,7 @@
["." type
["." check]]
["." macro
- ["s" syntax]]
+ ["s" syntax (#+ Syntax)]]
["." host (#+ import:)]]
["." // #_
["#." common]
@@ -30,7 +30,8 @@
[".A" type]
[".A" inference]]
["#/" // #_
- ["#." analysis (#+ Analysis Operation Handler Bundle)]]]]])
+ ["#." analysis (#+ Analysis Operation Handler Bundle)]
+ ["#." synthesis]]]]])
(type: Method-Signature
{#method Type
@@ -73,7 +74,6 @@
[unknown-class]
[primitives-cannot-have-type-parameters]
[primitives-are-not-objects]
- [invalid-type-for-array-element]
[unknown-field]
[mistaken-field-owner]
@@ -131,7 +131,7 @@
(def: bundle::conversion
Bundle
- (<| (///bundle.prefix "convert")
+ (<| (///bundle.prefix "conversion")
(|> ///bundle.empty
(///bundle.install "double-to-float" (//common.unary Double Float))
(///bundle.install "double-to-int" (//common.unary Double Integer))
@@ -220,6 +220,33 @@
["char" "java.lang.Character"])
(dictionary.from-list text.hash)))
+(def: (array-type-info arrayT)
+ (-> Type (Operation [Nat Text]))
+ (loop [level 0
+ currentT arrayT]
+ (case currentT
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
+ (#.Some outputT)
+ (recur level outputT)
+
+ #.None
+ (/////analysis.throw non-array arrayT))
+
+ (^ (#.Primitive (static array.type-name) (list elemT)))
+ (recur (inc level) elemT)
+
+ (#.Primitive class #.Nil)
+ (////@wrap [level class])
+
+ (#.Primitive class _)
+ (if (dictionary.contains? class boxes)
+ (/////analysis.throw primitives-cannot-have-type-parameters class)
+ (////@wrap [level class]))
+
+ _
+ (/////analysis.throw non-array arrayT))))
+
(def: array::length
Handler
(function (_ extension-name analyse args)
@@ -229,8 +256,12 @@
[_ (typeA.infer Nat)
[var-id varT] (typeA.with-env check.var)
arrayA (typeA.with-type (type (Array varT))
- (analyse arrayC))]
- (wrap (#/////analysis.Extension extension-name (list arrayA))))
+ (analyse arrayC))
+ varT (typeA.with-env (check.clean varT))
+ [array-nesting elem-class] (array-type-info (type (Array varT)))]
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat array-nesting)
+ (/////analysis.text elem-class)
+ arrayA))))
_
(/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
@@ -244,26 +275,7 @@
[lengthA (typeA.with-type Nat
(analyse lengthC))
expectedT (///.lift macro.expected-type)
- [level elem-class] (: (Operation [Nat Text])
- (loop [analysisT expectedT
- level 0]
- (case analysisT
- (#.Apply inputT funcT)
- (case (type.apply (list inputT) funcT)
- (#.Some outputT)
- (recur outputT level)
-
- #.None
- (/////analysis.throw non-array expectedT))
-
- (^ (#.Primitive "#Array" (list elemT)))
- (recur elemT (inc level))
-
- (#.Primitive class _)
- (wrap [level class])
-
- _
- (/////analysis.throw non-array expectedT))))
+ [level elem-class] (array-type-info expectedT)
_ (if (n/> 0 level)
(wrap [])
(/////analysis.throw non-array expectedT))]
@@ -292,8 +304,8 @@
([#.UnivQ]
[#.ExQ])
- (#.Apply inputT funcT)
- (case (type.apply (list inputT) funcT)
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
(#.Some outputT)
(check-jvm outputT)
@@ -311,39 +323,25 @@
(/////analysis.throw primitives-are-not-objects name)
(////@wrap name))))
-(def: (box-array-element-type elemT)
- (-> Type (Operation [Type Text]))
- (case elemT
- (#.Primitive name #.Nil)
- (let [boxed-name (|> (dictionary.get name boxes)
- (maybe.default name))]
- (////@wrap [(#.Primitive boxed-name #.Nil)
- boxed-name]))
-
- (#.Primitive name _)
- (if (dictionary.contains? name boxes)
- (/////analysis.throw primitives-cannot-have-type-parameters name)
- (////@wrap [elemT name]))
-
- _
- (/////analysis.throw invalid-type-for-array-element (%type elemT))))
-
(def: array::read
Handler
(function (_ extension-name analyse args)
(case args
- (^ (list arrayC idxC))
+ (^ (list idxC arrayC))
(do ////.monad
[[var-id varT] (typeA.with-env check.var)
_ (typeA.infer varT)
arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))
- ?elemT (typeA.with-env
- (check.read var-id))
- [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ varT (typeA.with-env
+ (check.clean varT))
+ [nesting elem-class] (array-type-info varT)
idxA (typeA.with-type Nat
(analyse idxC))]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA arrayA))))
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting))
+ (/////analysis.text elem-class)
+ idxA
+ arrayA))))
_
(/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
@@ -352,20 +350,24 @@
Handler
(function (_ extension-name analyse args)
(case args
- (^ (list arrayC idxC valueC))
+ (^ (list idxC valueC arrayC))
(do ////.monad
[[var-id varT] (typeA.with-env check.var)
_ (typeA.infer (type (Array varT)))
arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))
- ?elemT (typeA.with-env
- (check.read var-id))
- [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ varT (typeA.with-env
+ (check.clean varT))
+ [nesting elem-class] (array-type-info varT)
idxA (typeA.with-type Nat
(analyse idxC))
- valueA (typeA.with-type valueT
+ valueA (typeA.with-type varT
(analyse valueC))]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA valueA arrayA))))
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting))
+ (/////analysis.text elem-class)
+ idxA
+ valueA
+ arrayA))))
_
(/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
@@ -533,7 +535,7 @@
(wrap (#/////analysis.Extension extension-name (list (/////analysis.text class)))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
_
(/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
@@ -556,7 +558,7 @@
(/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= " class))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
_
(/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
@@ -644,7 +646,7 @@
[innerT (|> java-type
GenericArrayType::getGenericComponentType
(java-type-to-lux-type mappings))]
- (wrap (#.Primitive "#Array" (list innerT))))
+ (wrap (#.Primitive array.type-name (list innerT))))
_)
## else
@@ -756,7 +758,7 @@
" For value: " (%code valueC) text.new-line))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))))
(def: bundle::object
Bundle
@@ -845,7 +847,7 @@
(wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field)))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
_
(/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
@@ -867,7 +869,7 @@
(wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
_
(/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
@@ -886,7 +888,7 @@
(wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) objectA))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
_
(/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
@@ -910,7 +912,7 @@
(wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA objectA))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
_
(/////analysis.throw ///.incorrect-arity [extension-name 4 (list.size args)]))))
@@ -1163,6 +1165,10 @@
candidates
(/////analysis.throw too-many-candidates [class-name ..constructor-method candidates]))))
+(def: typed-input
+ (Syntax [Text Code])
+ (s.tuple (p.and s.text s.any)))
+
(def: (decorate-inputs typesT inputsA)
(-> (List Text) (List Analysis) (List Analysis))
(|> inputsA
@@ -1174,24 +1180,26 @@
Handler
(function (_ extension-name analyse args)
(case (: (Error [Text Text (List [Text Code])])
- (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any))))))
+ (s.run args ($_ p.and s.text s.text (p.some ..typed-input))))
(#error.Success [class method argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Static argsT)
[outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))
outputJC (check-jvm outputT)]
- (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method)
- (/////analysis.text outputJC) (decorate-inputs argsT argsA)))))
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (/////analysis.text method)
+ (/////analysis.text outputJC)
+ (decorate-inputs argsT argsA)))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))))
(def: invoke::virtual
Handler
(function (_ extension-name analyse args)
(case (: (Error [Text Text Code (List [Text Code])])
- (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))))))
+ (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input))))
(#error.Success [class method objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
@@ -1204,34 +1212,39 @@
_
(undefined))]
outputJC (check-jvm outputT)]
- (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method)
- (/////analysis.text outputJC) objectA (decorate-inputs argsT argsA)))))
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (/////analysis.text method)
+ (/////analysis.text outputJC)
+ objectA
+ (decorate-inputs argsT argsA)))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))))
(def: invoke::special
Handler
(function (_ extension-name analyse args)
- (case (: (Error [(List Code) [Text Text Code (List [Text Code]) Any]])
- (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!)))
- (#error.Success [_ [class method objectC argsTC _]])
+ (case (: (Error [Text Text Code (List [Text Code])])
+ (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input))))
+ (#error.Success [class method objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Special argsT)
[outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
outputJC (check-jvm outputT)]
- (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method)
- (/////analysis.text outputJC) (decorate-inputs argsT argsA)))))
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (/////analysis.text method)
+ (/////analysis.text outputJC)
+ (decorate-inputs argsT argsA)))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))))
(def: invoke::interface
Handler
(function (_ extension-name analyse args)
(case (: (Error [Text Text Code (List [Text Code])])
- (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))))))
+ (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input))))
(#error.Success [class-name method objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
@@ -1242,26 +1255,29 @@
[outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
outputJC (check-jvm outputT)]
(wrap (#/////analysis.Extension extension-name
- (list& (/////analysis.text class-name) (/////analysis.text method) (/////analysis.text outputJC)
+ (list& (/////analysis.text class-name)
+ (/////analysis.text method)
+ (/////analysis.text outputJC)
(decorate-inputs argsT argsA)))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))))
(def: invoke::constructor
Handler
(function (_ extension-name analyse args)
(case (: (Error [Text (List [Text Code])])
- (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any))))))
+ (s.run args ($_ p.and s.text (p.some ..typed-input))))
(#error.Success [class argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
[methodT exceptionsT] (constructor-candidate class argsT)
[outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))]
- (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (decorate-inputs argsT argsA)))))
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (decorate-inputs argsT argsA)))))
_
- (/////analysis.throw ///.invalid-syntax [extension-name args]))))
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))))
(def: bundle::member
Bundle
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 12:34:12 +0000