aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
authorEduardo Julian2018-05-23 02:04:47 -0400
committerEduardo Julian2018-05-23 02:04:47 -0400
commit72950a540be3dc49a107700c77c0195db16a4f58 (patch)
tree0f36aa21abad840e1a4a29215a5bfb9bb85659a7 /new-luxc
parent14e96f5e5dad439383d63e60a52169cc2e7aaa5c (diff)
- Migrated special-form analysis to stdlib.
Diffstat (limited to 'new-luxc')
-rw-r--r--new-luxc/source/luxc/lang/analysis/type.lux27
-rw-r--r--new-luxc/source/luxc/lang/extension.lux114
-rw-r--r--new-luxc/source/luxc/lang/extension/analysis.lux19
-rw-r--r--new-luxc/source/luxc/lang/extension/analysis/common.lux448
-rw-r--r--new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux1218
-rw-r--r--new-luxc/source/luxc/lang/synthesis.lux8
-rw-r--r--new-luxc/test/test/luxc/lang/analysis/procedure/common.lux324
-rw-r--r--new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux546
8 files changed, 0 insertions, 2704 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux
deleted file mode 100644
index 6d89dd5ef..000000000
--- a/new-luxc/source/luxc/lang/analysis/type.lux
+++ /dev/null
@@ -1,27 +0,0 @@
-(.module:
- lux
- (lux (control monad)
- [macro]
- (lang (type ["tc" check])))
- (luxc ["&" lang]
- (lang ["la" analysis #+ Analysis])))
-
-## These 2 analysers are somewhat special, since they require the
-## means of evaluating Lux expressions at compile-time for the sake of
-## computing Lux type values.
-(def: #export (analyse-check analyse eval type value)
- (-> &.Analyser &.Eval Code Code (Meta Analysis))
- (do macro.Monad<Meta>
- [actualT (eval Type type)
- #let [actualT (:! Type actualT)]
- _ (&.infer actualT)]
- (&.with-type actualT
- (analyse value))))
-
-(def: #export (analyse-coerce analyse eval type value)
- (-> &.Analyser &.Eval Code Code (Meta Analysis))
- (do macro.Monad<Meta>
- [actualT (eval Type type)
- _ (&.infer (:! Type actualT))]
- (&.with-type Any
- (analyse value))))
diff --git a/new-luxc/source/luxc/lang/extension.lux b/new-luxc/source/luxc/lang/extension.lux
deleted file mode 100644
index 254dd18ca..000000000
--- a/new-luxc/source/luxc/lang/extension.lux
+++ /dev/null
@@ -1,114 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data ["e" error]
- [text]
- (coll (dictionary ["dict" unordered #+ Dict])))
- [macro])
- [//]
- (// ["la" analysis]
- ["ls" synthesis]))
-
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Unknown-Analysis]
- [Unknown-Synthesis]
- [Unknown-Translation]
- [Unknown-Statement]
-
- [Cannot-Define-Analysis-More-Than-Once]
- [Cannot-Define-Synthesis-More-Than-Once]
- [Cannot-Define-Translation-More-Than-Once]
- [Cannot-Define-Statement-More-Than-Once]
- )
-
-(type: #export Analysis
- (-> (-> Code (Meta Code))
- (-> Type Code (Meta Any))
- (List Code) (Meta Code)))
-
-(type: #export Synthesis
- (-> (-> la.Analysis ls.Synthesis) (List Code) Code))
-
-(type: #export Syntheses (Dict Text Synthesis))
-
-(type: #export Translation
- (-> (List Code) (Meta Code)))
-
-(type: #export Statement
- (-> (List Code) (Meta Any)))
-
-(type: #export Extensions
- {#analysis (Dict Text Analysis)
- #synthesis Syntheses
- #translation (Dict Text Translation)
- #statement (Dict Text Statement)})
-
-(def: #export fresh
- Extensions
- {#analysis (dict.new text.Hash<Text>)
- #synthesis (dict.new text.Hash<Text>)
- #translation (dict.new text.Hash<Text>)
- #statement (dict.new text.Hash<Text>)})
-
-(def: get
- (Meta Extensions)
- (function (_ compiler)
- (#e.Success [compiler
- (|> compiler (get@ #.extensions) (:! Extensions))])))
-
-(def: (set extensions)
- (-> Extensions (Meta Any))
- (function (_ compiler)
- (#e.Success [(set@ #.extensions (:! Nothing extensions) compiler)
- []])))
-
-(do-template [<name> <type> <category> <exception>]
- [(def: #export (<name> name)
- (-> Text (Meta <type>))
- (do macro.Monad<Meta>
- [extensions ..get]
- (case (dict.get name (get@ <category> extensions))
- (#.Some extension)
- (wrap extension)
-
- #.None
- (//.throw <exception> name))))]
-
- [find-analysis Analysis #analysis Unknown-Analysis]
- [find-synthesis Synthesis #synthesis Unknown-Synthesis]
- [find-translation Translation #translation Unknown-Translation]
- [find-statement Statement #statement Unknown-Statement]
- )
-
-(do-template [<no> <all> <type> <category> <empty>]
- [(def: #export <no>
- <type>
- <empty>)
-
- (def: #export <all>
- (Meta <type>)
- (|> ..get
- (:: macro.Monad<Meta> map (get@ <category>))))]
-
- [no-syntheses all-syntheses Syntheses #synthesis (dict.new text.Hash<Text>)]
- )
-
-(do-template [<name> <type> <category> <exception>]
- [(def: #export (<name> name extension)
- (-> Text <type> (Meta Any))
- (do macro.Monad<Meta>
- [extensions ..get
- _ (//.assert <exception> name
- (not (dict.contains? name (get@ <category> extensions))))
- _ (..set (update@ <category> (dict.put name extension) extensions))]
- (wrap [])))]
-
- [install-analysis Analysis #analysis Cannot-Define-Analysis-More-Than-Once]
- [install-synthesis Synthesis #synthesis Cannot-Define-Synthesis-More-Than-Once]
- [install-translation Translation #translation Cannot-Define-Translation-More-Than-Once]
- [install-statement Statement #statement Cannot-Define-Statement-More-Than-Once]
- )
diff --git a/new-luxc/source/luxc/lang/extension/analysis.lux b/new-luxc/source/luxc/lang/extension/analysis.lux
deleted file mode 100644
index 79fa3af88..000000000
--- a/new-luxc/source/luxc/lang/extension/analysis.lux
+++ /dev/null
@@ -1,19 +0,0 @@
-(.module:
- lux
- (lux (data [text]
- (coll [list "list/" Functor<List>]
- (dictionary ["dict" unordered #+ Dict]))))
- [//]
- [/common]
- [/host])
-
-(def: realize
- (-> /common.Bundle (Dict Text //.Analysis))
- (|>> dict.entries
- (list/map (function (_ [name proc]) [name (proc name)]))
- (dict.from-list text.Hash<Text>)))
-
-(def: #export defaults
- (Dict Text //.Analysis)
- (realize (dict.merge /common.procedures
- /host.procedures)))
diff --git a/new-luxc/source/luxc/lang/extension/analysis/common.lux b/new-luxc/source/luxc/lang/extension/analysis/common.lux
deleted file mode 100644
index f22cdcdd1..000000000
--- a/new-luxc/source/luxc/lang/extension/analysis/common.lux
+++ /dev/null
@@ -1,448 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (concurrency [atom #+ Atom])
- (data [text]
- text/format
- (coll [list "list/" Functor<List>]
- [array]
- (dictionary ["dict" unordered #+ Dict])))
- [macro]
- (macro [code])
- (lang (type ["tc" check]))
- [io])
- (luxc ["&" lang]
- (lang ["la" analysis]
- (analysis ["&." common]
- [".A" function]
- [".A" case]
- [".A" type])))
- [///])
-
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Incorrect-Procedure-Arity]
- [Invalid-Syntax]
- )
-
-## [Utils]
-(type: #export Bundle
- (Dict Text (-> Text ///.Analysis)))
-
-(def: #export (install name unnamed)
- (-> Text (-> Text ///.Analysis)
- (-> Bundle Bundle))
- (dict.put name unnamed))
-
-(def: #export (prefix prefix bundle)
- (-> Text Bundle Bundle)
- (|> bundle
- dict.entries
- (list/map (function (_ [key val]) [(format prefix " " key) val]))
- (dict.from-list text.Hash<Text>)))
-
-(def: #export (wrong-arity proc expected actual)
- (-> Text Nat Nat Text)
- (format " Procedure: " (%t proc) "\n"
- " Expected Arity: " (|> expected nat-to-int %i) "\n"
- " Actual Arity: " (|> actual nat-to-int %i)))
-
-(def: (simple proc inputsT+ outputT)
- (-> Text (List Type) Type ///.Analysis)
- (let [num-expected (list.size inputsT+)]
- (function (_ analyse eval args)
- (let [num-actual (list.size args)]
- (if (n/= num-expected num-actual)
- (do macro.Monad<Meta>
- [_ (&.infer outputT)
- argsA (monad.map @
- (function (_ [argT argC])
- (&.with-type argT
- (analyse argC)))
- (list.zip2 inputsT+ args))]
- (wrap (la.procedure proc argsA)))
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual)))))))
-
-(def: #export (nullary valueT proc)
- (-> Type Text ///.Analysis)
- (simple proc (list) valueT))
-
-(def: #export (unary inputT outputT proc)
- (-> Type Type Text ///.Analysis)
- (simple proc (list inputT) outputT))
-
-(def: #export (binary subjectT paramT outputT proc)
- (-> Type Type Type Text ///.Analysis)
- (simple proc (list subjectT paramT) outputT))
-
-(def: #export (trinary subjectT param0T param1T outputT proc)
- (-> Type Type Type Type Text ///.Analysis)
- (simple proc (list subjectT param0T param1T) outputT))
-
-## [Analysers]
-## "lux is" represents reference/pointer equality.
-(def: (lux//is proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
- ((binary varT varT Bool proc)
- analyse eval args))))
-
-## "lux try" provides a simple way to interact with the host platform's
-## error-handling facilities.
-(def: (lux//try proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list opC))
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer (type (Either Text varT)))
- opA (&.with-type (type (io.IO varT))
- (analyse opC))]
- (wrap (la.procedure proc (list opA))))
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
-
-(def: (lux//function proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list [_ (#.Symbol ["" func-name])]
- [_ (#.Symbol ["" arg-name])]
- body))
- (functionA.analyse-function analyse func-name arg-name body)
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args))))))
-
-(def: (lux//case proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list input [_ (#.Record branches)]))
- (caseA.analyse-case analyse input branches)
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))
-
-(def: (lux//in-module proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval argsC+)
- (case argsC+
- (^ (list [_ (#.Text module-name)] exprC))
- (&.with-current-module module-name
- (analyse exprC))
-
- _
- (&.throw Invalid-Syntax (format "Procedure: " proc "\n"
- " Inputs:" (|> argsC+
- list.enumerate
- (list/map (function (_ [idx argC])
- (format "\n " (%n idx) " " (%code argC))))
- (text.join-with "")) "\n")))))
-
-(do-template [<name> <analyser>]
- [(def: (<name> proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list typeC valueC))
- (<analyser> analyse eval typeC valueC)
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))]
-
- [lux//check typeA.analyse-check]
- [lux//coerce typeA.analyse-coerce])
-
-(def: (lux//check//type proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list valueC))
- (do macro.Monad<Meta>
- [_ (&.infer (type Type))
- valueA (&.with-type Type
- (analyse valueC))]
- (wrap valueA))
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
-
-(def: lux-procs
- Bundle
- (|> (dict.new text.Hash<Text>)
- (install "is" lux//is)
- (install "try" lux//try)
- (install "function" lux//function)
- (install "case" lux//case)
- (install "check" lux//check)
- (install "coerce" lux//coerce)
- (install "check type" lux//check//type)
- (install "in-module" lux//in-module)))
-
-(def: io-procs
- Bundle
- (<| (prefix "io")
- (|> (dict.new text.Hash<Text>)
- (install "log" (unary Text Any))
- (install "error" (unary Text Nothing))
- (install "exit" (unary Int Nothing))
- (install "current-time" (nullary Int)))))
-
-(def: bit-procs
- Bundle
- (<| (prefix "bit")
- (|> (dict.new text.Hash<Text>)
- (install "and" (binary Nat Nat Nat))
- (install "or" (binary Nat Nat Nat))
- (install "xor" (binary Nat Nat Nat))
- (install "left-shift" (binary Nat Nat Nat))
- (install "logical-right-shift" (binary Nat Nat Nat))
- (install "arithmetic-right-shift" (binary Int Nat Int))
- )))
-
-(def: int-procs
- Bundle
- (<| (prefix "int")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary Int Int Int))
- (install "-" (binary Int Int Int))
- (install "*" (binary Int Int Int))
- (install "/" (binary Int Int Int))
- (install "%" (binary Int Int Int))
- (install "=" (binary Int Int Bool))
- (install "<" (binary Int Int Bool))
- (install "min" (nullary Int))
- (install "max" (nullary Int))
- (install "to-nat" (unary Int Nat))
- (install "to-frac" (unary Int Frac))
- (install "char" (unary Int Text)))))
-
-(def: deg-procs
- Bundle
- (<| (prefix "deg")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary Deg Deg Deg))
- (install "-" (binary Deg Deg Deg))
- (install "*" (binary Deg Deg Deg))
- (install "/" (binary Deg Deg Deg))
- (install "%" (binary Deg Deg Deg))
- (install "=" (binary Deg Deg Bool))
- (install "<" (binary Deg Deg Bool))
- (install "scale" (binary Deg Nat Deg))
- (install "reciprocal" (binary Deg Nat Deg))
- (install "min" (nullary Deg))
- (install "max" (nullary Deg))
- (install "to-frac" (unary Deg Frac)))))
-
-(def: frac-procs
- Bundle
- (<| (prefix "frac")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary Frac Frac Frac))
- (install "-" (binary Frac Frac Frac))
- (install "*" (binary Frac Frac Frac))
- (install "/" (binary Frac Frac Frac))
- (install "%" (binary Frac Frac Frac))
- (install "=" (binary Frac Frac Bool))
- (install "<" (binary Frac Frac Bool))
- (install "smallest" (nullary Frac))
- (install "min" (nullary Frac))
- (install "max" (nullary Frac))
- (install "not-a-number" (nullary Frac))
- (install "positive-infinity" (nullary Frac))
- (install "negative-infinity" (nullary Frac))
- (install "to-deg" (unary Frac Deg))
- (install "to-int" (unary Frac Int))
- (install "encode" (unary Frac Text))
- (install "decode" (unary Text (type (Maybe Frac)))))))
-
-(def: text-procs
- Bundle
- (<| (prefix "text")
- (|> (dict.new text.Hash<Text>)
- (install "=" (binary Text Text Bool))
- (install "<" (binary Text Text Bool))
- (install "concat" (binary Text Text Text))
- (install "index" (trinary Text Text Nat (type (Maybe Nat))))
- (install "size" (unary Text Nat))
- (install "hash" (unary Text Nat))
- (install "replace-once" (trinary Text Text Text Text))
- (install "replace-all" (trinary Text Text Text Text))
- (install "char" (binary Text Nat (type (Maybe Nat))))
- (install "clip" (trinary Text Nat Nat (type (Maybe Text))))
- )))
-
-(def: (array//get proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
- ((binary (type (Array varT)) Nat (type (Maybe varT)) proc)
- analyse eval args))))
-
-(def: (array//put proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
- ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc)
- analyse eval args))))
-
-(def: (array//remove proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
- ((binary (type (Array varT)) Nat (type (Array varT)) proc)
- analyse eval args))))
-
-(def: array-procs
- Bundle
- (<| (prefix "array")
- (|> (dict.new text.Hash<Text>)
- (install "new" (unary Nat Array))
- (install "get" array//get)
- (install "put" array//put)
- (install "remove" array//remove)
- (install "size" (unary (type (Ex [a] (Array a))) Nat))
- )))
-
-(def: math-procs
- Bundle
- (<| (prefix "math")
- (|> (dict.new text.Hash<Text>)
- (install "cos" (unary Frac Frac))
- (install "sin" (unary Frac Frac))
- (install "tan" (unary Frac Frac))
- (install "acos" (unary Frac Frac))
- (install "asin" (unary Frac Frac))
- (install "atan" (unary Frac Frac))
- (install "cosh" (unary Frac Frac))
- (install "sinh" (unary Frac Frac))
- (install "tanh" (unary Frac Frac))
- (install "exp" (unary Frac Frac))
- (install "log" (unary Frac Frac))
- (install "ceil" (unary Frac Frac))
- (install "floor" (unary Frac Frac))
- (install "round" (unary Frac Frac))
- (install "atan2" (binary Frac Frac Frac))
- (install "pow" (binary Frac Frac Frac))
- )))
-
-(def: (atom-new proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list initC))
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer (type (Atom varT)))
- initA (&.with-type varT
- (analyse initC))]
- (wrap (la.procedure proc (list initA))))
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
-
-(def: (atom-read proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
- ((unary (type (Atom varT)) varT proc)
- analyse eval args))))
-
-(def: (atom//compare-and-swap proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
- ((trinary (type (Atom varT)) varT varT Bool proc)
- analyse eval args))))
-
-(def: atom-procs
- Bundle
- (<| (prefix "atom")
- (|> (dict.new text.Hash<Text>)
- (install "new" atom-new)
- (install "read" atom-read)
- (install "compare-and-swap" atom//compare-and-swap)
- )))
-
-(type: (Box ! a)
- (#.Primitive "#Box" (#.Cons ! (#.Cons a #.Nil))))
-
-(def: (box//new proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list initC))
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer (type (All [!] (Box ! varT))))
- initA (&.with-type varT
- (analyse initC))]
- (wrap (la.procedure proc (list initA))))
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
-
-(def: (box//read proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[thread-id threadT] (&.with-type-env tc.var)
- [var-id varT] (&.with-type-env tc.var)]
- ((unary (type (Box threadT varT)) varT proc)
- analyse eval args))))
-
-(def: (box//write proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[thread-id threadT] (&.with-type-env tc.var)
- [var-id varT] (&.with-type-env tc.var)]
- ((binary varT (type (Box threadT varT)) Any proc)
- analyse eval args))))
-
-(def: box-procs
- Bundle
- (<| (prefix "box")
- (|> (dict.new text.Hash<Text>)
- (install "new" box//new)
- (install "read" box//read)
- (install "write" box//write)
- )))
-
-(def: process-procs
- Bundle
- (<| (prefix "process")
- (|> (dict.new text.Hash<Text>)
- (install "parallelism-level" (nullary Nat))
- (install "schedule" (binary Nat (type (io.IO Any)) Any))
- )))
-
-(def: #export procedures
- Bundle
- (<| (prefix "lux")
- (|> (dict.new text.Hash<Text>)
- (dict.merge lux-procs)
- (dict.merge bit-procs)
- (dict.merge int-procs)
- (dict.merge deg-procs)
- (dict.merge frac-procs)
- (dict.merge text-procs)
- (dict.merge array-procs)
- (dict.merge math-procs)
- (dict.merge atom-procs)
- (dict.merge box-procs)
- (dict.merge process-procs)
- (dict.merge io-procs))))
diff --git a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux b/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
deleted file mode 100644
index 9ef06a4b1..000000000
--- a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
+++ /dev/null
@@ -1,1218 +0,0 @@
-(.module:
- [lux #- char]
- (lux (control [monad #+ do]
- ["p" parser]
- ["ex" exception #+ exception:])
- (concurrency ["A" atom])
- (data ["e" error]
- [maybe]
- [product]
- [bool "bool/" Eq<Bool>]
- [text "text/" Eq<Text>]
- (text format
- ["l" lexer])
- (coll [list "list/" Fold<List> Functor<List> Monoid<List>]
- [array]
- (dictionary ["dict" unordered #+ Dict])))
- [macro "macro/" Monad<Meta>]
- (macro [code]
- ["s" syntax])
- (lang [type]
- (type ["tc" check]))
- [host])
- (luxc ["&" lang]
- (lang ["&." host]
- ["la" analysis]
- (analysis ["&." common]
- [".A" inference])))
- ["@" //common]
- [///]
- )
-
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Wrong-Syntax]
-
- [JVM-Type-Is-Not-Class]
-
- [Non-Interface]
- [Non-Object]
- [Non-Array]
- [Non-Throwable]
- [Non-JVM-Type]
-
- [Unknown-Class]
- [Primitives-Cannot-Have-Type-Parameters]
- [Primitives-Are-Not-Objects]
- [Invalid-Type-For-Array-Element]
-
- [Unknown-Field]
- [Mistaken-Field-Owner]
- [Not-Virtual-Field]
- [Not-Static-Field]
- [Cannot-Set-Final-Field]
-
- [No-Candidates]
- [Too-Many-Candidates]
-
- [Cannot-Cast]
-
- [Cannot-Possibly-Be-Instance]
-
- [Cannot-Convert-To-Class]
- [Cannot-Convert-To-Parameter]
- [Cannot-Convert-To-Lux-Type]
- [Unknown-Type-Var]
- [Type-Parameter-Mismatch]
- [Cannot-Correspond-Type-With-Class]
- )
-
-(def: (wrong-syntax procedure args)
- (-> Text (List Code) Text)
- (format "Procedure: " procedure "\n"
- "Arguments: " (%code (code.tuple args))))
-
-(do-template [<name> <class>]
- [(def: #export <name> Type (#.Primitive <class> (list)))]
-
- ## Boxes
- [Boolean "java.lang.Boolean"]
- [Byte "java.lang.Byte"]
- [Short "java.lang.Short"]
- [Integer "java.lang.Integer"]
- [Long "java.lang.Long"]
- [Float "java.lang.Float"]
- [Double "java.lang.Double"]
- [Character "java.lang.Character"]
- [String "java.lang.String"]
-
- ## Primitives
- [boolean "boolean"]
- [byte "byte"]
- [short "short"]
- [int "int"]
- [long "long"]
- [float "float"]
- [double "double"]
- [char "char"]
- )
-
-(def: conversion-procs
- @.Bundle
- (<| (@.prefix "convert")
- (|> (dict.new text.Hash<Text>)
- (@.install "double-to-float" (@.unary Double Float))
- (@.install "double-to-int" (@.unary Double Integer))
- (@.install "double-to-long" (@.unary Double Long))
- (@.install "float-to-double" (@.unary Float Double))
- (@.install "float-to-int" (@.unary Float Integer))
- (@.install "float-to-long" (@.unary Float Long))
- (@.install "int-to-byte" (@.unary Integer Byte))
- (@.install "int-to-char" (@.unary Integer Character))
- (@.install "int-to-double" (@.unary Integer Double))
- (@.install "int-to-float" (@.unary Integer Float))
- (@.install "int-to-long" (@.unary Integer Long))
- (@.install "int-to-short" (@.unary Integer Short))
- (@.install "long-to-double" (@.unary Long Double))
- (@.install "long-to-float" (@.unary Long Float))
- (@.install "long-to-int" (@.unary Long Integer))
- (@.install "long-to-short" (@.unary Long Short))
- (@.install "long-to-byte" (@.unary Long Byte))
- (@.install "char-to-byte" (@.unary Character Byte))
- (@.install "char-to-short" (@.unary Character Short))
- (@.install "char-to-int" (@.unary Character Integer))
- (@.install "char-to-long" (@.unary Character Long))
- (@.install "byte-to-long" (@.unary Byte Long))
- (@.install "short-to-long" (@.unary Short Long))
- )))
-
-(do-template [<name> <prefix> <type>]
- [(def: <name>
- @.Bundle
- (<| (@.prefix <prefix>)
- (|> (dict.new text.Hash<Text>)
- (@.install "+" (@.binary <type> <type> <type>))
- (@.install "-" (@.binary <type> <type> <type>))
- (@.install "*" (@.binary <type> <type> <type>))
- (@.install "/" (@.binary <type> <type> <type>))
- (@.install "%" (@.binary <type> <type> <type>))
- (@.install "=" (@.binary <type> <type> Boolean))
- (@.install "<" (@.binary <type> <type> Boolean))
- (@.install "and" (@.binary <type> <type> <type>))
- (@.install "or" (@.binary <type> <type> <type>))
- (@.install "xor" (@.binary <type> <type> <type>))
- (@.install "shl" (@.binary <type> Integer <type>))
- (@.install "shr" (@.binary <type> Integer <type>))
- (@.install "ushr" (@.binary <type> Integer <type>))
- )))]
-
- [int-procs "int" Integer]
- [long-procs "long" Long]
- )
-
-(do-template [<name> <prefix> <type>]
- [(def: <name>
- @.Bundle
- (<| (@.prefix <prefix>)
- (|> (dict.new text.Hash<Text>)
- (@.install "+" (@.binary <type> <type> <type>))
- (@.install "-" (@.binary <type> <type> <type>))
- (@.install "*" (@.binary <type> <type> <type>))
- (@.install "/" (@.binary <type> <type> <type>))
- (@.install "%" (@.binary <type> <type> <type>))
- (@.install "=" (@.binary <type> <type> Boolean))
- (@.install "<" (@.binary <type> <type> Boolean))
- )))]
-
- [float-procs "float" Float]
- [double-procs "double" Double]
- )
-
-(def: char-procs
- @.Bundle
- (<| (@.prefix "char")
- (|> (dict.new text.Hash<Text>)
- (@.install "=" (@.binary Character Character Boolean))
- (@.install "<" (@.binary Character Character Boolean))
- )))
-
-(def: #export boxes
- (Dict Text Text)
- (|> (list ["boolean" "java.lang.Boolean"]
- ["byte" "java.lang.Byte"]
- ["short" "java.lang.Short"]
- ["int" "java.lang.Integer"]
- ["long" "java.lang.Long"]
- ["float" "java.lang.Float"]
- ["double" "java.lang.Double"]
- ["char" "java.lang.Character"])
- (dict.from-list text.Hash<Text>)))
-
-(def: (array-length proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list arrayC))
- (do macro.Monad<Meta>
- [_ (&.infer Nat)
- [var-id varT] (&.with-type-env tc.var)
- arrayA (&.with-type (type (Array varT))
- (analyse arrayC))]
- (wrap (la.procedure proc (list arrayA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (array-new proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list lengthC))
- (do macro.Monad<Meta>
- [lengthA (&.with-type Nat
- (analyse lengthC))
- expectedT macro.expected-type
- [level elem-class] (: (Meta [Nat Text])
- (loop [analysisT expectedT
- level +0]
- (case analysisT
- (#.Apply inputT funcT)
- (case (type.apply (list inputT) funcT)
- (#.Some outputT)
- (recur outputT level)
-
- #.None
- (&.throw Non-Array (%type expectedT)))
-
- (^ (#.Primitive "#Array" (list elemT)))
- (recur elemT (n/inc level))
-
- (#.Primitive class _)
- (wrap [level class])
-
- _
- (&.throw Non-Array (%type expectedT)))))
- _ (if (n/> +0 level)
- (wrap [])
- (&.throw Non-Array (%type expectedT)))]
- (wrap (la.procedure proc (list (code.nat (n/dec level)) (code.text elem-class) lengthA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (check-jvm objectT)
- (-> Type (Meta Text))
- (case objectT
- (#.Primitive name _)
- (macro/wrap name)
-
- (#.Named name unnamed)
- (check-jvm unnamed)
-
- (#.Var id)
- (macro/wrap "java.lang.Object")
-
- (^template [<tag>]
- (<tag> env unquantified)
- (check-jvm unquantified))
- ([#.UnivQ]
- [#.ExQ])
-
- (#.Apply inputT funcT)
- (case (type.apply (list inputT) funcT)
- (#.Some outputT)
- (check-jvm outputT)
-
- #.None
- (&.throw Non-Object (%type objectT)))
-
- _
- (&.throw Non-Object (%type objectT))))
-
-(def: (check-object objectT)
- (-> Type (Meta Text))
- (do macro.Monad<Meta>
- [name (check-jvm objectT)]
- (if (dict.contains? name boxes)
- (&.throw Primitives-Are-Not-Objects name)
- (macro/wrap name))))
-
-(def: (box-array-element-type elemT)
- (-> Type (Meta [Type Text]))
- (case elemT
- (#.Primitive name #.Nil)
- (let [boxed-name (|> (dict.get name boxes)
- (maybe.default name))]
- (macro/wrap [(#.Primitive boxed-name #.Nil)
- boxed-name]))
-
- (#.Primitive name _)
- (if (dict.contains? name boxes)
- (&.throw Primitives-Cannot-Have-Type-Parameters name)
- (macro/wrap [elemT name]))
-
- _
- (&.throw Invalid-Type-For-Array-Element (%type elemT))))
-
-(def: (array-read proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list arrayC idxC))
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer varT)
- arrayA (&.with-type (type (Array varT))
- (analyse arrayC))
- ?elemT (&.with-type-env
- (tc.read var-id))
- [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
- idxA (&.with-type Nat
- (analyse idxC))]
- (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-
-(def: (array-write proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list arrayC idxC valueC))
- (do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer (type (Array varT)))
- arrayA (&.with-type (type (Array varT))
- (analyse arrayC))
- ?elemT (&.with-type-env
- (tc.read var-id))
- [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
- idxA (&.with-type Nat
- (analyse idxC))
- valueA (&.with-type valueT
- (analyse valueC))]
- (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
-
-(def: array-procs
- @.Bundle
- (<| (@.prefix "array")
- (|> (dict.new text.Hash<Text>)
- (@.install "length" array-length)
- (@.install "new" array-new)
- (@.install "read" array-read)
- (@.install "write" array-write)
- )))
-
-(def: (object//null proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list))
- (do macro.Monad<Meta>
- [expectedT macro.expected-type
- _ (check-object expectedT)]
- (wrap (la.procedure proc (list))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args))))))
-
-(def: (object//null? proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list objectC))
- (do macro.Monad<Meta>
- [_ (&.infer Bool)
- [objectT objectA] (&common.with-unknown-type
- (analyse objectC))
- _ (check-object objectT)]
- (wrap (la.procedure proc (list objectA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (object//synchronized proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list monitorC exprC))
- (do macro.Monad<Meta>
- [[monitorT monitorA] (&common.with-unknown-type
- (analyse monitorC))
- _ (check-object monitorT)
- exprA (analyse exprC)]
- (wrap (la.procedure proc (list monitorA exprA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-
-(host.import java/lang/Object
- (equals [Object] boolean))
-
-(host.import java/lang/ClassLoader)
-
-(host.import #long java/lang/reflect/Type
- (getTypeName [] String))
-
-(host.import java/lang/reflect/GenericArrayType
- (getGenericComponentType [] java/lang/reflect/Type))
-
-(host.import java/lang/reflect/ParameterizedType
- (getRawType [] java/lang/reflect/Type)
- (getActualTypeArguments [] (Array java/lang/reflect/Type)))
-
-(host.import (java/lang/reflect/TypeVariable d)
- (getName [] String)
- (getBounds [] (Array java/lang/reflect/Type)))
-
-(host.import (java/lang/reflect/WildcardType d)
- (getLowerBounds [] (Array java/lang/reflect/Type))
- (getUpperBounds [] (Array java/lang/reflect/Type)))
-
-(host.import java/lang/reflect/Modifier
- (#static isStatic [int] boolean)
- (#static isFinal [int] boolean)
- (#static isInterface [int] boolean)
- (#static isAbstract [int] boolean))
-
-(host.import java/lang/reflect/Field
- (getDeclaringClass [] (java/lang/Class Object))
- (getModifiers [] int)
- (getGenericType [] java/lang/reflect/Type))
-
-(host.import java/lang/reflect/Method
- (getName [] String)
- (getModifiers [] int)
- (getDeclaringClass [] (Class Object))
- (getTypeParameters [] (Array (TypeVariable Method)))
- (getGenericParameterTypes [] (Array java/lang/reflect/Type))
- (getGenericReturnType [] java/lang/reflect/Type)
- (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
-
-(host.import (java/lang/reflect/Constructor c)
- (getModifiers [] int)
- (getDeclaringClass [] (Class c))
- (getTypeParameters [] (Array (TypeVariable (Constructor c))))
- (getGenericParameterTypes [] (Array java/lang/reflect/Type))
- (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
-
-(host.import (java/lang/Class c)
- (getName [] String)
- (getModifiers [] int)
- (#static forName [String boolean ClassLoader] #try (Class Object))
- (isAssignableFrom [(Class Object)] boolean)
- (getTypeParameters [] (Array (TypeVariable (Class c))))
- (getGenericInterfaces [] (Array java/lang/reflect/Type))
- (getGenericSuperclass [] java/lang/reflect/Type)
- (getDeclaredField [String] #try Field)
- (getConstructors [] (Array (Constructor Object)))
- (getDeclaredMethods [] (Array Method)))
-
-(def: (load-class name)
- (-> Text (Meta (Class Object)))
- (do macro.Monad<Meta>
- [class-loader &host.class-loader]
- (case (Class::forName [name false class-loader])
- (#e.Success [class])
- (wrap class)
-
- (#e.Error error)
- (&.throw Unknown-Class name))))
-
-(def: (sub-class? super sub)
- (-> Text Text (Meta Bool))
- (do macro.Monad<Meta>
- [super (load-class super)
- sub (load-class sub)]
- (wrap (Class::isAssignableFrom [sub] super))))
-
-(def: (object//throw proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list exceptionC))
- (do macro.Monad<Meta>
- [_ (&.infer Nothing)
- [exceptionT exceptionA] (&common.with-unknown-type
- (analyse exceptionC))
- exception-class (check-object exceptionT)
- ? (sub-class? "java.lang.Throwable" exception-class)
- _ (: (Meta Any)
- (if ?
- (wrap [])
- (&.throw Non-Throwable exception-class)))]
- (wrap (la.procedure proc (list exceptionA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (object//class proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list classC))
- (case classC
- [_ (#.Text class)]
- (do macro.Monad<Meta>
- [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
- _ (load-class class)]
- (wrap (la.procedure proc (list (code.text class)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (object//instance? proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list classC objectC))
- (case classC
- [_ (#.Text class)]
- (do macro.Monad<Meta>
- [_ (&.infer Bool)
- [objectT objectA] (&common.with-unknown-type
- (analyse objectC))
- object-class (check-object objectT)
- ? (sub-class? class object-class)]
- (if ?
- (wrap (la.procedure proc (list (code.text class))))
- (&.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-
-(def: type-descriptor
- (-> java/lang/reflect/Type Text)
- (java/lang/reflect/Type::getTypeName []))
-
-(def: (java-type-to-class type)
- (-> java/lang/reflect/Type (Meta Text))
- (cond (host.instance? Class type)
- (macro/wrap (Class::getName [] (:! Class type)))
-
- (host.instance? ParameterizedType type)
- (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type)))
-
- ## else
- (&.throw Cannot-Convert-To-Class (type-descriptor type))))
-
-(type: Mappings
- (Dict Text Type))
-
-(def: fresh-mappings Mappings (dict.new text.Hash<Text>))
-
-(def: (java-type-to-lux-type mappings java-type)
- (-> Mappings java/lang/reflect/Type (Meta Type))
- (cond (host.instance? TypeVariable java-type)
- (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))]
- (case (dict.get var-name mappings)
- (#.Some var-type)
- (macro/wrap var-type)
-
- #.None
- (&.throw Unknown-Type-Var var-name)))
-
- (host.instance? WildcardType java-type)
- (let [java-type (:! WildcardType java-type)]
- (case [(array.read +0 (WildcardType::getUpperBounds [] java-type))
- (array.read +0 (WildcardType::getLowerBounds [] java-type))]
- (^or [(#.Some bound) _] [_ (#.Some bound)])
- (java-type-to-lux-type mappings bound)
-
- _
- (macro/wrap Any)))
-
- (host.instance? Class java-type)
- (let [java-type (:! (Class Object) java-type)
- class-name (Class::getName [] java-type)]
- (macro/wrap (case (array.size (Class::getTypeParameters [] java-type))
- +0
- (#.Primitive class-name (list))
-
- arity
- (|> (list.n/range +0 (n/dec arity))
- list.reverse
- (list/map (|>> (n/* +2) n/inc #.Bound))
- (#.Primitive class-name)
- (type.univ-q arity)))))
-
- (host.instance? ParameterizedType java-type)
- (let [java-type (:! ParameterizedType java-type)
- raw (ParameterizedType::getRawType [] java-type)]
- (if (host.instance? Class raw)
- (do macro.Monad<Meta>
- [paramsT (|> java-type
- (ParameterizedType::getActualTypeArguments [])
- array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))]
- (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw))
- paramsT)))
- (&.throw JVM-Type-Is-Not-Class (type-descriptor raw))))
-
- (host.instance? GenericArrayType java-type)
- (do macro.Monad<Meta>
- [innerT (|> (:! GenericArrayType java-type)
- (GenericArrayType::getGenericComponentType [])
- (java-type-to-lux-type mappings))]
- (wrap (#.Primitive "#Array" (list innerT))))
-
- ## else
- (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
-
-(def: (correspond-type-params class type)
- (-> (Class Object) Type (Meta Mappings))
- (case type
- (#.Primitive name params)
- (let [class-name (Class::getName [] class)
- class-params (array.to-list (Class::getTypeParameters [] class))
- num-class-params (list.size class-params)
- num-type-params (list.size params)]
- (cond (not (text/= class-name name))
- (&.throw Cannot-Correspond-Type-With-Class
- (format "Class = " class-name "\n"
- "Type = " (%type type)))
-
- (not (n/= num-class-params num-type-params))
- (&.throw Type-Parameter-Mismatch
- (format "Expected: " (%i (nat-to-int num-class-params)) "\n"
- " Actual: " (%i (nat-to-int num-type-params)) "\n"
- " Class: " class-name "\n"
- " Type: " (%type type)))
-
- ## else
- (macro/wrap (|> params
- (list.zip2 (list/map (TypeVariable::getName []) class-params))
- (dict.from-list text.Hash<Text>)))
- ))
-
- _
- (&.throw Non-JVM-Type (%type type))))
-
-(def: (object//cast proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list valueC))
- (do macro.Monad<Meta>
- [toT macro.expected-type
- to-name (check-jvm toT)
- [valueT valueA] (&common.with-unknown-type
- (analyse valueC))
- from-name (check-jvm valueT)
- can-cast? (: (Meta Bool)
- (case [from-name to-name]
- (^template [<primitive> <object>]
- (^or [<primitive> <object>]
- [<object> <primitive>])
- (do @
- [_ (&.infer (#.Primitive to-name (list)))]
- (wrap true)))
- (["boolean" "java.lang.Boolean"]
- ["byte" "java.lang.Byte"]
- ["short" "java.lang.Short"]
- ["int" "java.lang.Integer"]
- ["long" "java.lang.Long"]
- ["float" "java.lang.Float"]
- ["double" "java.lang.Double"]
- ["char" "java.lang.Character"])
-
- _
- (do @
- [_ (&.assert Primitives-Are-Not-Objects from-name
- (not (dict.contains? from-name boxes)))
- _ (&.assert Primitives-Are-Not-Objects to-name
- (not (dict.contains? to-name boxes)))
- to-class (load-class to-name)]
- (loop [[current-name currentT] [from-name valueT]]
- (if (text/= to-name current-name)
- (do @
- [_ (&.infer toT)]
- (wrap true))
- (do @
- [current-class (load-class current-name)
- _ (&.assert Cannot-Cast (format "From class/primitive: " current-name "\n"
- " To class/primitive: " to-name "\n"
- " For value: " (%code valueC) "\n")
- (Class::isAssignableFrom [current-class] to-class))
- candiate-parents (monad.map @
- (function (_ java-type)
- (do @
- [class-name (java-type-to-class java-type)
- class (load-class class-name)]
- (wrap [[class-name java-type] (Class::isAssignableFrom [class] to-class)])))
- (list& (Class::getGenericSuperclass [] current-class)
- (array.to-list (Class::getGenericInterfaces [] current-class))))]
- (case (|> candiate-parents
- (list.filter product.right)
- (list/map product.left))
- (#.Cons [next-name nextJT] _)
- (do @
- [mapping (correspond-type-params current-class currentT)
- nextT (java-type-to-lux-type mapping nextJT)]
- (recur [next-name nextT]))
-
- #.Nil
- (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n"
- " To class/primitive: " to-name "\n"
- " For value: " (%code valueC) "\n")))
- ))))))]
- (if can-cast?
- (wrap (la.procedure proc (list (code.text from-name)
- (code.text to-name)
- valueA)))
- (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n"
- " To class/primitive: " to-name "\n"
- " For value: " (%code valueC) "\n"))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: object-procs
- @.Bundle
- (<| (@.prefix "object")
- (|> (dict.new text.Hash<Text>)
- (@.install "null" object//null)
- (@.install "null?" object//null?)
- (@.install "synchronized" object//synchronized)
- (@.install "throw" object//throw)
- (@.install "class" object//class)
- (@.install "instance?" object//instance?)
- (@.install "cast" object//cast)
- )))
-
-(def: (find-field class-name field-name)
- (-> Text Text (Meta [(Class Object) Field]))
- (do macro.Monad<Meta>
- [class (load-class class-name)]
- (case (Class::getDeclaredField [field-name] class)
- (#e.Success field)
- (let [owner (Field::getDeclaringClass [] field)]
- (if (is? owner class)
- (wrap [class field])
- (&.throw Mistaken-Field-Owner
- (format " Field: " field-name "\n"
- " Owner Class: " (Class::getName [] owner) "\n"
- "Target Class: " class-name "\n"))))
-
- (#e.Error _)
- (&.throw Unknown-Field (format class-name "#" field-name)))))
-
-(def: (static-field class-name field-name)
- (-> Text Text (Meta [Type Bool]))
- (do macro.Monad<Meta>
- [[class fieldJ] (find-field class-name field-name)
- #let [modifiers (Field::getModifiers [] fieldJ)]]
- (if (Modifier::isStatic [modifiers])
- (let [fieldJT (Field::getGenericType [] fieldJ)]
- (do @
- [fieldT (java-type-to-lux-type fresh-mappings fieldJT)]
- (wrap [fieldT (Modifier::isFinal [modifiers])])))
- (&.throw Not-Static-Field (format class-name "#" field-name)))))
-
-(def: (virtual-field class-name field-name objectT)
- (-> Text Text Type (Meta [Type Bool]))
- (do macro.Monad<Meta>
- [[class fieldJ] (find-field class-name field-name)
- #let [modifiers (Field::getModifiers [] fieldJ)]]
- (if (not (Modifier::isStatic [modifiers]))
- (do @
- [#let [fieldJT (Field::getGenericType [] fieldJ)
- var-names (|> class
- (Class::getTypeParameters [])
- array.to-list
- (list/map (TypeVariable::getName [])))]
- mappings (: (Meta Mappings)
- (case objectT
- (#.Primitive _class-name _class-params)
- (do @
- [#let [num-params (list.size _class-params)
- num-vars (list.size var-names)]
- _ (&.assert Type-Parameter-Mismatch
- (format "Expected: " (%i (nat-to-int num-params)) "\n"
- " Actual: " (%i (nat-to-int num-vars)) "\n"
- " Class: " _class-name "\n"
- " Type: " (%type objectT))
- (n/= num-params num-vars))]
- (wrap (|> (list.zip2 var-names _class-params)
- (dict.from-list text.Hash<Text>))))
-
- _
- (&.throw Non-Object (%type objectT))))
- fieldT (java-type-to-lux-type mappings fieldJT)]
- (wrap [fieldT (Modifier::isFinal [modifiers])]))
- (&.throw Not-Virtual-Field (format class-name "#" field-name)))))
-
-(def: (static//get proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list classC fieldC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad<Meta>
- [[fieldT final?] (static-field class field)]
- (wrap (la.procedure proc (list (code.text class) (code.text field)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-
-(def: (static//put proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list classC fieldC valueC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad<Meta>
- [_ (&.infer Any)
- [fieldT final?] (static-field class field)
- _ (&.assert Cannot-Set-Final-Field (format class "#" field)
- (not final?))
- valueA (&.with-type fieldT
- (analyse valueC))]
- (wrap (la.procedure proc (list (code.text class) (code.text field) valueA))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
-
-(def: (virtual//get proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list classC fieldC objectC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad<Meta>
- [[objectT objectA] (&common.with-unknown-type
- (analyse objectC))
- [fieldT final?] (virtual-field class field objectT)]
- (wrap (la.procedure proc (list (code.text class) (code.text field) objectA))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
-
-(def: (virtual//put proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list classC fieldC valueC objectC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad<Meta>
- [[objectT objectA] (&common.with-unknown-type
- (analyse objectC))
- _ (&.infer objectT)
- [fieldT final?] (virtual-field class field objectT)
- _ (&.assert Cannot-Set-Final-Field (format class "#" field)
- (not final?))
- valueA (&.with-type fieldT
- (analyse valueC))]
- (wrap (la.procedure proc (list (code.text class) (code.text field) valueA objectA))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +4 (list.size args))))))
-
-(def: (java-type-to-parameter type)
- (-> java/lang/reflect/Type (Meta Text))
- (cond (host.instance? Class type)
- (macro/wrap (Class::getName [] (:! Class type)))
-
- (host.instance? ParameterizedType type)
- (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type)))
-
- (or (host.instance? TypeVariable type)
- (host.instance? WildcardType type))
- (macro/wrap "java.lang.Object")
-
- (host.instance? GenericArrayType type)
- (do macro.Monad<Meta>
- [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))]
- (wrap (format componentP "[]")))
-
- ## else
- (&.throw Cannot-Convert-To-Parameter (type-descriptor type))))
-
-(type: Method-Type
- #Static
- #Abstract
- #Virtual
- #Special
- #Interface)
-
-(def: (check-method class method-name method-type arg-classes method)
- (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool))
- (do macro.Monad<Meta>
- [parameters (|> (Method::getGenericParameterTypes [] method)
- array.to-list
- (monad.map @ java-type-to-parameter))
- #let [modifiers (Method::getModifiers [] method)]]
- (wrap (and (Object::equals [class] (Method::getDeclaringClass [] method))
- (text/= method-name (Method::getName [] method))
- (case #Static
- #Special
- (Modifier::isStatic [modifiers])
-
- _
- true)
- (case method-type
- #Special
- (not (or (Modifier::isInterface [(Class::getModifiers [] class)])
- (Modifier::isAbstract [modifiers])))
-
- _
- true)
- (n/= (list.size arg-classes) (list.size parameters))
- (list/fold (function (_ [expectedJC actualJC] prev)
- (and prev
- (text/= expectedJC actualJC)))
- true
- (list.zip2 arg-classes parameters))))))
-
-(def: (check-constructor class arg-classes constructor)
- (-> (Class Object) (List Text) (Constructor Object) (Meta Bool))
- (do macro.Monad<Meta>
- [parameters (|> (Constructor::getGenericParameterTypes [] constructor)
- array.to-list
- (monad.map @ java-type-to-parameter))]
- (wrap (and (Object::equals [class] (Constructor::getDeclaringClass [] constructor))
- (n/= (list.size arg-classes) (list.size parameters))
- (list/fold (function (_ [expectedJC actualJC] prev)
- (and prev
- (text/= expectedJC actualJC)))
- true
- (list.zip2 arg-classes parameters))))))
-
-(def: idx-to-bound
- (-> Nat Type)
- (|>> (n/* +2) n/inc #.Bound))
-
-(def: (type-vars amount offset)
- (-> Nat Nat (List Type))
- (if (n/= +0 amount)
- (list)
- (|> (list.n/range offset (|> amount n/dec (n/+ offset)))
- (list/map idx-to-bound))))
-
-(def: (method-to-type method-type method)
- (-> Method-Type Method (Meta [Type (List Type)]))
- (let [owner (Method::getDeclaringClass [] method)
- owner-name (Class::getName [] owner)
- owner-tvars (case method-type
- #Static
- (list)
-
- _
- (|> (Class::getTypeParameters [] owner)
- array.to-list
- (list/map (TypeVariable::getName []))))
- method-tvars (|> (Method::getTypeParameters [] method)
- array.to-list
- (list/map (TypeVariable::getName [])))
- num-owner-tvars (list.size owner-tvars)
- num-method-tvars (list.size method-tvars)
- all-tvars (list/compose owner-tvars method-tvars)
- num-all-tvars (list.size all-tvars)
- owner-tvarsT (type-vars num-owner-tvars +0)
- method-tvarsT (type-vars num-method-tvars num-owner-tvars)
- mappings (: Mappings
- (if (list.empty? all-tvars)
- fresh-mappings
- (|> (list/compose owner-tvarsT method-tvarsT)
- list.reverse
- (list.zip2 all-tvars)
- (dict.from-list text.Hash<Text>))))]
- (do macro.Monad<Meta>
- [inputsT (|> (Method::getGenericParameterTypes [] method)
- array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))
- outputT (java-type-to-lux-type mappings (Method::getGenericReturnType [] method))
- exceptionsT (|> (Method::getGenericExceptionTypes [] method)
- array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))
- #let [methodT (<| (type.univ-q num-all-tvars)
- (type.function (case method-type
- #Static
- inputsT
-
- _
- (list& (#.Primitive owner-name (list.reverse owner-tvarsT))
- inputsT)))
- outputT)]]
- (wrap [methodT exceptionsT]))))
-
-(def: (methods class-name method-name method-type arg-classes)
- (-> Text Text Method-Type (List Text) (Meta [Type (List Type)]))
- (do macro.Monad<Meta>
- [class (load-class class-name)
- candidates (|> class
- (Class::getDeclaredMethods [])
- array.to-list
- (monad.map @ (function (_ method)
- (do @
- [passes? (check-method class method-name method-type arg-classes method)]
- (wrap [passes? method])))))]
- (case (list.filter product.left candidates)
- #.Nil
- (&.throw No-Candidates (format class-name "#" method-name))
-
- (#.Cons candidate #.Nil)
- (|> candidate product.right (method-to-type method-type))
-
- _
- (&.throw Too-Many-Candidates (format class-name "#" method-name)))))
-
-(def: (constructor-to-type constructor)
- (-> (Constructor Object) (Meta [Type (List Type)]))
- (let [owner (Constructor::getDeclaringClass [] constructor)
- owner-name (Class::getName [] owner)
- owner-tvars (|> (Class::getTypeParameters [] owner)
- array.to-list
- (list/map (TypeVariable::getName [])))
- constructor-tvars (|> (Constructor::getTypeParameters [] constructor)
- array.to-list
- (list/map (TypeVariable::getName [])))
- num-owner-tvars (list.size owner-tvars)
- all-tvars (list/compose owner-tvars constructor-tvars)
- num-all-tvars (list.size all-tvars)
- owner-tvarsT (type-vars num-owner-tvars +0)
- constructor-tvarsT (type-vars num-all-tvars num-owner-tvars)
- mappings (: Mappings
- (if (list.empty? all-tvars)
- fresh-mappings
- (|> (list/compose owner-tvarsT constructor-tvarsT)
- list.reverse
- (list.zip2 all-tvars)
- (dict.from-list text.Hash<Text>))))]
- (do macro.Monad<Meta>
- [inputsT (|> (Constructor::getGenericParameterTypes [] constructor)
- array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))
- exceptionsT (|> (Constructor::getGenericExceptionTypes [] constructor)
- array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))
- #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT))
- constructorT (<| (type.univ-q num-all-tvars)
- (type.function inputsT)
- objectT)]]
- (wrap [constructorT exceptionsT]))))
-
-(def: (constructor-methods class-name arg-classes)
- (-> Text (List Text) (Meta [Type (List Type)]))
- (do macro.Monad<Meta>
- [class (load-class class-name)
- candidates (|> class
- (Class::getConstructors [])
- array.to-list
- (monad.map @ (function (_ constructor)
- (do @
- [passes? (check-constructor class arg-classes constructor)]
- (wrap [passes? constructor])))))]
- (case (list.filter product.left candidates)
- #.Nil
- (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")"))
-
- (#.Cons candidate #.Nil)
- (|> candidate product.right constructor-to-type)
-
- _
- (&.throw Too-Many-Candidates class-name))))
-
-(def: (decorate-inputs typesT inputsA)
- (-> (List Text) (List la.Analysis) (List la.Analysis))
- (|> inputsA
- (list.zip2 (list/map code.text typesT))
- (list/map (function (_ [type value])
- (la.product (list type value))))))
-
-(def: (invoke//static proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case (: (e.Error [Text Text (List [Text Code])])
- (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any))))))
- (#e.Success [class method argsTC])
- (do macro.Monad<Meta>
- [#let [argsT (list/map product.left argsTC)]
- [methodT exceptionsT] (methods class method #Static argsT)
- [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))
- outputJC (check-jvm outputT)]
- (wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text outputJC) (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: (invoke//virtual proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case (: (e.Error [Text Text Code (List [Text Code])])
- (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))))))
- (#e.Success [class method objectC argsTC])
- (do macro.Monad<Meta>
- [#let [argsT (list/map product.left argsTC)]
- [methodT exceptionsT] (methods class method #Virtual argsT)
- [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
- #let [[objectA argsA] (case allA
- (#.Cons objectA argsA)
- [objectA argsA]
-
- _
- (undefined))]
- outputJC (check-jvm outputT)]
- (wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text outputJC) objectA (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: (invoke//special proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]])
- (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!)))
- (#e.Success [_ [class method objectC argsTC _]])
- (do macro.Monad<Meta>
- [#let [argsT (list/map product.left argsTC)]
- [methodT exceptionsT] (methods class method #Special argsT)
- [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
- outputJC (check-jvm outputT)]
- (wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text outputJC) (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: (invoke//interface proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case (: (e.Error [Text Text Code (List [Text Code])])
- (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))))))
- (#e.Success [class-name method objectC argsTC])
- (do macro.Monad<Meta>
- [#let [argsT (list/map product.left argsTC)]
- class (load-class class-name)
- _ (&.assert Non-Interface class-name
- (Modifier::isInterface [(Class::getModifiers [] class)]))
- [methodT exceptionsT] (methods class-name method #Interface argsT)
- [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
- outputJC (check-jvm outputT)]
- (wrap (la.procedure proc
- (list& (code.text class-name) (code.text method) (code.text outputJC)
- (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: (invoke//constructor proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case (: (e.Error [Text (List [Text Code])])
- (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any))))))
- (#e.Success [class argsTC])
- (do macro.Monad<Meta>
- [#let [argsT (list/map product.left argsTC)]
- [methodT exceptionsT] (constructor-methods class argsT)
- [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))]
- (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: member-procs
- @.Bundle
- (<| (@.prefix "member")
- (|> (dict.new text.Hash<Text>)
- (dict.merge (<| (@.prefix "static")
- (|> (dict.new text.Hash<Text>)
- (@.install "get" static//get)
- (@.install "put" static//put))))
- (dict.merge (<| (@.prefix "virtual")
- (|> (dict.new text.Hash<Text>)
- (@.install "get" virtual//get)
- (@.install "put" virtual//put))))
- (dict.merge (<| (@.prefix "invoke")
- (|> (dict.new text.Hash<Text>)
- (@.install "static" invoke//static)
- (@.install "virtual" invoke//virtual)
- (@.install "special" invoke//special)
- (@.install "interface" invoke//interface)
- (@.install "constructor" invoke//constructor)
- )))
- )))
-
-(def: #export procedures
- @.Bundle
- (<| (@.prefix "jvm")
- (|> (dict.new text.Hash<Text>)
- (dict.merge conversion-procs)
- (dict.merge int-procs)
- (dict.merge long-procs)
- (dict.merge float-procs)
- (dict.merge double-procs)
- (dict.merge char-procs)
- (dict.merge array-procs)
- (dict.merge object-procs)
- (dict.merge member-procs)
- )))
diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux
deleted file mode 100644
index 33c8aa063..000000000
--- a/new-luxc/source/luxc/lang/synthesis.lux
+++ /dev/null
@@ -1,8 +0,0 @@
-(.module:
- lux)
-
-(def: #export Arity Nat)
-
-(type: #export Synthesis Code)
-
-(type: #export Path Code)
diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux
deleted file mode 100644
index fba355a79..000000000
--- a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux
+++ /dev/null
@@ -1,324 +0,0 @@
-(.module:
- lux
- (lux [io]
- (control [monad #+ do]
- pipe)
- (concurrency [atom])
- (data text/format
- ["e" error]
- [product]
- (coll [array]))
- ["r" math/random "r/" Monad<Random>]
- [macro #+ Monad<Meta>]
- (macro [code])
- (lang [type "type/" Eq<Type>])
- test)
- (luxc ["&" lang]
- (lang ["&." scope]
- ["&." module]
- ["~" analysis]
- (analysis [".A" expression]
- ["@." common])
- [".L" eval]))
- (/// common)
- (test/luxc common))
-
-(do-template [<name> <success> <failure>]
- [(def: (<name> procedure params output-type)
- (-> Text (List Code) Type Bool)
- (|> (&.with-scope
- (&.with-type output-type
- (analyse (` ((~ (code.text procedure)) (~+ params))))))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- <success>
-
- (#e.Error error)
- <failure>)))]
-
- [check-success+ true false]
- [check-failure+ false true]
- )
-
-(context: "Lux procedures"
- (<| (times +100)
- (do @
- [[primT primC] gen-primitive
- [antiT antiC] (|> gen-primitive
- (r.filter (|>> product.left (type/= primT) not)))]
- ($_ seq
- (test "Can test for reference equality."
- (check-success+ "lux is" (list primC primC) Bool))
- (test "Reference equality must be done with elements of the same type."
- (check-failure+ "lux is" (list primC antiC) Bool))
- (test "Can 'try' risky IO computations."
- (check-success+ "lux try"
- (list (` ("lux function" (~' _) (~' _) (~ primC))))
- (type (Either Text primT))))
- ))))
-
-(context: "Bit procedures"
- (<| (times +100)
- (do @
- [subjectC (|> r.nat (:: @ map code.nat))
- signedC (|> r.int (:: @ map code.int))
- paramC (|> r.nat (:: @ map code.nat))]
- ($_ seq
- (test "Can count the number of 1 bits in a bit pattern."
- (check-success+ "lux bit count" (list subjectC) Nat))
- (test "Can perform bit 'and'."
- (check-success+ "lux bit and" (list subjectC paramC) Nat))
- (test "Can perform bit 'or'."
- (check-success+ "lux bit or" (list subjectC paramC) Nat))
- (test "Can perform bit 'xor'."
- (check-success+ "lux bit xor" (list subjectC paramC) Nat))
- (test "Can shift bit pattern to the left."
- (check-success+ "lux bit left-shift" (list subjectC paramC) Nat))
- (test "Can shift bit pattern to the right."
- (check-success+ "lux bit logical-right-shift" (list subjectC paramC) Nat))
- (test "Can shift signed bit pattern to the right."
- (check-success+ "lux bit arithmetic-right-shift" (list signedC paramC) Int))
- ))))
-
-(context: "Int procedures"
- (<| (times +100)
- (do @
- [subjectC (|> r.int (:: @ map code.int))
- paramC (|> r.int (:: @ map code.int))]
- ($_ seq
- (test "Can add integers."
- (check-success+ "lux int +" (list subjectC paramC) Int))
- (test "Can subtract integers."
- (check-success+ "lux int -" (list subjectC paramC) Int))
- (test "Can multiply integers."
- (check-success+ "lux int *" (list subjectC paramC) Int))
- (test "Can divide integers."
- (check-success+ "lux int /" (list subjectC paramC) Int))
- (test "Can calculate remainder of integers."
- (check-success+ "lux int %" (list subjectC paramC) Int))
- (test "Can test equality of integers."
- (check-success+ "lux int =" (list subjectC paramC) Bool))
- (test "Can compare integers."
- (check-success+ "lux int <" (list subjectC paramC) Bool))
- (test "Can obtain minimum integer."
- (check-success+ "lux int min" (list) Int))
- (test "Can obtain maximum integer."
- (check-success+ "lux int max" (list) Int))
- (test "Can convert integer to natural number."
- (check-success+ "lux int to-nat" (list subjectC) Nat))
- (test "Can convert integer to frac number."
- (check-success+ "lux int to-frac" (list subjectC) Frac))
- (test "Can convert integer to text."
- (check-success+ "lux int char" (list subjectC) Text))
- ))))
-
-(context: "Frac procedures"
- (<| (times +100)
- (do @
- [subjectC (|> r.frac (:: @ map code.frac))
- paramC (|> r.frac (:: @ map code.frac))
- encodedC (|> (r.text +5) (:: @ map code.text))]
- ($_ seq
- (test "Can add frac numbers."
- (check-success+ "lux frac +" (list subjectC paramC) Frac))
- (test "Can subtract frac numbers."
- (check-success+ "lux frac -" (list subjectC paramC) Frac))
- (test "Can multiply frac numbers."
- (check-success+ "lux frac *" (list subjectC paramC) Frac))
- (test "Can divide frac numbers."
- (check-success+ "lux frac /" (list subjectC paramC) Frac))
- (test "Can calculate remainder of frac numbers."
- (check-success+ "lux frac %" (list subjectC paramC) Frac))
- (test "Can test equality of frac numbers."
- (check-success+ "lux frac =" (list subjectC paramC) Bool))
- (test "Can compare frac numbers."
- (check-success+ "lux frac <" (list subjectC paramC) Bool))
- (test "Can obtain minimum frac number."
- (check-success+ "lux frac min" (list) Frac))
- (test "Can obtain maximum frac number."
- (check-success+ "lux frac max" (list) Frac))
- (test "Can obtain smallest frac number."
- (check-success+ "lux frac smallest" (list) Frac))
- (test "Can obtain not-a-number."
- (check-success+ "lux frac not-a-number" (list) Frac))
- (test "Can obtain positive infinity."
- (check-success+ "lux frac positive-infinity" (list) Frac))
- (test "Can obtain negative infinity."
- (check-success+ "lux frac negative-infinity" (list) Frac))
- (test "Can convert frac number to integer."
- (check-success+ "lux frac to-int" (list subjectC) Int))
- (test "Can convert frac number to text."
- (check-success+ "lux frac encode" (list subjectC) Text))
- (test "Can convert text to frac number."
- (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac))))
- ))))
-
-(context: "Text procedures"
- (<| (times +100)
- (do @
- [subjectC (|> (r.text +5) (:: @ map code.text))
- paramC (|> (r.text +5) (:: @ map code.text))
- replacementC (|> (r.text +5) (:: @ map code.text))
- fromC (|> r.nat (:: @ map code.nat))
- toC (|> r.nat (:: @ map code.nat))]
- ($_ seq
- (test "Can test text equality."
- (check-success+ "lux text =" (list subjectC paramC) Bool))
- (test "Compare texts in lexicographical order."
- (check-success+ "lux text <" (list subjectC paramC) Bool))
- (test "Can concatenate one text to another."
- (check-success+ "lux text concat" (list subjectC paramC) Text))
- (test "Can find the index of a piece of text inside a larger one that (may) contain it."
- (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat))))
- (test "Can query the size/length of a text."
- (check-success+ "lux text size" (list subjectC) Nat))
- (test "Can calculate a hash code for text."
- (check-success+ "lux text hash" (list subjectC) Nat))
- (test "Can replace a text inside of a larger one (once)."
- (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text))
- (test "Can replace a text inside of a larger one (all times)."
- (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text))
- (test "Can obtain the character code of a text at a given index."
- (check-success+ "lux text char" (list subjectC fromC) (type (Maybe Nat))))
- (test "Can clip a piece of text between 2 indices."
- (check-success+ "lux text clip" (list subjectC fromC toC) (type (Maybe Text))))
- ))))
-
-(context: "Array procedures"
- (<| (times +100)
- (do @
- [[elemT elemC] gen-primitive
- sizeC (|> r.nat (:: @ map code.nat))
- idxC (|> r.nat (:: @ map code.nat))
- var-name (r.text +5)
- #let [arrayT (type (Array elemT))
- g!array (code.local-symbol var-name)
- array-operation (function (_ output-type code)
- (|> (&scope.with-scope ""
- (&scope.with-local [var-name arrayT]
- (&.with-type output-type
- (analyse code))))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- true
-
- (#e.Error error)
- false)))]]
- ($_ seq
- (test "Can create arrays."
- (check-success+ "lux array new" (list sizeC) arrayT))
- (test "Can get a value inside an array."
- (array-operation (type (Maybe elemT))
- (` ("lux array get" (~ g!array) (~ idxC)))))
- (test "Can put a value inside an array."
- (array-operation arrayT
- (` ("lux array put" (~ g!array) (~ idxC) (~ elemC)))))
- (test "Can remove a value from an array."
- (array-operation arrayT
- (` ("lux array remove" (~ g!array) (~ idxC)))))
- (test "Can query the size of an array."
- (array-operation Nat
- (` ("lux array size" (~ g!array)))))
- ))))
-
-(context: "Math procedures"
- (<| (times +100)
- (do @
- [subjectC (|> r.frac (:: @ map code.frac))
- paramC (|> r.frac (:: @ map code.frac))]
- (with-expansions [<unary> (do-template [<proc> <desc>]
- [(test (format "Can calculate " <desc> ".")
- (check-success+ <proc> (list subjectC) Frac))]
-
- ["lux math cos" "cosine"]
- ["lux math sin" "sine"]
- ["lux math tan" "tangent"]
- ["lux math acos" "inverse/arc cosine"]
- ["lux math asin" "inverse/arc sine"]
- ["lux math atan" "inverse/arc tangent"]
- ["lux math cosh" "hyperbolic cosine"]
- ["lux math sinh" "hyperbolic sine"]
- ["lux math tanh" "hyperbolic tangent"]
- ["lux math exp" "exponentiation"]
- ["lux math log" "logarithm"]
- ["lux math ceil" "ceiling"]
- ["lux math floor" "floor"]
- ["lux math round" "rounding"])
- <binary> (do-template [<proc> <desc>]
- [(test (format "Can calculate " <desc> ".")
- (check-success+ <proc> (list subjectC paramC) Frac))]
-
- ["lux math atan2" "inverse/arc tangent (with 2 arguments)"]
- ["lux math pow" "power"])]
- ($_ seq
- <unary>
- <binary>)))))
-
-(context: "Atom procedures"
- (<| (times +100)
- (do @
- [[elemT elemC] gen-primitive
- sizeC (|> r.nat (:: @ map code.nat))
- idxC (|> r.nat (:: @ map code.nat))
- var-name (r.text +5)
- #let [atomT (type (atom.Atom elemT))]]
- ($_ seq
- (test "Can create atomic reference."
- (check-success+ "lux atom new" (list elemC) atomT))
- (test "Can read the value of an atomic reference."
- (|> (&scope.with-scope ""
- (&scope.with-local [var-name atomT]
- (&.with-type elemT
- (analyse (` ("lux atom read" (~ (code.symbol ["" var-name]))))))))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- true
-
- (#e.Error _)
- false)))
- (test "Can swap the value of an atomic reference."
- (|> (&scope.with-scope ""
- (&scope.with-local [var-name atomT]
- (&.with-type Bool
- (analyse (` ("lux atom compare-and-swap"
- (~ (code.symbol ["" var-name]))
- (~ elemC)
- (~ elemC)))))))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- true
-
- (#e.Error _)
- false)))
- ))))
-
-(context: "Process procedures"
- (<| (times +100)
- (do @
- [[primT primC] gen-primitive
- timeC (|> r.nat (:: @ map code.nat))]
- ($_ seq
- (test "Can query the level of concurrency."
- (check-success+ "lux process parallelism-level" (list) Nat))
- (test "Can schedule an IO computation to run concurrently at some future time."
- (check-success+ "lux process schedule"
- (list timeC
- (` ("lux function" (~' _) (~' _) (~ primC))))
- Any))
- ))))
-
-(context: "IO procedures"
- (<| (times +100)
- (do @
- [logC (|> (r.text +5) (:: @ map code.text))
- exitC (|> r.int (:: @ map code.int))]
- ($_ seq
- (test "Can log messages to standard output."
- (check-success+ "lux io log" (list logC) Any))
- (test "Can throw a run-time error."
- (check-success+ "lux io error" (list logC) Nothing))
- (test "Can exit the program."
- (check-success+ "lux io exit" (list exitC) Nothing))
- (test "Can query the current time (as milliseconds since epoch)."
- (check-success+ "lux io current-time" (list) Int))
- ))))
diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
deleted file mode 100644
index 3d0c76777..000000000
--- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
+++ /dev/null
@@ -1,546 +0,0 @@
-(.module:
- lux
- (lux [io]
- (control [monad #+ do]
- pipe)
- (concurrency [atom])
- (data ["e" error]
- [product]
- [maybe]
- [text "text/" Eq<Text>]
- text/format
- (coll [array]
- [list "list/" Fold<List>]
- (dictionary ["dict" unordered])))
- ["r" math/random "r/" Monad<Random>]
- [macro #+ Monad<Meta>]
- (macro [code])
- (lang [type])
- test)
- (luxc ["&" lang]
- (lang ["&." scope]
- ["&." module]
- ["~" analysis]
- (analysis [".A" expression]
- ["@." common])
- (translation (jvm ["@." runtime]))
- (extension (analysis ["@." host]))
- [".L" eval]))
- (/// common)
- (test/luxc common))
-
-(do-template [<name> <success> <failure>]
- [(def: (<name> procedure params output-type)
- (-> Text (List Code) Type Bool)
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime.translate]
- (&.with-scope
- (&.with-type output-type
- ((expressionA.analyser evalL.eval)
- (` ((~ (code.text procedure)) (~+ params)))))))
- (&.with-current-module "")
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- <success>
-
- (#e.Error error)
- <failure>)))]
-
- [success true false]
- [failure false true]
- )
-
-(do-template [<name> <success> <failure>]
- [(def: (<name> syntax output-type)
- (-> Code Type Bool)
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime.translate]
- (&.with-scope
- (&.with-type output-type
- (expressionA.analyser evalL.eval syntax))))
- (&.with-current-module "")
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- <success>
-
- (#e.Error error)
- <failure>)))]
-
- [success' true false]
- [failure' false true]
- )
-
-(context: "Conversions [double + float]."
- (with-expansions [<conversions> (do-template [<procedure> <from> <to>]
- [(test (format <procedure> " SUCCESS")
- (success <procedure> (list (' ("lux coerce" (+0 <from> (+0)) []))) <to>))
- (test (format <procedure> " FAILURE")
- (failure <procedure> (list (' [])) <to>))]
-
- ["jvm convert double-to-float" "java.lang.Double" @host.Float]
- ["jvm convert double-to-int" "java.lang.Double" @host.Integer]
- ["jvm convert double-to-long" "java.lang.Double" @host.Long]
- ["jvm convert float-to-double" "java.lang.Float" @host.Double]
- ["jvm convert float-to-int" "java.lang.Float" @host.Integer]
- ["jvm convert float-to-long" "java.lang.Float" @host.Long]
- )]
- ($_ seq
- <conversions>
- )))
-
-(context: "Conversions [int]."
- (with-expansions [<conversions> (do-template [<procedure> <from> <to>]
- [(test (format <procedure> " SUCCESS")
- (success <procedure> (list (' ("lux coerce" (+0 <from> (+0)) []))) <to>))
- (test (format <procedure> " FAILURE")
- (failure <procedure> (list (' [])) <to>))]
-
- ["jvm convert int-to-byte" "java.lang.Integer" @host.Byte]
- ["jvm convert int-to-char" "java.lang.Integer" @host.Character]
- ["jvm convert int-to-double" "java.lang.Integer" @host.Double]
- ["jvm convert int-to-float" "java.lang.Integer" @host.Float]
- ["jvm convert int-to-long" "java.lang.Integer" @host.Long]
- ["jvm convert int-to-short" "java.lang.Integer" @host.Short]
- )]
- ($_ seq
- <conversions>
- )))
-
-(context: "Conversions [long]."
- (with-expansions [<conversions> (do-template [<procedure> <from> <to>]
- [(test (format <procedure> " SUCCESS")
- (success <procedure> (list (' ("lux coerce" (+0 <from> (+0)) []))) <to>))
- (test (format <procedure> " FAILURE")
- (failure <procedure> (list (' [])) <to>))]
-
- ["jvm convert long-to-double" "java.lang.Long" @host.Double]
- ["jvm convert long-to-float" "java.lang.Long" @host.Float]
- ["jvm convert long-to-int" "java.lang.Long" @host.Integer]
- ["jvm convert long-to-short" "java.lang.Long" @host.Short]
- ["jvm convert long-to-byte" "java.lang.Long" @host.Byte]
- )]
- ($_ seq
- <conversions>
- )))
-
-(context: "Conversions [char + byte + short]."
- (with-expansions [<conversions> (do-template [<procedure> <from> <to>]
- [(test (format <procedure> " SUCCESS")
- (success <procedure> (list (' ("lux coerce" (+0 <from> (+0)) []))) <to>))
- (test (format <procedure> " FAILURE")
- (failure <procedure> (list (' [])) <to>))]
-
- ["jvm convert char-to-byte" "java.lang.Character" @host.Byte]
- ["jvm convert char-to-short" "java.lang.Character" @host.Short]
- ["jvm convert char-to-int" "java.lang.Character" @host.Integer]
- ["jvm convert char-to-long" "java.lang.Character" @host.Long]
- ["jvm convert byte-to-long" "java.lang.Byte" @host.Long]
- ["jvm convert short-to-long" "java.lang.Short" @host.Long]
- )]
- ($_ seq
- <conversions>
- )))
-
-(do-template [<domain> <boxed> <type>]
- [(context: (format "Arithmetic " "[" <domain> "].")
- (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
- [(test <procedure>
- (success <procedure>
- (list (' ("lux coerce" (+0 <subject> (+0)) []))
- (' ("lux coerce" (+0 <param> (+0)) [])))
- <output>))]
-
- [(format "jvm " <domain> " +") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " -") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " *") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " /") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " %") <boxed> <boxed> <type>]
- )]
- ($_ seq
- <instructions>
- )))
-
- (context: (format "Order " "[" <domain> "].")
- (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
- [(test <procedure>
- (success <procedure>
- (list (' ("lux coerce" (+0 <subject> (+0)) []))
- (' ("lux coerce" (+0 <param> (+0)) [])))
- <output>))]
-
- [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean]
- [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean]
- )]
- ($_ seq
- <instructions>
- )))
-
- (context: (format "Bitwise " "[" <domain> "].")
- (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
- [(test <procedure>
- (success <procedure>
- (list (' ("lux coerce" (+0 <subject> (+0)) []))
- (' ("lux coerce" (+0 <param> (+0)) [])))
- <output>))]
-
- [(format "jvm " <domain> " and") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " or") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " xor") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " shl") <boxed> "java.lang.Integer" <type>]
- [(format "jvm " <domain> " shr") <boxed> "java.lang.Integer" <type>]
- [(format "jvm " <domain> " ushr") <boxed> "java.lang.Integer" <type>]
- )]
- ($_ seq
- <instructions>
- )))]
-
-
- ["int" "java.lang.Integer" @host.Integer]
- ["long" "java.lang.Long" @host.Long]
- )
-
-(do-template [<domain> <boxed> <type>]
- [(context: (format "Arithmetic " "[" <domain> "].")
- (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
- [(test <procedure>
- (success <procedure>
- (list (' ("lux coerce" (+0 <subject> (+0)) []))
- (' ("lux coerce" (+0 <param> (+0)) [])))
- <output>))]
-
- [(format "jvm " <domain> " +") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " -") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " *") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " /") <boxed> <boxed> <type>]
- [(format "jvm " <domain> " %") <boxed> <boxed> <type>]
- )]
- ($_ seq
- <instructions>
- )))
-
- (context: (format "Order " "[" <domain> "].")
- (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
- [(test <procedure>
- (success <procedure>
- (list (' ("lux coerce" (+0 <subject> (+0)) []))
- (' ("lux coerce" (+0 <param> (+0)) [])))
- <output>))]
-
- [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean]
- [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean]
- )]
- ($_ seq
- <instructions>
- )))]
-
-
- ["float" "java.lang.Float" @host.Float]
- ["double" "java.lang.Double" @host.Double]
- )
-
-(do-template [<domain> <boxed> <type>]
- [(context: (format "Order " "[" <domain> "].")
- (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
- [(test <procedure>
- (success <procedure>
- (list (' ("lux coerce" (+0 <subject> (+0)) []))
- (' ("lux coerce" (+0 <param> (+0)) [])))
- <output>))]
-
- [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean]
- [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean]
- )]
- ($_ seq
- <instructions>
- )))]
-
-
- ["char" "java.lang.Character" @host.Character]
- )
-
-(def: array-type
- (r.Random [Text Text])
- (let [entries (dict.entries @host.boxes)
- num-entries (list.size entries)]
- (do r.Monad<Random>
- [choice (|> r.nat (:: @ map (n/% (n/inc num-entries))))
- #let [[unboxed boxed] (: [Text Text]
- (|> entries
- (list.nth choice)
- (maybe.default ["java.lang.Object" "java.lang.Object"])))]]
- (wrap [unboxed boxed]))))
-
-(context: "Array."
- (<| (times +100)
- (do @
- [#let [cap (|>> (n/% +10) (n/max +1))]
- [unboxed boxed] array-type
- size (|> r.nat (:: @ map cap))
- idx (|> r.nat (:: @ map (n/% size)))
- level (|> r.nat (:: @ map cap))
- #let [unboxedT (#.Primitive unboxed (list))
- arrayT (#.Primitive "#Array" (list unboxedT))
- arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0)))
- ("jvm array new" (~ (code.nat size)))))
- boxedT (#.Primitive boxed (list))
- boxedTC (` (+0 (~ (code.text boxed)) (+0)))
- multi-arrayT (list/fold (function (_ _ innerT)
- (|> innerT (list) (#.Primitive "#Array")))
- boxedT
- (list.n/range +1 level))]]
- ($_ seq
- (test "jvm array new"
- (success "jvm array new"
- (list (code.nat size))
- arrayT))
- (test "jvm array new (no nesting)"
- (failure "jvm array new"
- (list (code.nat size))
- unboxedT))
- (test "jvm array new (nested/multi-level)"
- (success "jvm array new"
- (list (code.nat size))
- multi-arrayT))
- (test "jvm array length"
- (success "jvm array length"
- (list arrayC)
- Nat))
- (test "jvm array read"
- (success' (` ("jvm object cast"
- ("jvm array read" (~ arrayC) (~ (code.nat idx)))))
- boxedT))
- (test "jvm array write"
- (success "jvm array write"
- (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) [])))
- arrayT))
- ))))
-
-(def: throwables
- (List Text)
- (list "java.lang.Throwable"
- "java.lang.Error"
- "java.io.IOError"
- "java.lang.VirtualMachineError"
- "java.lang.Exception"
- "java.io.IOException"
- "java.lang.RuntimeException"))
-
-(context: "Object."
- (<| (times +100)
- (do @
- [[unboxed boxed] array-type
- [!unboxed !boxed] (|> array-type
- (r.filter (function (_ [!unboxed !boxed])
- (not (text/= boxed !boxed)))))
- #let [boxedT (#.Primitive boxed (list))
- boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0))
- ("jvm object null")))
- !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0))
- ("jvm object null")))
- unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0))
- ("jvm object null")))]
- throwable (|> r.nat
- (:: @ map (n/% (n/inc (list.size throwables))))
- (:: @ map (function (_ idx)
- (|> throwables
- (list.nth idx)
- (maybe.default "java.lang.Object")))))
- #let [throwableC (`' ("lux check" (+0 (~ (code.text throwable)) (+0))
- ("jvm object null")))]]
- ($_ seq
- (test "jvm object null"
- (success "jvm object null"
- (list)
- (#.Primitive boxed (list))))
- (test "jvm object null (no primitives)"
- (or (text/= "java.lang.Object" boxed)
- (failure "jvm object null"
- (list)
- (#.Primitive unboxed (list)))))
- (test "jvm object null?"
- (success "jvm object null?"
- (list boxedC)
- Bool))
- (test "jvm object synchronized"
- (success "jvm object synchronized"
- (list boxedC boxedC)
- boxedT))
- (test "jvm object synchronized (no primitives)"
- (or (text/= "java.lang.Object" boxed)
- (failure "jvm object synchronized"
- (list unboxedC boxedC)
- boxedT)))
- (test "jvm object throw"
- (or (text/= "java.lang.Object" throwable)
- (success "jvm object throw"
- (list throwableC)
- Nothing)))
- (test "jvm object class"
- (success "jvm object class"
- (list (code.text boxed))
- (#.Primitive "java.lang.Class" (list boxedT))))
- (test "jvm object instance?"
- (success "jvm object instance?"
- (list (code.text boxed)
- boxedC)
- Bool))
- (test "jvm object instance? (lineage)"
- (success "jvm object instance?"
- (list (' "java.lang.Object")
- boxedC)
- Bool))
- (test "jvm object instance? (no lineage)"
- (or (text/= "java.lang.Object" boxed)
- (failure "jvm object instance?"
- (list (code.text boxed)
- !boxedC)
- Bool)))
- ))))
-
-(context: "Member [Static Field]."
- ($_ seq
- (test "jvm member static get"
- (success "jvm member static get"
- (list (code.text "java.lang.System")
- (code.text "out"))
- (#.Primitive "java.io.PrintStream" (list))))
- (test "jvm member static get (inheritance out)"
- (success "jvm member static get"
- (list (code.text "java.lang.System")
- (code.text "out"))
- (#.Primitive "java.lang.Object" (list))))
- (test "jvm member static put"
- (success "jvm member static put"
- (list (code.text "java.awt.datatransfer.DataFlavor")
- (code.text "allHtmlFlavor")
- (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0))
- ("jvm object null"))))
- Any))
- (test "jvm member static put (final)"
- (failure "jvm member static put"
- (list (code.text "java.lang.System")
- (code.text "out")
- (`' ("lux check" (+0 "java.io.PrintStream" (+0))
- ("jvm object null"))))
- Any))
- (test "jvm member static put (inheritance in)"
- (success "jvm member static put"
- (list (code.text "java.awt.datatransfer.DataFlavor")
- (code.text "allHtmlFlavor")
- (`' ("jvm object cast"
- ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0))
- ("jvm object null")))))
- Any))
- ))
-
-(context: "Member [Virtual Field]."
- ($_ seq
- (test "jvm member virtual get"
- (success "jvm member virtual get"
- (list (code.text "org.omg.CORBA.ValueMember")
- (code.text "id")
- (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0))
- ("jvm object null"))))
- (#.Primitive "java.lang.String" (list))))
- (test "jvm member virtual get (inheritance out)"
- (success "jvm member virtual get"
- (list (code.text "org.omg.CORBA.ValueMember")
- (code.text "id")
- (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0))
- ("jvm object null"))))
- (#.Primitive "java.lang.Object" (list))))
- (test "jvm member virtual put"
- (success "jvm member virtual put"
- (list (code.text "org.omg.CORBA.ValueMember")
- (code.text "id")
- (`' ("lux check" (+0 "java.lang.String" (+0))
- ("jvm object null")))
- (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0))
- ("jvm object null"))))
- (primitive "org.omg.CORBA.ValueMember")))
- (test "jvm member virtual put (final)"
- (failure "jvm member virtual put"
- (list (code.text "javax.swing.text.html.parser.DTD")
- (code.text "applet")
- (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0))
- ("jvm object null")))
- (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0))
- ("jvm object null"))))
- (primitive "javax.swing.text.html.parser.DTD")))
- (test "jvm member virtual put (inheritance in)"
- (success "jvm member virtual put"
- (list (code.text "java.awt.GridBagConstraints")
- (code.text "insets")
- (`' ("jvm object cast"
- ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0))
- ("jvm object null"))))
- (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0))
- ("jvm object null"))))
- (primitive "java.awt.GridBagConstraints")))
- ))
-
-(context: "Boxing/Unboxing."
- ($_ seq
- (test "jvm member static get"
- (success "jvm member static get"
- (list (code.text "java.util.GregorianCalendar")
- (code.text "AD"))
- (#.Primitive "java.lang.Integer" (list))))
- (test "jvm member virtual get"
- (success "jvm member virtual get"
- (list (code.text "javax.accessibility.AccessibleAttributeSequence")
- (code.text "startIndex")
- (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0))
- ("jvm object null"))))
- (#.Primitive "java.lang.Integer" (list))))
- (test "jvm member virtual put"
- (success "jvm member virtual put"
- (list (code.text "javax.accessibility.AccessibleAttributeSequence")
- (code.text "startIndex")
- (`' ("jvm object cast"
- ("lux check" (+0 "java.lang.Integer" (+0))
- ("jvm object null"))))
- (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0))
- ("jvm object null"))))
- (primitive "javax.accessibility.AccessibleAttributeSequence")))
- ))
-
-(context: "Member [Method]."
- (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0))
- +123))
- intC (`' ("jvm convert long-to-int" (~ longC)))
- stringC (' ("lux coerce" (+0 "java.lang.String" (+0))
- "YOLO"))
- objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0)))
- ("jvm member invoke constructor" "java.util.ArrayList"
- ["int" ("jvm object cast" (~ intC))])))]
- ($_ seq
- (test "jvm member invoke static"
- (success' (` ("jvm member invoke static"
- "java.lang.Long" "decode"
- ["java.lang.String" (~ stringC)]))
- (#.Primitive "java.lang.Long" (list))))
- (test "jvm member invoke virtual"
- (success' (` ("jvm object cast"
- ("jvm member invoke virtual"
- "java.lang.Object" "equals"
- ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
- (#.Primitive "java.lang.Boolean" (list))))
- (test "jvm member invoke special"
- (success' (` ("jvm object cast"
- ("jvm member invoke special"
- "java.lang.Long" "equals"
- ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
- (#.Primitive "java.lang.Boolean" (list))))
- (test "jvm member invoke interface"
- (success' (` ("jvm object cast"
- ("jvm member invoke interface"
- "java.util.Collection" "add"
- ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
- (#.Primitive "java.lang.Boolean" (list))))
- (test "jvm member invoke constructor"
- (success' (` ("jvm member invoke constructor"
- "java.util.ArrayList"
- ["int" ("jvm object cast" (~ intC))]))
- (All [a] (#.Primitive "java.util.ArrayList" (list a)))))
- )))