From 84b5e5becced7eaad0f733f13d4c9f5064dd63ea Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 17 Apr 2019 19:21:32 -0400 Subject: - Re-named the "lux convert ..." extensions to "lux conversion ...". - Fixed some issues with array extensions. --- .../luxc/lang/translation/jvm/procedure/host.lux | 168 ++++++++++--------- stdlib/source/lux/data/collection/array.lux | 101 ++++++----- stdlib/source/lux/host/jvm/loader.jvm.lux | 126 -------------- stdlib/source/lux/host/jvm/loader.old.lux | 126 ++++++++++++++ .../compiler/phase/extension/analysis/host.old.lux | 184 +++++++++++---------- 5 files changed, 381 insertions(+), 324 deletions(-) delete mode 100644 stdlib/source/lux/host/jvm/loader.jvm.lux create mode 100644 stdlib/source/lux/host/jvm/loader.old.lux diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index 45e025d0b..2e39860fc 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -61,60 +61,60 @@ (_.wrap ))))] - [convert::double-to-float #$.Double _.D2F #$.Float] - [convert::double-to-int #$.Double _.D2I #$.Int] - [convert::double-to-long #$.Double _.D2L #$.Long] - [convert::float-to-double #$.Float _.F2D #$.Double] - [convert::float-to-int #$.Float _.F2I #$.Int] - [convert::float-to-long #$.Float _.F2L #$.Long] - [convert::int-to-byte #$.Int _.I2B #$.Byte] - [convert::int-to-char #$.Int _.I2C #$.Char] - [convert::int-to-double #$.Int _.I2D #$.Double] - [convert::int-to-float #$.Int _.I2F #$.Float] - [convert::int-to-long #$.Int _.I2L #$.Long] - [convert::int-to-short #$.Int _.I2S #$.Short] - [convert::long-to-double #$.Long _.L2D #$.Double] - [convert::long-to-float #$.Long _.L2F #$.Float] - [convert::long-to-int #$.Long _.L2I #$.Int] - [convert::long-to-short #$.Long L2S #$.Short] - [convert::long-to-byte #$.Long L2B #$.Byte] - [convert::long-to-char #$.Long L2C #$.Char] - [convert::char-to-byte #$.Char _.I2B #$.Byte] - [convert::char-to-short #$.Char _.I2S #$.Short] - [convert::char-to-int #$.Char _.NOP #$.Int] - [convert::char-to-long #$.Char _.I2L #$.Long] - [convert::byte-to-long #$.Byte _.I2L #$.Long] - [convert::short-to-long #$.Short _.I2L #$.Long] + [conversion::double-to-float #$.Double _.D2F #$.Float] + [conversion::double-to-int #$.Double _.D2I #$.Int] + [conversion::double-to-long #$.Double _.D2L #$.Long] + [conversion::float-to-double #$.Float _.F2D #$.Double] + [conversion::float-to-int #$.Float _.F2I #$.Int] + [conversion::float-to-long #$.Float _.F2L #$.Long] + [conversion::int-to-byte #$.Int _.I2B #$.Byte] + [conversion::int-to-char #$.Int _.I2C #$.Char] + [conversion::int-to-double #$.Int _.I2D #$.Double] + [conversion::int-to-float #$.Int _.I2F #$.Float] + [conversion::int-to-long #$.Int _.I2L #$.Long] + [conversion::int-to-short #$.Int _.I2S #$.Short] + [conversion::long-to-double #$.Long _.L2D #$.Double] + [conversion::long-to-float #$.Long _.L2F #$.Float] + [conversion::long-to-int #$.Long _.L2I #$.Int] + [conversion::long-to-short #$.Long L2S #$.Short] + [conversion::long-to-byte #$.Long L2B #$.Byte] + [conversion::long-to-char #$.Long L2C #$.Char] + [conversion::char-to-byte #$.Char _.I2B #$.Byte] + [conversion::char-to-short #$.Char _.I2S #$.Short] + [conversion::char-to-int #$.Char _.NOP #$.Int] + [conversion::char-to-long #$.Char _.I2L #$.Long] + [conversion::byte-to-long #$.Byte _.I2L #$.Long] + [conversion::short-to-long #$.Short _.I2L #$.Long] ) (def: conversion Bundle - (<| (bundle.prefix "convert") + (<| (bundle.prefix "conversion") (|> (: Bundle bundle.empty) - (bundle.install "double-to-float" (unary convert::double-to-float)) - (bundle.install "double-to-int" (unary convert::double-to-int)) - (bundle.install "double-to-long" (unary convert::double-to-long)) - (bundle.install "float-to-double" (unary convert::float-to-double)) - (bundle.install "float-to-int" (unary convert::float-to-int)) - (bundle.install "float-to-long" (unary convert::float-to-long)) - (bundle.install "int-to-byte" (unary convert::int-to-byte)) - (bundle.install "int-to-char" (unary convert::int-to-char)) - (bundle.install "int-to-double" (unary convert::int-to-double)) - (bundle.install "int-to-float" (unary convert::int-to-float)) - (bundle.install "int-to-long" (unary convert::int-to-long)) - (bundle.install "int-to-short" (unary convert::int-to-short)) - (bundle.install "long-to-double" (unary convert::long-to-double)) - (bundle.install "long-to-float" (unary convert::long-to-float)) - (bundle.install "long-to-int" (unary convert::long-to-int)) - (bundle.install "long-to-short" (unary convert::long-to-short)) - (bundle.install "long-to-byte" (unary convert::long-to-byte)) - (bundle.install "long-to-char" (unary convert::long-to-char)) - (bundle.install "char-to-byte" (unary convert::char-to-byte)) - (bundle.install "char-to-short" (unary convert::char-to-short)) - (bundle.install "char-to-int" (unary convert::char-to-int)) - (bundle.install "char-to-long" (unary convert::char-to-long)) - (bundle.install "byte-to-long" (unary convert::byte-to-long)) - (bundle.install "short-to-long" (unary convert::short-to-long)) + (bundle.install "double-to-float" (unary conversion::double-to-float)) + (bundle.install "double-to-int" (unary conversion::double-to-int)) + (bundle.install "double-to-long" (unary conversion::double-to-long)) + (bundle.install "float-to-double" (unary conversion::float-to-double)) + (bundle.install "float-to-int" (unary conversion::float-to-int)) + (bundle.install "float-to-long" (unary conversion::float-to-long)) + (bundle.install "int-to-byte" (unary conversion::int-to-byte)) + (bundle.install "int-to-char" (unary conversion::int-to-char)) + (bundle.install "int-to-double" (unary conversion::int-to-double)) + (bundle.install "int-to-float" (unary conversion::int-to-float)) + (bundle.install "int-to-long" (unary conversion::int-to-long)) + (bundle.install "int-to-short" (unary conversion::int-to-short)) + (bundle.install "long-to-double" (unary conversion::long-to-double)) + (bundle.install "long-to-float" (unary conversion::long-to-float)) + (bundle.install "long-to-int" (unary conversion::long-to-int)) + (bundle.install "long-to-short" (unary conversion::long-to-short)) + (bundle.install "long-to-byte" (unary conversion::long-to-byte)) + (bundle.install "long-to-char" (unary conversion::long-to-char)) + (bundle.install "char-to-byte" (unary conversion::char-to-byte)) + (bundle.install "char-to-short" (unary conversion::char-to-short)) + (bundle.install "char-to-int" (unary conversion::char-to-int)) + (bundle.install "char-to-long" (unary conversion::char-to-long)) + (bundle.install "byte-to-long" (unary conversion::byte-to-long)) + (bundle.install "short-to-long" (unary conversion::short-to-long)) ))) (template [ ] @@ -284,37 +284,49 @@ (bundle.install "<" (binary char::<)) ))) -(def: (array::length arrayD arrayI) - (Binary Inst) - (|>> arrayI - (_.CHECKCAST arrayD) - _.ARRAYLENGTH - _.I2L - (_.wrap #$.Long))) +(def: (array-java-type nesting elem-class) + (-> Nat Text $.Type) + (_t.array nesting + (case elem-class + "boolean" _t.boolean + "byte" _t.byte + "short" _t.short + "int" _t.int + "long" _t.long + "float" _t.float + "double" _t.double + "char" _t.char + _ (_t.class elem-class (list))))) + +(def: (array::length proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.i64 nesting) + (synthesis.text elem-class) + arrayS)) + (do phase.monad + [arrayI (generate arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) + _.ARRAYLENGTH + _.I2L + (_.wrap #$.Long)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) (def: (array::new proc generate inputs) Handler (case inputs - (^ (list (synthesis.i64 level) - (synthesis.text class) + (^ (list (synthesis.i64 nesting) + (synthesis.text elem-class) lengthS)) (do phase.monad - [lengthI (generate lengthS) - #let [arrayJT (_t.array (.nat level) - (case class - "boolean" _t.boolean - "byte" _t.byte - "short" _t.short - "int" _t.int - "long" _t.long - "float" _t.float - "double" _t.double - "char" _t.char - _ (_t.class class (list))))]] + [lengthI (generate lengthS)] (wrap (|>> lengthI (_.unwrap #$.Long) _.L2I - (_.array arrayJT)))) + (_.array (array-java-type (.nat nesting) elem-class))))) _ (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) @@ -322,13 +334,14 @@ (def: (array::read proc generate inputs) Handler (case inputs - (^ (list (synthesis.text class) + (^ (list (synthesis.i64 nesting) + (synthesis.text elem-class) idxS arrayS)) (do phase.monad [arrayI (generate arrayS) idxI (generate idxS) - #let [loadI (case class + #let [loadI (case elem-class "boolean" (|>> _.BALOAD (_.wrap #$.Boolean)) "byte" (|>> _.BALOAD (_.wrap #$.Byte)) "short" (|>> _.SALOAD (_.wrap #$.Short)) @@ -339,6 +352,7 @@ "char" (|>> _.CALOAD (_.wrap #$.Char)) _ _.AALOAD)]] (wrap (|>> arrayI + (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) idxI (_.unwrap #$.Long) _.L2I @@ -350,7 +364,8 @@ (def: (array::write proc generate inputs) Handler (case inputs - (^ (list (synthesis.text class) + (^ (list (synthesis.i64 nesting) + (synthesis.text elem-class) idxS valueS arrayS)) @@ -358,7 +373,7 @@ [arrayI (generate arrayS) idxI (generate idxS) valueI (generate valueS) - #let [storeI (case class + #let [storeI (case elem-class "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE) "byte" (|>> (_.unwrap #$.Byte) _.BASTORE) "short" (|>> (_.unwrap #$.Short) _.SASTORE) @@ -369,6 +384,7 @@ "char" (|>> (_.unwrap #$.Char) _.CASTORE) _ _.AASTORE)]] (wrap (|>> arrayI + (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) _.DUP idxI (_.unwrap #$.Long) @@ -383,7 +399,7 @@ Bundle (<| (bundle.prefix "array") (|> (: Bundle bundle.empty) - (bundle.install "length" (unary array::length)) + (bundle.install "length" array::length) (bundle.install "new" array::new) (bundle.install "read" array::read) (bundle.install "write" array::write) 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 [ (primitive "java.lang.Object") + (type (Array ))] + (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))}))) + + (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))] + (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 value) + (:coerce 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 (: ("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))) ))))] - [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.jvm.lux deleted file mode 100644 index 0ca92fa23..000000000 --- a/stdlib/source/lux/host/jvm/loader.jvm.lux +++ /dev/null @@ -1,126 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - ["." io (#+ IO)] - [concurrency - ["." atom (#+ Atom)]]] - [data - ["." error (#+ Error)] - ["." text - format] - [collection - ["." array] - ["." list ("#;." functor)] - ["." dictionary (#+ Dictionary)]]] - [world - ["." binary (#+ Binary)]] - ["." host (#+ import: object do-to)]]) - -(type: #export Library - (Atom (Dictionary Text Binary))) - -(exception: #export (already-stored {class Text}) - (ex.report ["Class" class])) - -(exception: #export (unknown {class Text} {known-classes (List Text)}) - (ex.report ["Class" class] - ["Known classes" (|> known-classes - (list.sort (:: text.order <)) - (list;map (|>> (format text.new-line text.tab))) - (text.join-with ""))])) - -(exception: #export (cannot-define {class Text} {error Text}) - (ex.report ["Class" class] - ["Error" error])) - -(import: #long java/lang/Object - (getClass [] (java/lang/Class java/lang/Object))) - -(import: #long java/lang/String) - -(import: #long java/lang/reflect/Method - (invoke [java/lang/Object (Array java/lang/Object)] - #try java/lang/Object)) - -(import: #long (java/lang/Class a) - (getDeclaredMethod [java/lang/String (Array (java/lang/Class java/lang/Object))] - #try java/lang/reflect/Method)) - -(import: #long java/lang/Integer - (#static TYPE (java/lang/Class java/lang/Integer))) - -(import: #long java/lang/reflect/AccessibleObject - (setAccessible [boolean] void)) - -(import: #long java/lang/ClassLoader - (loadClass [java/lang/String] - #io #try (java/lang/Class java/lang/Object))) - -(def: java/lang/ClassLoader::defineClass - java/lang/reflect/Method - (let [signature (|> (host.array (java/lang/Class java/lang/Object) 4) - (host.array-write 0 (:coerce (java/lang/Class java/lang/Object) - (host.class-for java/lang/String))) - (host.array-write 1 (java/lang/Object::getClass (host.array byte 0))) - (host.array-write 2 (:coerce (java/lang/Class java/lang/Object) - (java/lang/Integer::TYPE))) - (host.array-write 3 (:coerce (java/lang/Class java/lang/Object) - (java/lang/Integer::TYPE))))] - (do-to (error.assume - (java/lang/Class::getDeclaredMethod "defineClass" - signature - (host.class-for java/lang/ClassLoader))) - (java/lang/reflect/AccessibleObject::setAccessible true)))) - -(def: #export (define class-name bytecode loader) - (-> Text Binary java/lang/ClassLoader (Error java/lang/Object)) - (let [signature (array.from-list (list (:coerce java/lang/Object - class-name) - (:coerce java/lang/Object - bytecode) - (:coerce java/lang/Object - (host.long-to-int +0)) - (:coerce java/lang/Object - (host.long-to-int (.int (binary.size bytecode))))))] - (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) - -(def: #export (new-library _) - (-> Any Library) - (atom.atom (dictionary.new text.hash))) - -(def: #export (memory library) - (-> Library java/lang/ClassLoader) - (object [] java/lang/ClassLoader [] - [] - (java/lang/ClassLoader (findClass {class-name java/lang/String}) java/lang/Class - (let [classes (|> library atom.read io.run)] - (case (dictionary.get class-name classes) - (#.Some bytecode) - (case (|> _jvm_this - (..define class-name bytecode)) - (#error.Success class) - (:assume class) - - (#error.Failure error) - (error! (ex.construct ..cannot-define [class-name error]))) - - #.None - (error! (ex.construct ..unknown [class-name (dictionary.keys classes)]))))))) - -(def: #export (store name bytecode library) - (-> Text Binary Library (IO (Error Any))) - (do io.monad - [library' (atom.read library)] - (if (dictionary.contains? name library') - (wrap (ex.throw ..already-stored name)) - (do @ - [_ (atom.update (dictionary.put name bytecode) library)] - (wrap (#error.Success [])))))) - -(def: #export (load name loader) - (-> Text java/lang/ClassLoader - (IO (Error (java/lang/Class java/lang/Object)))) - (java/lang/ClassLoader::loadClass name loader)) diff --git a/stdlib/source/lux/host/jvm/loader.old.lux b/stdlib/source/lux/host/jvm/loader.old.lux new file mode 100644 index 000000000..0ca92fa23 --- /dev/null +++ b/stdlib/source/lux/host/jvm/loader.old.lux @@ -0,0 +1,126 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)] + ["." io (#+ IO)] + [concurrency + ["." atom (#+ Atom)]]] + [data + ["." error (#+ Error)] + ["." text + format] + [collection + ["." array] + ["." list ("#;." functor)] + ["." dictionary (#+ Dictionary)]]] + [world + ["." binary (#+ Binary)]] + ["." host (#+ import: object do-to)]]) + +(type: #export Library + (Atom (Dictionary Text Binary))) + +(exception: #export (already-stored {class Text}) + (ex.report ["Class" class])) + +(exception: #export (unknown {class Text} {known-classes (List Text)}) + (ex.report ["Class" class] + ["Known classes" (|> known-classes + (list.sort (:: text.order <)) + (list;map (|>> (format text.new-line text.tab))) + (text.join-with ""))])) + +(exception: #export (cannot-define {class Text} {error Text}) + (ex.report ["Class" class] + ["Error" error])) + +(import: #long java/lang/Object + (getClass [] (java/lang/Class java/lang/Object))) + +(import: #long java/lang/String) + +(import: #long java/lang/reflect/Method + (invoke [java/lang/Object (Array java/lang/Object)] + #try java/lang/Object)) + +(import: #long (java/lang/Class a) + (getDeclaredMethod [java/lang/String (Array (java/lang/Class java/lang/Object))] + #try java/lang/reflect/Method)) + +(import: #long java/lang/Integer + (#static TYPE (java/lang/Class java/lang/Integer))) + +(import: #long java/lang/reflect/AccessibleObject + (setAccessible [boolean] void)) + +(import: #long java/lang/ClassLoader + (loadClass [java/lang/String] + #io #try (java/lang/Class java/lang/Object))) + +(def: java/lang/ClassLoader::defineClass + java/lang/reflect/Method + (let [signature (|> (host.array (java/lang/Class java/lang/Object) 4) + (host.array-write 0 (:coerce (java/lang/Class java/lang/Object) + (host.class-for java/lang/String))) + (host.array-write 1 (java/lang/Object::getClass (host.array byte 0))) + (host.array-write 2 (:coerce (java/lang/Class java/lang/Object) + (java/lang/Integer::TYPE))) + (host.array-write 3 (:coerce (java/lang/Class java/lang/Object) + (java/lang/Integer::TYPE))))] + (do-to (error.assume + (java/lang/Class::getDeclaredMethod "defineClass" + signature + (host.class-for java/lang/ClassLoader))) + (java/lang/reflect/AccessibleObject::setAccessible true)))) + +(def: #export (define class-name bytecode loader) + (-> Text Binary java/lang/ClassLoader (Error java/lang/Object)) + (let [signature (array.from-list (list (:coerce java/lang/Object + class-name) + (:coerce java/lang/Object + bytecode) + (:coerce java/lang/Object + (host.long-to-int +0)) + (:coerce java/lang/Object + (host.long-to-int (.int (binary.size bytecode))))))] + (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) + +(def: #export (new-library _) + (-> Any Library) + (atom.atom (dictionary.new text.hash))) + +(def: #export (memory library) + (-> Library java/lang/ClassLoader) + (object [] java/lang/ClassLoader [] + [] + (java/lang/ClassLoader (findClass {class-name java/lang/String}) java/lang/Class + (let [classes (|> library atom.read io.run)] + (case (dictionary.get class-name classes) + (#.Some bytecode) + (case (|> _jvm_this + (..define class-name bytecode)) + (#error.Success class) + (:assume class) + + (#error.Failure error) + (error! (ex.construct ..cannot-define [class-name error]))) + + #.None + (error! (ex.construct ..unknown [class-name (dictionary.keys classes)]))))))) + +(def: #export (store name bytecode library) + (-> Text Binary Library (IO (Error Any))) + (do io.monad + [library' (atom.read library)] + (if (dictionary.contains? name library') + (wrap (ex.throw ..already-stored name)) + (do @ + [_ (atom.update (dictionary.put name bytecode) library)] + (wrap (#error.Success [])))))) + +(def: #export (load name loader) + (-> Text java/lang/ClassLoader + (IO (Error (java/lang/Class java/lang/Object)))) + (java/lang/ClassLoader::loadClass name loader)) 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 -- cgit v1.2.3