diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/parser/text.lux | 82 | ||||
| -rw-r--r-- | stdlib/source/lux/control/parser/xml.lux | 14 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/json.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/xml.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/host.jvm.lux | 53 | ||||
| -rw-r--r-- | stdlib/source/lux/math/modular.lux | 13 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/type.lux | 97 | ||||
| -rw-r--r-- | stdlib/source/lux/time/date.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux | 78 |
9 files changed, 241 insertions, 108 deletions
diff --git a/stdlib/source/lux/control/parser/text.lux b/stdlib/source/lux/control/parser/text.lux index bf4c45867..7c7c7fe4a 100644 --- a/stdlib/source/lux/control/parser/text.lux +++ b/stdlib/source/lux/control/parser/text.lux @@ -28,8 +28,6 @@ {#basis Offset #distance Offset}) -(def: cannot-lex-error Text "Cannot lex from empty text.") - (def: (remaining offset tape) (-> Offset Text Text) (|> tape (/.split offset) maybe.assume product.right)) @@ -40,27 +38,35 @@ ["Input size" (nat@encode (/.size tape))] ["Remaining input" (remaining offset tape)])) -(def: #export (run input lexer) - (All [a] (-> Text (Parser a) (Error a))) - (case (lexer [start-offset input]) +(exception: #export (expected-to-fail {offset Offset} {tape Text}) + (exception.report + ["Offset" (nat@encode offset)] + ["Input" (remaining offset tape)])) + +(exception: #export cannot-parse) +(exception: #export cannot-slice) + +(def: #export (run parser input) + (All [a] (-> (Parser a) Text (Error a))) + (case (parser [start-offset input]) (#error.Failure msg) (#error.Failure msg) (#error.Success [[end-offset _] output]) (if (n/= end-offset (/.size input)) (#error.Success output) - (exception.throw unconsumed-input [end-offset input])))) + (exception.throw ..unconsumed-input [end-offset input])))) (def: #export offset (Parser Offset) (function (_ (^@ input [offset tape])) (#error.Success [input offset]))) -(def: (with-slices lexer) +(def: (with-slices parser) (-> (Parser (List Slice)) (Parser Slice)) (do //.monad [offset ..offset - slices lexer] + slices parser] (wrap (list@fold (function (_ [slice::basis slice::distance] [total::basis total::distance]) [total::basis ("lux i64 +" slice::distance total::distance)]) @@ -77,7 +83,7 @@ (#error.Success [[("lux i64 +" 1 offset) tape] (/.from-code output)]) _ - (#error.Failure cannot-lex-error)))) + (exception.throw ..cannot-parse [])))) (def: #export any! {#.doc "Just returns the next character without applying any logic."} @@ -89,7 +95,7 @@ (template [<name> <type> <any>] [(def: #export (<name> p) - {#.doc "Produce a character if the lexer fails."} + {#.doc "Produce a character if the parser fails."} (All [a] (-> (Parser a) (Parser <type>))) (function (_ input) (case (p input) @@ -97,7 +103,7 @@ (<any> input) _ - (#error.Failure "Expected to fail@ yet succeeded."))))] + (exception.throw ..expected-to-fail input))))] [not Text ..any] [not! Slice ..any!] @@ -130,15 +136,15 @@ (#error.Success [input #0])))) (def: #export end - {#.doc "Ensure the lexer's input is empty."} + {#.doc "Ensure the parser's input is empty."} (Parser Any) (function (_ (^@ input [offset tape])) (if (n/= offset (/.size tape)) (#error.Success [input []]) - (exception.throw unconsumed-input [offset tape])))) + (exception.throw ..unconsumed-input input)))) (def: #export end? - {#.doc "Ask if the lexer's input is empty."} + {#.doc "Ask if the parser's input is empty."} (Parser Bit) (function (_ (^@ input [offset tape])) (#error.Success [input (n/= offset (/.size tape))]))) @@ -152,7 +158,7 @@ (#error.Success [input (/.from-code output)]) _ - (#error.Failure cannot-lex-error)))) + (exception.throw ..cannot-parse [])))) (def: #export get-input {#.doc "Get all of the remaining input (without consuming it)."} @@ -216,7 +222,7 @@ "be one of: " options)))) _ - (#error.Failure cannot-lex-error))))] + (exception.throw ..cannot-parse []))))] [one-of "" |>] [none-of " not" .not] @@ -239,7 +245,7 @@ "be one of: " options)))) _ - (#error.Failure cannot-lex-error))))] + (exception.throw ..cannot-parse []))))] [one-of! "" |>] [none-of! " not" .not] @@ -256,7 +262,7 @@ (#error.Failure ($_ /@compose "Character does not satisfy predicate: " (/.from-code output)))) _ - (#error.Failure cannot-lex-error)))) + (exception.throw ..cannot-parse [])))) (def: #export space {#.doc "Only lex white-space."} @@ -278,30 +284,30 @@ (wrap [left::basis ("lux i64 +" left::distance right::distance)]))) (template [<name> <base> <doc-modifier>] - [(def: #export (<name> lexer) + [(def: #export (<name> parser) {#.doc (code.text ($_ /@compose "Lex " <doc-modifier> " characters as a single continuous text."))} (-> (Parser Text) (Parser Text)) - (|> lexer <base> (:: //.monad map /.concat)))] + (|> parser <base> (:: //.monad map /.concat)))] [some //.some "some"] [many //.many "many"] ) (template [<name> <base> <doc-modifier>] - [(def: #export (<name> lexer) + [(def: #export (<name> parser) {#.doc (code.text ($_ /@compose "Lex " <doc-modifier> " characters as a single continuous text."))} (-> (Parser Slice) (Parser Slice)) - (with-slices (<base> lexer)))] + (with-slices (<base> parser)))] [some! //.some "some"] [many! //.many "many"] ) (template [<name> <base> <doc-modifier>] - [(def: #export (<name> amount lexer) + [(def: #export (<name> amount parser) {#.doc (code.text ($_ /@compose "Lex " <doc-modifier> " N characters."))} (-> Nat (Parser Text) (Parser Text)) - (|> lexer (<base> amount) (:: //.monad map /.concat)))] + (|> parser (<base> amount) (:: //.monad map /.concat)))] [exactly //.exactly "exactly"] [at-most //.at-most "at most"] @@ -309,51 +315,51 @@ ) (template [<name> <base> <doc-modifier>] - [(def: #export (<name> amount lexer) + [(def: #export (<name> amount parser) {#.doc (code.text ($_ /@compose "Lex " <doc-modifier> " N characters."))} (-> Nat (Parser Slice) (Parser Slice)) - (with-slices (<base> amount lexer)))] + (with-slices (<base> amount parser)))] [exactly! //.exactly "exactly"] [at-most! //.at-most "at most"] [at-least! //.at-least "at least"] ) -(def: #export (between from to lexer) +(def: #export (between from to parser) {#.doc "Lex between N and M characters."} (-> Nat Nat (Parser Text) (Parser Text)) - (|> lexer (//.between from to) (:: //.monad map /.concat))) + (|> parser (//.between from to) (:: //.monad map /.concat))) -(def: #export (between! from to lexer) +(def: #export (between! from to parser) {#.doc "Lex between N and M characters."} (-> Nat Nat (Parser Slice) (Parser Slice)) - (with-slices (//.between from to lexer))) + (with-slices (//.between from to parser))) -(def: #export (enclosed [start end] lexer) +(def: #export (enclosed [start end] parser) (All [a] (-> [Text Text] (Parser a) (Parser a))) - (|> lexer + (|> parser (//.before (this end)) (//.after (this start)))) -(def: #export (local local-input lexer) - {#.doc "Run a lexer with the given input, instead of the real one."} +(def: #export (local local-input parser) + {#.doc "Run a parser with the given input, instead of the real one."} (All [a] (-> Text (Parser a) (Parser a))) (function (_ real-input) - (case (run local-input lexer) + (case (run parser local-input) (#error.Failure error) (#error.Failure error) (#error.Success value) (#error.Success [real-input value])))) -(def: #export (slice lexer) +(def: #export (slice parser) (-> (Parser Slice) (Parser Text)) (do //.monad - [[basis distance] lexer] + [[basis distance] parser] (function (_ (^@ input [offset tape])) (case (/.clip basis ("lux i64 +" basis distance) tape) (#.Some output) (#error.Success [input output]) #.None - (#error.Failure "Cannot slice."))))) + (exception.throw ..cannot-slice []))))) diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux index a2ae5dbec..be5c0f7b6 100644 --- a/stdlib/source/lux/control/parser/xml.lux +++ b/stdlib/source/lux/control/parser/xml.lux @@ -68,9 +68,9 @@ (#.Some value) (#error.Success [docs value])))))) -(def: (run' docs reader) - (All [a] (-> (List XML) (Parser a) (Error a))) - (case (//.run docs reader) +(def: (run' reader docs) + (All [a] (-> (Parser a) (List XML) (Error a))) + (case (//.run reader docs) (#error.Success [remaining output]) (if (list.empty? remaining) (#error.Success output) @@ -110,7 +110,7 @@ (#/.Node _tag _attrs _children) (do error.monad - [output (run' _children reader)] + [output (run' reader _children)] (wrap [tail output])))))) (def: #export ignore @@ -123,6 +123,6 @@ (#.Cons head tail) (#error.Success [tail []])))) -(def: #export (run document reader) - (All [a] (-> XML (Parser a) (Error a))) - (run' (list document) reader)) +(def: #export (run reader document) + (All [a] (-> (Parser a) XML (Error a))) + (run' reader (list document))) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 1bbdc4ee0..219f7cd9b 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -356,4 +356,4 @@ (structure: #export codec (Codec Text JSON) (def: encode ..format) - (def: decode (function (_ input) (l.run input (json~' []))))) + (def: decode (l.run (json~' [])))) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index bd4fef488..3c81ef889 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -171,9 +171,9 @@ (p.after (p.some comment^)) (p.after (p.maybe xml-header^)))) -(def: #export (read input) +(def: #export read (-> Text (Error XML)) - (l.run input xml^)) + (l.run xml^)) (def: (sanitize-value input) (-> Text Text) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 8a5b0d849..cb08e1cce 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -29,7 +29,7 @@ ["#" type (#+ Primitive Var Bound Class Generic Type Argument Return Typed)]]]]) (template [<name> <class>] - [(type: #export <name> (#.Primitive <class> #.Nil))] + [(def: #export <name> .Type (#.Primitive <class> #.Nil))] ## Boxes [Boolean "java.lang.Boolean"] @@ -460,13 +460,44 @@ (-> [Text Code] Code) (` [(~ (code.text class)) (~ value)])) +(def: (simple-class type) + (-> Type Text) + (case type + (#jvm.Primitive prim) + (case prim + #jvm.Boolean "boolean" + #jvm.Byte "byte" + #jvm.Short "short" + #jvm.Int "int" + #jvm.Long "long" + #jvm.Float "float" + #jvm.Double "double" + #jvm.Char "char") + + (#jvm.Array sub) + (sanitize (jvm.descriptor type)) + + (#jvm.Generic generic) + (case generic + (#jvm.Class class params) + (sanitize class) + + (^or (#jvm.Var name) + (#jvm.Wildcard #.None) + (#jvm.Wildcard (#.Some [#jvm.Lower bound]))) + "java.lang.Object" + + (#jvm.Wildcard (#.Some [#jvm.Upper bound])) + (simple-class (#jvm.Generic bound))) + )) + (def: (make-constructor-parser class-name arguments) (-> Text (List Argument) (Parser Code)) (do p.monad [args (: (Parser (List Code)) (s.form (p.after (s.this! (' ::new!)) (s.tuple (p.exactly (list.size arguments) s.any))))) - #let [arguments' (list@map (|>> product.right jvm.signature) arguments)]] + #let [arguments' (list@map (|>> product.right ..simple-class) arguments)]] (wrap (` ("jvm member invoke constructor" (~ (code.text class-name)) (~+ (|> args (list.zip2 arguments') @@ -479,7 +510,7 @@ args (: (Parser (List Code)) (s.form (p.after (s.this! (code.identifier ["" dotted-name])) (s.tuple (p.exactly (list.size arguments) s.any))))) - #let [arguments' (list@map (|>> product.right jvm.signature) arguments)]] + #let [arguments' (list@map (|>> product.right ..simple-class) arguments)]] (wrap (` ("jvm member invoke static" (~ (code.text class-name)) (~ (code.text method-name)) (~+ (|> args (list.zip2 arguments') @@ -493,7 +524,7 @@ args (: (Parser (List Code)) (s.form (p.after (s.this! (code.identifier ["" dotted-name])) (s.tuple (p.exactly (list.size arguments) s.any))))) - #let [arguments' (list@map (|>> product.right jvm.signature) arguments)]] + #let [arguments' (list@map (|>> product.right ..simple-class) arguments)]] (wrap (` (<jvm-op> (~ (code.text class-name)) (~ (code.text method-name)) (~' _jvm_this) (~+ (|> args @@ -1111,7 +1142,7 @@ (let [super-replacer (parser->replacer (s.form (do p.monad [_ (s.this! (' ::super!)) args (s.tuple (p.exactly (list.size arguments) s.any)) - #let [arguments' (list@map (|>> product.right jvm.signature) arguments)]] + #let [arguments' (list@map (|>> product.right ..simple-class) arguments)]] (wrap (` ("jvm member invoke special" (~ (code.text (product.left super-class))) (~ (code.text name)) @@ -1344,7 +1375,7 @@ (#.Some value-as-string) #.None))} (with-gensyms [g!_ g!unchecked] - (let [class-name (jvm.signature class) + (let [class-name (..simple-class class) class-type (` (.primitive (~ (code.text class-name)))) check-type (` (.Maybe (~ class-type))) check-code (` (if ((~ (code.text (format "jvm instanceof" ":" class-name))) (~ g!unchecked)) @@ -1424,7 +1455,7 @@ (with-gensyms [arg-name] (wrap [maybe? arg-name])))) import-member-args) - #let [arg-classes (list@map (|>> product.right jvm.signature) import-member-args) + #let [arg-classes (list@map (|>> product.right ..simple-class) import-member-args) arg-types (list@map (: (-> [Bit Type] Code) (function (_ [maybe? arg]) (let [arg-type (jvm-type (get@ #import-member-mode commons) arg)] @@ -1610,7 +1641,7 @@ jvm.void-descriptor (#.Some return) - (jvm.signature return)) + (..simple-class return)) jvm-interop (|> [method-return-class (` ((~ (code.text jvm-op)) (~ (code.text full-name)) @@ -1643,7 +1674,7 @@ (` ((~ getter-name))) (` ((~ getter-name) (~ g!obj)))) getter-body (<| (auto-convert-output import-field-mode) - [(jvm.signature import-field-type) + [(..simple-class import-field-type) (if import-field-static? (get-static-field full-name import-field-name) (get-virtual-field full-name import-field-name (un-quote g!obj)))]) @@ -1661,7 +1692,7 @@ (let [setter-call (if import-field-static? (` ((~ setter-name) (~ g!value))) (` ((~ setter-name) (~ g!value) (~ g!obj)))) - setter-value (|> [(jvm.signature import-field-type) (un-quote g!value)] + setter-value (|> [(..simple-class import-field-type) (un-quote g!value)] ..jvm-input (auto-convert-input import-field-mode)) setter-value (if import-field-maybe? @@ -1884,7 +1915,7 @@ {type (..type^ imports (list))}) {#.doc (doc "Loads the class as a java.lang.Class object." (class-for java/lang/String))} - (wrap (list (` ("jvm object class" (~ (code.text (jvm.signature type)))))))) + (wrap (list (` ("jvm object class" (~ (code.text (..simple-class type)))))))) (def: get-compiler (Meta Lux) diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux index 76c85ec1b..fa26f0abe 100644 --- a/stdlib/source/lux/math/modular.lux +++ b/stdlib/source/lux/math/modular.lux @@ -96,13 +96,12 @@ separator (int@encode (to-int modulus))))) - (def: (decode text) - (<| (l.run text) - (do p.monad - [[remainder _ _modulus] ($_ p.and intL (l.this separator) intL) - _ (p.assert (ex.construct incorrect-modulus [modulus _modulus]) - (i/= (to-int modulus) _modulus))] - (wrap (mod modulus remainder)))))) + (def: decode + (l.run (do p.monad + [[remainder _ _modulus] ($_ p.and intL (l.this separator) intL) + _ (p.assert (ex.construct incorrect-modulus [modulus _modulus]) + (i/= (to-int modulus) _modulus))] + (wrap (mod modulus remainder)))))) (def: #export (equalize reference sample) (All [r s] (-> (Mod r) (Mod s) (Error (Mod r)))) diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux index 703352139..ff30cf782 100644 --- a/stdlib/source/lux/target/jvm/type.lux +++ b/stdlib/source/lux/target/jvm/type.lux @@ -1,6 +1,10 @@ (.module: [lux (#- Type int char) + [control + ["<>" parser + ["<t>" text (#+ Parser)]]] [data + [error (#+ Error)] ["." maybe ("#@." functor)] ["." text format] @@ -23,9 +27,31 @@ (def: array-prefix "[") (def: object-prefix "L") +(def: var-prefix "T") +(def: wildcard-descriptor "*") +(def: lower-prefix "-") +(def: upper-prefix "+") (def: object-suffix ";") (def: object-class "java.lang.Object") +(def: valid-var-characters/head + (format "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "_")) + +(def: valid-var-characters/tail + (format valid-var-characters/head + "0123456789")) + +(def: syntax-package-separator ".") +(def: binary-package-separator "/") + +(def: valid-class-characters/head + (format valid-var-characters/head ..binary-package-separator)) + +(def: valid-class-characters/tail + (format valid-var-characters/tail ..binary-package-separator)) + (type: #export Bound #Lower #Upper) @@ -104,7 +130,7 @@ (def: #export binary-name (-> Text Text) - (text.replace-all "." "/")) + (text.replace-all ..syntax-package-separator ..binary-package-separator)) (def: #export (descriptor type) (-> Type Text) @@ -180,18 +206,79 @@ (format ..object-prefix (binary-name class) =params ..object-suffix)) (#Var name) - (format "T" name ..object-suffix) + (format ..var-prefix name ..object-suffix) (#Wildcard #.None) - "*" + ..wildcard-descriptor (^template [<tag> <prefix>] (#Wildcard (#.Some [<tag> bound])) (format <prefix> (signature (#Generic bound)))) - ([#Upper "+"] - [#Lower "-"])) + ([#Lower ..lower-prefix] + [#Upper ..upper-prefix])) )) +(template [<name> <head> <tail>] + [(def: <name> + (Parser Text) + (<t>.slice (<t>.and! (<t>.one-of! <head>) + (<t>.some! (<t>.one-of! <tail>)))))] + + [parse-class-name valid-class-characters/head valid-class-characters/tail] + [parse-var-name valid-var-characters/head valid-var-characters/tail] + ) + +(def: parse-var + (Parser Var) + (|> ..parse-var-name + (<>.after (<t>.this ..var-prefix)) + (<>.before (<t>.this ..object-suffix)))) + +(def: parse-bound + (Parser Bound) + ($_ <>.or + (<t>.this ..lower-prefix) + (<t>.this ..upper-prefix))) + +(def: parse-generic + (Parser Generic) + (<>.rec + (function (_ recur) + ($_ <>.or + ..parse-var + ($_ <>.or + (<t>.this ..wildcard-descriptor) + (<>.and ..parse-bound recur) + ) + (|> (<>.and ..parse-class-name + (|> (<>.some recur) + (<>.after (<t>.this "<")) + (<>.before (<t>.this ">")) + (<>.default (list)))) + (<>.after (<t>.this ..object-prefix)) + (<>.before (<t>.this ..object-suffix))) + )))) + +(def: #export parse-signature + (-> Text (Error Type)) + (<t>.run (<>.rec + (function (_ recur) + ($_ <>.or + ($_ <>.or + (<t>.this ..boolean-descriptor) + (<t>.this ..byte-descriptor) + (<t>.this ..short-descriptor) + (<t>.this ..int-descriptor) + (<t>.this ..long-descriptor) + (<t>.this ..float-descriptor) + (<t>.this ..double-descriptor) + (<t>.this ..char-descriptor) + ) + ..parse-generic + (<>.after (<t>.this ..array-prefix) + recur) + ))))) + (def: #export (method args return exceptions) (-> (List Type) (Maybe Type) (List Generic) Method) {#args args #return return #exceptions exceptions}) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 3a1df14c1..45121339a 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -152,14 +152,10 @@ #month month #day (.nat (.dec utc-day))}))) -(def: (decode input) - (-> Text (Error Date)) - (l.run input ..lex-date)) - (structure: #export codec {#.doc (doc "Based on ISO 8601." "For example: 2017-01-15")} (Codec Text Date) (def: encode ..encode) - (def: decode ..decode)) + (def: decode (l.run ..lex-date))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux index 28d4ff07c..91581c37b 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -164,7 +164,7 @@ ## TODO: Get rid of this template block and use the definition in ## lux/host.jvm.lux ASAP (template [<name> <class>] - [(type: #export <name> (.primitive <class>))] + [(def: #export <name> .Type (#.Primitive <class> #.Nil))] ## Boxes [Boolean "java.lang.Boolean"] @@ -368,9 +368,6 @@ (#.Primitive name _) (////@wrap name) - (#.Named name unnamed) - (check-jvm unnamed) - (^template [<tag>] (<tag> id) (////@wrap "java.lang.Object")) @@ -402,6 +399,12 @@ (/////analysis.throw ..primitives-are-not-objects [name]) (////@wrap name)))) +(def: (check-return type) + (-> .Type (Operation Text)) + (if (is? .Any type) + (////@wrap "void") + (check-jvm type))) + (def: (read-primitive-array-handler lux-type jvm-type) (-> .Type Type Handler) (function (_ extension-name analyse args) @@ -759,7 +762,12 @@ class-name (java/lang/Class::getName java-type)] (////@wrap (case (array.size (java/lang/Class::getTypeParameters java-type)) 0 - (#.Primitive class-name (list)) + (case class-name + "void" + Any + + _ + (#.Primitive class-name (list))) arity (|> (list.indices arity) @@ -796,7 +804,7 @@ _) ## else - (/////analysis.throw cannot-convert-to-a-lux-type java-type))) + (/////analysis.throw ..cannot-convert-to-a-lux-type java-type))) (def: (correspond-type-params class type) (-> (java/lang/Class java/lang/Object) .Type (Operation Mapping)) @@ -1127,28 +1135,34 @@ [parameters (|> (Method::getGenericParameterTypes method) array.to-list (monad.map @ java-type-to-parameter)) - #let [modifiers (Method::getModifiers method)]] - (wrap (and (java/lang/Object::equals class (Method::getDeclaringClass method)) - (text@= method-name (Method::getName method)) - (case #Static - #Special - (Modifier::isStatic modifiers) - - _ - #1) - (case method-style - #Special - (not (or (Modifier::isInterface (java/lang/Class::getModifiers class)) - (Modifier::isAbstract modifiers))) - - _ - #1) - (n/= (list.size arg-classes) (list.size parameters)) - (list@fold (function (_ [expectedJC actualJC] prev) - (and prev - (text@= expectedJC actualJC))) - #1 - (list.zip2 arg-classes parameters)))))) + #let [modifiers (Method::getModifiers method)] + #let [correct-class? (java/lang/Object::equals class (Method::getDeclaringClass method)) + correct-method? (text@= method-name (Method::getName method)) + static-matches? (case method-style + #Static + (Modifier::isStatic modifiers) + + _ + #1) + special-matches? (case method-style + #Special + (not (or (Modifier::isInterface (java/lang/Class::getModifiers class)) + (Modifier::isAbstract modifiers))) + + _ + #1) + arity-matches? (n/= (list.size arg-classes) (list.size parameters)) + inputs-match? (list@fold (function (_ [expectedJC actualJC] prev) + (and prev + (text@= expectedJC actualJC))) + #1 + (list.zip2 arg-classes parameters))]] + (wrap (and correct-class? + correct-method? + static-matches? + special-matches? + arity-matches? + inputs-match?)))) (def: (check-constructor class arg-classes constructor) (-> (java/lang/Class java/lang/Object) (List Text) (Constructor java/lang/Object) (Operation Bit)) @@ -1330,7 +1344,7 @@ [#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)] + outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) (/////analysis.text outputJC) @@ -1350,7 +1364,7 @@ _ (undefined))] - outputJC (check-jvm outputT)] + outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) (/////analysis.text outputJC) @@ -1365,7 +1379,7 @@ [#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)] + outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) (/////analysis.text outputJC) @@ -1382,7 +1396,7 @@ (Modifier::isInterface (java/lang/Class::getModifiers class))) [methodT exceptionsT] (method-candidate class-name method #Interface argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) - outputJC (check-jvm outputT)] + outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class-name) (/////analysis.text method) |