From 70005a6dee1eba3e3f5694aa4903e95988dcaa3d Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 13 Nov 2017 23:26:06 -0400
Subject: - Refactoring. - Now giving type checking/inference a higher
priority. - Better error messages.
---
new-luxc/source/luxc/base.lux | 14 +-
new-luxc/source/luxc/lang/analysis/case.lux | 26 +-
new-luxc/source/luxc/lang/analysis/common.lux | 11 +-
new-luxc/source/luxc/lang/analysis/expression.lux | 3 +-
new-luxc/source/luxc/lang/analysis/function.lux | 44 +-
new-luxc/source/luxc/lang/analysis/inference.lux | 27 +-
new-luxc/source/luxc/lang/analysis/primitive.lux | 8 +-
.../source/luxc/lang/analysis/procedure/common.lux | 183 ++++----
.../luxc/lang/analysis/procedure/host.jvm.lux | 514 +++++++++++----------
new-luxc/source/luxc/lang/analysis/reference.lux | 12 +-
new-luxc/source/luxc/lang/analysis/structure.lux | 75 ++-
new-luxc/source/luxc/lang/translation.lux | 3 +-
.../source/luxc/lang/translation/procedure.jvm.lux | 2 +-
.../luxc/lang/translation/procedure/host.jvm.lux | 44 +-
.../source/luxc/lang/translation/statement.jvm.lux | 12 +-
.../source/luxc/lang/translation/structure.jvm.lux | 7 +-
new-luxc/source/luxc/module.lux | 48 +-
17 files changed, 518 insertions(+), 515 deletions(-)
(limited to 'new-luxc/source')
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
index c7768cd8c..373c6b12b 100644
--- a/new-luxc/source/luxc/base.lux
+++ b/new-luxc/source/luxc/base.lux
@@ -9,7 +9,8 @@
text/format
(coll [list]))
[meta]
- (meta (type ["tc" check])))
+ (meta (type ["tc" check])
+ ["s" syntax #+ syntax:]))
(luxc (lang ["la" analysis])))
(type: #export Eval
@@ -30,16 +31,15 @@
(meta;fail (format message "\n\n"
"@ " location))))
-(def: #export (assert message test)
- (-> Text Bool (Meta Unit))
- (if test
- (:: meta;Monad wrap [])
- (fail message)))
-
(def: #export (throw exception message)
(All [a] (-> ex;Exception Text (Meta a)))
(fail (exception message)))
+(syntax: #export (assert exception message test)
+ (wrap (list (` (if (~ test)
+ (:: meta;Monad (~' wrap) [])
+ (;;throw (~ exception) (~ message)))))))
+
(def: #export (with-expected-type expected action)
(All [a] (-> Type (Meta a) (Meta a)))
(function [compiler]
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux
index b0098f7c2..5bf2e8ed1 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/new-luxc/source/luxc/lang/analysis/case.lux
@@ -26,13 +26,14 @@
(exception: #export Sum-Type-Has-No-Case)
(exception: #export Unrecognized-Pattern-Syntax)
(exception: #export Cannot-Simplify-Type-For-Pattern-Matching)
-(exception: #export Cannot-Apply-Type)
+(exception: #export Cannot-Have-Empty-Branches)
+(exception: #export Non-Exhaustive-Pattern-Matching)
+(exception: #export Symbols-Must-Be-Unqualified-Inside-Patterns)
(def: (pattern-error type pattern)
(-> Type Code Text)
- (Cannot-Match-Type-With-Pattern
- (format " Type: " (%type type) "\n"
- "Pattern: " (%code pattern))))
+ (format " Type: " (%type type) "\n"
+ "Pattern: " (%code pattern)))
## Type-checking on the input value is done during the analysis of a
## "case" expression, to ensure that the patterns being used make
@@ -73,7 +74,7 @@
[? (tc;concrete? funcT-id)]
(if ?
(tc;read funcT-id)
- (tc;throw Cannot-Apply-Type (%type caseT)))))]
+ (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
(simplify-case-type (#;Apply inputT funcT')))
_
@@ -82,7 +83,7 @@
(:: meta;Monad wrap outputT)
#;None
- (&;throw Cannot-Apply-Type (%type caseT))))
+ (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
_
(:: meta;Monad wrap caseT)))
@@ -116,7 +117,7 @@
[cursor (#;Symbol ident)]
(&;with-cursor cursor
- (&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident))))
+ (&;throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident)))
(^template [ ]
[cursor ( test)]
@@ -183,7 +184,7 @@
thenA])))
_
- (&;fail (pattern-error inputT pattern))
+ (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))
)))
[cursor (#;Record record)]
@@ -230,7 +231,7 @@
"Type: " (%type inputT)))))
_
- (&;fail (pattern-error inputT pattern)))))
+ (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)))))
(^ [cursor (#;Form (list& [_ (#;Tag tag)] values))])
(&;with-cursor cursor
@@ -249,7 +250,7 @@
(-> &;Analyser Code (List [Code Code]) (Meta la;Analysis))
(case branches
#;Nil
- (&;fail "Cannot have empty branches in pattern-matching expression.")
+ (&;throw Cannot-Have-Empty-Branches "")
(#;Cons [patternH bodyH] branchesT)
(do meta;Monad
@@ -264,9 +265,8 @@
outputTC (monad;map @ (|>. product;left coverageA;determine) outputT)
_ (case (monad;fold e;Monad coverageA;merge outputHC outputTC)
(#e;Success coverage)
- (if (coverageA;exhaustive? coverage)
- (wrap [])
- (&;fail "Pattern-matching is not exhaustive."))
+ (&;assert Non-Exhaustive-Pattern-Matching ""
+ (coverageA;exhaustive? coverage))
(#e;Error error)
(&;fail error))]
diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux
index 4d16e4ae6..1eb2b8b37 100644
--- a/new-luxc/source/luxc/lang/analysis/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/common.lux
@@ -4,7 +4,7 @@
["ex" exception #+ exception:])
(data text/format
[product])
- [meta #+ Monad]
+ [meta]
(meta [type]
(type ["tc" check])))
(luxc ["&" base]
@@ -12,7 +12,7 @@
(def: #export (with-unknown-type action)
(All [a] (-> (Meta Analysis) (Meta [Type Analysis])))
- (do Monad
+ (do meta;Monad
[[var-id var-type] (&;with-type-env
tc;var)
analysis (&;with-expected-type var-type
@@ -21,13 +21,6 @@
(tc;clean var-id var-type))]
(wrap [analysis-type analysis])))
-(def: #export (with-var body)
- (All [a] (-> (-> [Nat Type] (Meta a)) (Meta a)))
- (do Monad
- [[id var] (&;with-type-env
- tc;var)]
- (body [id var])))
-
(exception: #export Variant-Tag-Out-Of-Bounds)
(def: #export (variant-out-of-bounds-error type size tag)
diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
index 12256a4bf..248248010 100644
--- a/new-luxc/source/luxc/lang/analysis/expression.lux
+++ b/new-luxc/source/luxc/lang/analysis/expression.lux
@@ -24,6 +24,7 @@
(exception: #export Macro-Expression-Must-Have-Single-Expansion)
(exception: #export Unrecognized-Syntax)
+(exception: #export Macro-Expansion-Failed)
(def: #export (analyser eval)
(-> &;Eval &;Analyser)
@@ -96,7 +97,7 @@
(#e;Success [compiler' output])
(#e;Error error)
- ((&;fail error) compiler)))]
+ ((&;throw Macro-Expansion-Failed error) compiler)))]
(case expansion
(^ (list single))
(analyse single)
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
index 42a021577..0bb46aba1 100644
--- a/new-luxc/source/luxc/lang/analysis/function.lux
+++ b/new-luxc/source/luxc/lang/analysis/function.lux
@@ -38,7 +38,7 @@
(recur value)
#;None
- (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT))))
+ (&;throw Invalid-Function-Type (%type expectedT)))
(#;UnivQ _)
(do @
@@ -47,9 +47,9 @@
(recur (maybe;assume (type;apply (list var) expectedT))))
(#;ExQ _)
- (&common;with-var
- (function [[var-id var]]
- (recur (maybe;assume (type;apply (list var) expectedT)))))
+ (do @
+ [[var-id var] (&;with-type-env tc;var)]
+ (recur (maybe;assume (type;apply (list var) expectedT))))
(#;Var id)
(do @
@@ -61,25 +61,23 @@
(tc;read id))]
(recur expectedT'))
## Inference
- (&common;with-var
- (function [[input-id inputT]]
- (&common;with-var
- (function [[output-id outputT]]
- (do @
- [#let [funT (#;Function inputT outputT)]
- funA (recur funT)
- funT' (&;with-type-env
- (tc;clean output-id funT))
- concrete-input? (&;with-type-env
- (tc;concrete? input-id))
- funT'' (if concrete-input?
- (&;with-type-env
- (tc;clean input-id funT'))
- (wrap (type;univ-q +1 (&inference;replace-var input-id +1 funT'))))
- _ (&;with-type-env
- (tc;check expectedT funT''))]
- (wrap funA))
- ))))))
+ (do @
+ [[input-id inputT] (&;with-type-env tc;var)
+ [output-id outputT] (&;with-type-env tc;var)
+ #let [funT (#;Function inputT outputT)]
+ funA (recur funT)
+ funT' (&;with-type-env
+ (tc;clean output-id funT))
+ concrete-input? (&;with-type-env
+ (tc;concrete? input-id))
+ funT'' (if concrete-input?
+ (&;with-type-env
+ (tc;clean input-id funT'))
+ (wrap (type;univ-q +1 (&inference;replace-var input-id +1 funT'))))
+ _ (&;with-type-env
+ (tc;check expectedT funT''))]
+ (wrap funA))
+ ))
(#;Function inputT outputT)
(<| (:: @ map (function [[scope bodyA]]
diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux
index e2866ac87..934ecafa5 100644
--- a/new-luxc/source/luxc/lang/analysis/inference.lux
+++ b/new-luxc/source/luxc/lang/analysis/inference.lux
@@ -109,20 +109,19 @@
(apply-function analyse unnamedT args)
(#;UnivQ _)
- (&common;with-var
- (function [[var-id varT]]
- (do Monad
- [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)]
- (do @
- [? (&;with-type-env
- (tc;concrete? var-id))
- ## Quantify over the type if genericity/parametricity
- ## is discovered.
- outputT' (if ?
- (&;with-type-env
- (tc;clean var-id outputT))
- (wrap (type;univ-q +1 (replace-var var-id +1 outputT))))]
- (wrap [outputT' argsA])))))
+ (do Monad
+ [[var-id varT] (&;with-type-env tc;var)
+ [outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)]
+ (do @
+ [? (&;with-type-env
+ (tc;concrete? var-id))
+ ## Quantify over the type if genericity/parametricity
+ ## is discovered.
+ outputT' (if ?
+ (&;with-type-env
+ (tc;clean var-id outputT))
+ (wrap (type;univ-q +1 (replace-var var-id +1 outputT))))]
+ (wrap [outputT' argsA])))
(#;ExQ _)
(do Monad
diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux
index c7f7243fd..bb1762f46 100644
--- a/new-luxc/source/luxc/lang/analysis/primitive.lux
+++ b/new-luxc/source/luxc/lang/analysis/primitive.lux
@@ -12,9 +12,7 @@
[(def: #export ( value)
(-> (Meta Analysis))
(do meta;Monad
- [expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected ))]
+ [_ (&;infer )]
(wrap ( value))))]
[analyse-bool Bool code;bool]
@@ -28,7 +26,5 @@
(def: #export analyse-unit
(Meta Analysis)
(do meta;Monad
- [expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected Unit))]
+ [_ (&;infer Unit)]
(wrap (` []))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
index 778e57b94..fff5de504 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control [monad #+ do])
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
(concurrency [atom #+ Atom])
(data [text]
text/format
@@ -18,6 +19,8 @@
[";A" case]
[";A" type]))))
+(exception: #export Incorrect-Procedure-Arity)
+
## [Utils]
(type: #export Proc
(-> &;Analyser &;Eval (List Code) (Meta la;Analysis)))
@@ -39,27 +42,25 @@
(def: #export (wrong-arity proc expected actual)
(-> Text Nat Nat Text)
- (format "Wrong arity for " (%t proc) "\n"
- "Expected: " (|> expected nat-to-int %i) "\n"
- " Actual: " (|> actual nat-to-int %i)))
+ (format " Procedure: " (%t proc) "\n"
+ " Expected Arity: " (|> expected nat-to-int %i) "\n"
+ " Actual Arity: " (|> actual nat-to-int %i)))
-(def: (simple proc input-types output-type)
+(def: (simple proc inputsT+ outputT)
(-> Text (List Type) Type Proc)
- (let [num-expected (list;size input-types)]
+ (let [num-expected (list;size inputsT+)]
(function [analyse eval args]
(let [num-actual (list;size args)]
(if (n.= num-expected num-actual)
(do meta;Monad
- [argsA (monad;map @
+ [_ (&;infer outputT)
+ argsA (monad;map @
(function [[argT argC]]
(&;with-expected-type argT
(analyse argC)))
- (list;zip2 input-types args))
- expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected output-type))]
+ (list;zip2 inputsT+ args))]
(wrap (la;procedure proc argsA)))
- (&;fail (wrong-arity proc num-expected num-actual)))))))
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual)))))))
(def: #export (nullary valueT proc)
(-> Type Text Proc)
@@ -82,71 +83,60 @@
(def: (lux-is proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((binary varT varT Bool proc)
- analyse eval args)))))
+ (do meta;Monad
+ [[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 Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list opC))
- (do meta;Monad
- [opA (&;with-expected-type (type (io;IO varT))
- (analyse opC))
- outputT (&;with-type-env
- (tc;clean var-id (type (Either Text varT))))
- expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected outputT))]
- (wrap (la;procedure proc (list opA))))
-
- _
- (&;fail (wrong-arity proc +1 (list;size args))))))))
+ (case args
+ (^ (list opC))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)
+ _ (&;infer (type (Either Text varT)))
+ opA (&;with-expected-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 Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list [_ (#;Symbol ["" func-name])]
- [_ (#;Symbol ["" arg-name])]
- body))
- (functionA;analyse-function analyse func-name arg-name body)
-
- _
- (&;fail (wrong-arity proc +3 (list;size 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 Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list input [_ (#;Record branches)]))
- (caseA;analyse-case analyse input branches)
-
- _
- (&;fail (wrong-arity proc +2 (list;size args))))))))
+ (case args
+ (^ (list input [_ (#;Record branches)]))
+ (caseA;analyse-case analyse input branches)
+
+ _
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args))))))
(do-template [ ]
[(def: ( proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list typeC valueC))
- ( analyse eval typeC valueC)
-
- _
- (&;fail (wrong-arity proc +2 (list;size args))))))))]
+ (case args
+ (^ (list typeC valueC))
+ ( 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])
@@ -193,15 +183,13 @@
(case args
(^ (list valueC))
(do meta;Monad
- [valueA (&;with-expected-type Type
- (analyse valueC))
- expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected Type))]
+ [_ (&;infer (type Type))
+ valueA (&;with-expected-type Type
+ (analyse valueC))]
(wrap valueA))
_
- (&;fail (wrong-arity proc +1 (list;size args))))))
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args))))))
(def: lux-procs
Bundle
@@ -326,26 +314,26 @@
(def: (array-get proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((binary Nat (type (Array varT)) varT proc)
- analyse eval args)))))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((binary Nat (type (Array varT)) varT proc)
+ analyse eval args))))
(def: (array-put proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
- analyse eval args)))))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
+ analyse eval args))))
(def: (array-remove proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((binary Nat (type (Array varT)) (type (Array varT)) proc)
- analyse eval args)))))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((binary Nat (type (Array varT)) (type (Array varT)) proc)
+ analyse eval args))))
(def: array-procs
Bundle
@@ -385,38 +373,33 @@
(def: (atom-new proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list initC))
- (do meta;Monad
- [initA (&;with-expected-type varT
- (analyse initC))
- outputT (&;with-type-env
- (tc;clean var-id (type (Atom varT))))
- expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected outputT))]
- (wrap (la;procedure proc (list initA))))
-
- _
- (&;fail (wrong-arity proc +1 (list;size args))))))))
+ (case args
+ (^ (list initC))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)
+ _ (&;infer (type (Atom varT)))
+ initA (&;with-expected-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 Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((unary (type (Atom varT)) varT proc)
- analyse eval args)))))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((unary (type (Atom varT)) varT proc)
+ analyse eval args))))
(def: (atom-compare-and-swap proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((trinary varT varT (type (Atom varT)) Bool proc)
- analyse eval args)))))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((trinary varT varT (type (Atom varT)) Bool proc)
+ analyse eval args))))
(def: atom-procs
Bundle
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
index 3ba7713ac..fa10a7a1c 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
@@ -28,6 +28,49 @@
["@" ../common]
)
+(exception: #export Wrong-Syntax)
+(def: (wrong-syntax procedure args)
+ (-> Text (List Code) Text)
+ (format "Procedure: " procedure "\n"
+ "Arguments: " (%code (code;tuple args))))
+
+(exception: #export JVM-Type-Is-Not-Class)
+
+(exception: #export Non-Interface)
+(exception: #export Non-Object)
+(exception: #export Non-Array)
+(exception: #export Non-Throwable)
+(exception: #export Non-JVM-Type)
+
+(exception: #export Unknown-Class)
+(exception: #export Primitives-Cannot-Have-Type-Parameters)
+(exception: #export Primitives-Are-Not-Objects)
+(exception: #export Invalid-Type-For-Array-Element)
+
+(exception: #export Unknown-Field)
+(exception: #export Mistaken-Field-Owner)
+(exception: #export Not-Virtual-Field)
+(exception: #export Not-Static-Field)
+(exception: #export Cannot-Set-Final-Field)
+
+(exception: #export No-Candidates)
+(exception: #export Too-Many-Candidates)
+
+(exception: #export Cannot-Cast)
+(def: (cannot-cast to from)
+ (-> Type Type Text)
+ (format "From: " (%type from) "\n"
+ " To: " (%type to)))
+
+(exception: #export Cannot-Possibly-Be-Instance)
+
+(exception: #export Cannot-Convert-To-Class)
+(exception: #export Cannot-Convert-To-Parameter)
+(exception: #export Cannot-Convert-To-Lux-Type)
+(exception: #export Unknown-Type-Var)
+(exception: #export Type-Parameter-Mismatch)
+(exception: #export Cannot-Correspond-Type-With-Class)
+
(def: #export null-class Text "#Null")
(do-template [ ]
@@ -149,22 +192,17 @@
(def: (array-length proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list arrayC))
- (do meta;Monad
- [arrayA (&;with-expected-type (type (Array varT))
- (analyse arrayC))
- _ (&;infer Nat)]
- (wrap (la;procedure proc (list arrayA))))
-
- _
- (&;fail (@;wrong-arity proc +1 (list;size args))))))))
-
-(def: (invalid-array-type arrayT)
- (-> Type Text)
- (format "Invalid type for array: " (%type arrayT)))
+ (case args
+ (^ (list arrayC))
+ (do meta;Monad
+ [_ (&;infer Nat)
+ [var-id varT] (&;with-type-env tc;var)
+ arrayA (&;with-expected-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 @;Proc)
@@ -185,7 +223,7 @@
(recur outputT level)
#;None
- (&;fail (invalid-array-type expectedT)))
+ (&;throw Non-Array (%type expectedT)))
(^ (#;Primitive "#Array" (list elemT)))
(recur elemT (n.inc level))
@@ -194,15 +232,14 @@
(wrap [level class])
_
- (&;fail (invalid-array-type expectedT)))))
- _ (&;assert "Must have at least 1 level of nesting in array type."
- (n.> +0 level))]
+ (&;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))))
_
- (&;fail (@;wrong-arity proc +1 (list;size args))))))
-
-(exception: #export Not-Object-Type)
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
(def: (check-jvm objectT)
(-> Type (Meta Text))
@@ -228,81 +265,77 @@
(check-jvm outputT)
#;None
- (&;throw Not-Object-Type (%type objectT)))
+ (&;throw Non-Object (%type objectT)))
_
- (&;throw Not-Object-Type (%type objectT))))
+ (&;throw Non-Object (%type objectT))))
(def: (check-object objectT)
(-> Type (Meta Text))
(do meta;Monad
[name (check-jvm objectT)]
(if (dict;contains? name boxes)
- (&;fail (format "Primitives are not objects: " name))
- (:: meta;Monad wrap name))))
+ (&;throw Primitives-Are-Not-Objects name)
+ (meta/wrap name))))
(def: (box-array-element-type elemT)
(-> Type (Meta [Type Text]))
- (do meta;Monad
- []
- (case elemT
- (#;Primitive name #;Nil)
- (let [boxed-name (|> (dict;get name boxes)
- (maybe;default name))]
- (wrap [(#;Primitive boxed-name #;Nil)
- boxed-name]))
-
- (#;Primitive name _)
- (if (dict;contains? name boxes)
- (&;fail (format "Primitives cannot be parameterized: " name))
- (:: meta;Monad wrap [elemT name]))
+ (case elemT
+ (#;Primitive name #;Nil)
+ (let [boxed-name (|> (dict;get name boxes)
+ (maybe;default name))]
+ (meta/wrap [(#;Primitive boxed-name #;Nil)
+ boxed-name]))
- _
- (&;fail (format "Invalid type for array element: " (%type elemT))))))
+ (#;Primitive name _)
+ (if (dict;contains? name boxes)
+ (&;throw Primitives-Cannot-Have-Type-Parameters name)
+ (meta/wrap [elemT name]))
+
+ _
+ (&;throw Invalid-Type-For-Array-Element (%type elemT))))
(def: (array-read proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list arrayC idxC))
- (do meta;Monad
- [arrayA (&;with-expected-type (type (Array varT))
- (analyse arrayC))
- elemT (&;with-type-env
- (tc;read var-id))
- [elemT elem-class] (box-array-element-type elemT)
- idxA (&;with-expected-type Nat
- (analyse idxC))
- _ (&;infer elemT)]
- (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA))))
-
- _
- (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+ (case args
+ (^ (list arrayC idxC))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)
+ _ (&;infer varT)
+ arrayA (&;with-expected-type (type (Array varT))
+ (analyse arrayC))
+ elemT (&;with-type-env
+ (tc;read var-id))
+ [elemT elem-class] (box-array-element-type elemT)
+ idxA (&;with-expected-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 @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list arrayC idxC valueC))
- (do meta;Monad
- [arrayA (&;with-expected-type (type (Array varT))
- (analyse arrayC))
- elemT (&;with-type-env
- (tc;read var-id))
- [valueT elem-class] (box-array-element-type elemT)
- idxA (&;with-expected-type Nat
- (analyse idxC))
- valueA (&;with-expected-type valueT
- (analyse valueC))
- _ (&;infer (type (Array elemT)))]
- (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA))))
-
- _
- (&;fail (@;wrong-arity proc +3 (list;size args))))))))
+ (case args
+ (^ (list arrayC idxC valueC))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)
+ _ (&;infer (type (Array varT)))
+ arrayA (&;with-expected-type (type (Array varT))
+ (analyse arrayC))
+ elemT (&;with-type-env
+ (tc;read var-id))
+ [valueT elem-class] (box-array-element-type elemT)
+ idxA (&;with-expected-type Nat
+ (analyse idxC))
+ valueA (&;with-expected-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
@@ -325,45 +358,43 @@
(wrap (la;procedure proc (list))))
_
- (&;fail (@;wrong-arity proc +0 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +0 (list;size args))))))
(def: (object-null? proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list objectC))
- (do meta;Monad
- [objectA (&;with-expected-type varT
- (analyse objectC))
- objectT (&;with-type-env
- (tc;read var-id))
- _ (check-object objectT)
- _ (&;infer Bool)]
- (wrap (la;procedure proc (list objectA))))
-
- _
- (&;fail (@;wrong-arity proc +1 (list;size args))))))))
+ (case args
+ (^ (list objectC))
+ (do meta;Monad
+ [_ (&;infer Bool)
+ [var-id varT] (&;with-type-env tc;var)
+ objectA (&;with-expected-type varT
+ (analyse objectC))
+ objectT (&;with-type-env
+ (tc;read var-id))
+ _ (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 @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list monitorC exprC))
- (do meta;Monad
- [monitorA (&;with-expected-type varT
- (analyse monitorC))
- monitorT (&;with-type-env
- (tc;read var-id))
- _ (check-object monitorT)
- exprA (analyse exprC)]
- (wrap (la;procedure proc (list monitorA exprA))))
-
- _
- (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+ (case args
+ (^ (list monitorC exprC))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)
+ monitorA (&;with-expected-type varT
+ (analyse monitorC))
+ monitorT (&;with-type-env
+ (tc;read var-id))
+ _ (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))
@@ -436,7 +467,7 @@
(wrap class)
(#e;Error error)
- (&;fail (format "Unknown class: " name)))))
+ (&;throw Unknown-Class name))))
(def: (sub-class? super sub)
(-> Text Text (Meta Bool))
@@ -445,31 +476,28 @@
sub (load-class sub)]
(wrap (Class.isAssignableFrom [sub] super))))
-(exception: #export Not-Throwable)
-
(def: (object-throw proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list exceptionC))
- (do meta;Monad
- [exceptionA (&;with-expected-type varT
- (analyse exceptionC))
- exceptionT (&;with-type-env
- (tc;read var-id))
- exception-class (check-object exceptionT)
- ? (sub-class? "java.lang.Throwable" exception-class)
- _ (: (Meta Unit)
- (if ?
- (wrap [])
- (&;throw Not-Throwable exception-class)))
- _ (&;infer Bottom)]
- (wrap (la;procedure proc (list exceptionA))))
-
- _
- (&;fail (@;wrong-arity proc +1 (list;size args))))))))
+ (case args
+ (^ (list exceptionC))
+ (do meta;Monad
+ [_ (&;infer Bottom)
+ [var-id varT] (&;with-type-env tc;var)
+ exceptionA (&;with-expected-type varT
+ (analyse exceptionC))
+ exceptionT (&;with-type-env
+ (tc;read var-id))
+ exception-class (check-object exceptionT)
+ ? (sub-class? "java.lang.Throwable" exception-class)
+ _ (: (Meta Unit)
+ (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 @;Proc)
@@ -479,45 +507,38 @@
(case classC
[_ (#;Text class)]
(do meta;Monad
- [_ (load-class class)
- _ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))]
+ [_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))
+ _ (load-class class)]
(wrap (la;procedure proc (list (code;text class)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +1 (list;size args))))))
-
-(exception: #export Cannot-Be-Instance)
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
(def: (object-instance? proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list classC objectC))
- (case classC
- [_ (#;Text class)]
- (do meta;Monad
- [objectA (&;with-expected-type varT
- (analyse objectC))
- objectT (&;with-type-env
- (tc;read var-id))
- object-class (check-object objectT)
- ? (sub-class? class object-class)]
- (if ?
- (do @
- [_ (&;infer Bool)]
- (wrap (la;procedure proc (list (code;text class)))))
- (&;throw Cannot-Be-Instance (format object-class " !<= " class))))
+ (case args
+ (^ (list classC objectC))
+ (case classC
+ [_ (#;Text class)]
+ (do meta;Monad
+ [_ (&;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))))
- _
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ _
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
- _
- (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+ _
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
(def: object-procs
@;Bundle
@@ -531,14 +552,6 @@
(@;install "instance?" object-instance?)
)))
-(exception: #export Final-Field)
-
-(exception: #export Cannot-Convert-To-Class)
-(exception: #export Cannot-Convert-To-Parameter)
-(exception: #export Cannot-Convert-To-Lux-Type)
-(exception: #export Cannot-Cast-To-Primitive)
-(exception: #export JVM-Type-Is-Not-Class)
-
(def: type-descriptor
(-> java.lang.reflect.Type Text)
(java.lang.reflect.Type.getTypeName []))
@@ -554,8 +567,6 @@
## else
(&;throw Cannot-Convert-To-Class (type-descriptor type))))
-(exception: #export Unknown-Type-Var)
-
(type: Mappings
(Dict Text Type))
@@ -634,18 +645,29 @@
(case type
(#;Primitive name params)
(let [class-name (Class.getName [] class)
- class-params (array;to-list (Class.getTypeParameters [] class))]
- (if (text/= class-name name)
- (if (n.= (list;size class-params)
- (list;size params))
- (meta/wrap (|> params
- (list;zip2 (list/map (TypeVariable.getName []) class-params))
- (dict;from-list text;Hash)))
- (&;fail (format "Class and host-type parameters do not match: " "class = " class-name " | host type = " name)))
- (&;fail (format "Class and host-type names do not match: " "class = " class-name " | host type = " name))))
+ 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
+ (meta/wrap (|> params
+ (list;zip2 (list/map (TypeVariable.getName []) class-params))
+ (dict;from-list text;Hash)))
+ ))
_
- (&;fail (format "Not a host type: " (%type type)))))
+ (&;throw Non-JVM-Type (%type type))))
(def: (cast direction to from)
(-> Direction Type Type (Meta [Text Type]))
@@ -656,7 +678,7 @@
(let [box (maybe;assume (dict;get to-name boxes))]
(if (text/= box from-name)
(wrap [(choose direction to-name from-name) (#;Primitive to-name (list))])
- (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name))))
+ (&;throw Cannot-Cast (cannot-cast to from))))
(dict;contains? from-name boxes)
(let [box (maybe;assume (dict;get from-name boxes))]
@@ -674,7 +696,7 @@
(do @
[to-class (load-class to-name)
from-class (load-class from-name)
- _ (&;assert (format "Class '" from-name "' is not a sub-class of class '" to-name "'.")
+ _ (&;assert Cannot-Cast (cannot-cast to from)
(Class.isAssignableFrom [from-class] to-class))
candiate-parents (monad;map @
(function [java-type]
@@ -695,7 +717,7 @@
(wrap [(choose direction to-name from-name) castT]))
#;Nil
- (&;fail (format "No valid path between " (%type from) "and " (%type to) ".")))))))
+ (&;throw Cannot-Cast (cannot-cast to from)))))))
(def: (infer-out outputT)
(-> Type (Meta [Text Type]))
@@ -715,11 +737,13 @@
(let [owner (Field.getDeclaringClass [] field)]
(if (is owner class)
(wrap [class field])
- (&;fail (format "Field '" field-name "' does not belong to class '" class-name "'.\n"
- "Belongs to '" (Class.getName [] owner) "'."))))
+ (&;throw Mistaken-Field-Owner
+ (format " Field: " field-name "\n"
+ " Owner Class: " (Class.getName [] owner) "\n"
+ "Target Class: " class-name "\n"))))
(#e;Error _)
- (&;fail (format "Unknown field '" field-name "' for class '" class-name "'.")))))
+ (&;throw Unknown-Field (format class-name "#" field-name)))))
(def: (static-field class-name field-name)
(-> Text Text (Meta [Type Bool]))
@@ -731,9 +755,7 @@
(do @
[fieldT (java-type-to-lux-type fresh-mappings fieldJT)]
(wrap [fieldT (Modifier.isFinal [modifiers])])))
- (&;fail (format "Field '" field-name "' of class '" class-name "' is not static.")))))
-
-(exception: #export Non-Object-Type)
+ (&;throw Not-Static-Field (format class-name "#" field-name)))))
(def: (virtual-field class-name field-name objectT)
(-> Text Text Type (Meta [Type Bool]))
@@ -753,44 +775,48 @@
(do @
[#let [num-params (list;size _class-params)
num-vars (list;size var-names)]
- _ (&;assert (format "Number of paremeters in type does not match expected amount (" (%n num-vars) "): " (%type objectT))
+ _ (&;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))))
_
- (&;throw Non-Object-Type (%type objectT))))
+ (&;throw Non-Object (%type objectT))))
fieldT (java-type-to-lux-type mappings fieldJT)]
(wrap [fieldT (Modifier.isFinal [modifiers])]))
- (&;fail (format "Field '" field-name "' of class '" class-name "' is static.")))))
+ (&;throw Not-Virtual-Field (format class-name "#" field-name)))))
(def: (analyse-object class analyse sourceC)
(-> Text &;Analyser Code (Meta [Type la;Analysis]))
- (<| &common;with-var (function [[var-id varT]])
- (do meta;Monad
- [target-class (load-class class)
- targetT (java-type-to-lux-type fresh-mappings
- (:! java.lang.reflect.Type
- target-class))
- sourceA (&;with-expected-type varT
- (analyse sourceC))
- sourceT (&;with-type-env
- (tc;read var-id))
- [unboxed castT] (cast #Out targetT sourceT)
- _ (&;assert (format "Object cannot be a primitive: " unboxed)
- (not (dict;contains? unboxed boxes)))]
- (wrap [castT sourceA]))))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)
+ target-class (load-class class)
+ targetT (java-type-to-lux-type fresh-mappings
+ (:! java.lang.reflect.Type
+ target-class))
+ sourceA (&;with-expected-type varT
+ (analyse sourceC))
+ sourceT (&;with-type-env
+ (tc;read var-id))
+ [unboxed castT] (cast #Out targetT sourceT)
+ _ (&;assert Cannot-Cast (cannot-cast targetT sourceT)
+ (not (dict;contains? unboxed boxes)))]
+ (wrap [castT sourceA])))
(def: (analyse-input analyse targetT sourceC)
(-> &;Analyser Type Code (Meta [Type Text la;Analysis]))
- (<| &common;with-var (function [[var-id varT]])
- (do meta;Monad
- [sourceA (&;with-expected-type varT
- (analyse sourceC))
- sourceT (&;with-type-env
- (tc;read var-id))
- [unboxed castT] (cast #In targetT sourceT)]
- (wrap [castT unboxed sourceA]))))
+ (do meta;Monad
+ [[var-id varT] (&;with-type-env tc;var)
+ sourceA (&;with-expected-type varT
+ (analyse sourceC))
+ sourceT (&;with-type-env
+ (tc;read var-id))
+ [unboxed castT] (cast #In targetT sourceT)]
+ (wrap [castT unboxed sourceA])))
(def: (static-get proc)
(-> Text @;Proc)
@@ -806,10 +832,10 @@
(code;text unboxed)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +2 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
(def: (static-put proc)
(-> Text @;Proc)
@@ -819,21 +845,21 @@
(case [classC fieldC]
[[_ (#;Text class)] [_ (#;Text field)]]
(do meta;Monad
- [[fieldT final?] (static-field class field)
- _ (&;assert (Final-Field (format class "#" field))
+ [_ (&;infer Unit)
+ [fieldT final?] (static-field class field)
+ _ (&;assert Cannot-Set-Final-Field (format class "#" field)
(not final?))
[valueT unboxed valueA] (analyse-input analyse fieldT valueC)
_ (&;with-type-env
- (tc;check fieldT valueT))
- _ (&;infer Unit)]
+ (tc;check fieldT valueT))]
(wrap (la;procedure proc (list (code;text class) (code;text field)
(code;text unboxed) valueA))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +3 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args))))))
(def: (virtual-get proc)
(-> Text @;Proc)
@@ -850,10 +876,10 @@
(code;text unboxed) objectA))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +3 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args))))))
(def: (virtual-put proc)
(-> Text @;Proc)
@@ -864,20 +890,18 @@
[[_ (#;Text class)] [_ (#;Text field)]]
(do meta;Monad
[[objectT objectA] (analyse-object class analyse objectC)
+ _ (&;infer objectT)
[fieldT final?] (virtual-field class field objectT)
- _ (&;assert (Final-Field (format class "#" field))
+ _ (&;assert Cannot-Set-Final-Field (format class "#" field)
(not final?))
- [valueT unboxed valueA] (analyse-input analyse fieldT valueC)
- _ (&;with-type-env
- (tc;check fieldT valueT))
- _ (&;infer objectT)]
+ [valueT unboxed valueA] (analyse-input analyse fieldT valueC)]
(wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +4 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +4 (list;size args))))))
(def: (java-type-to-parameter type)
(-> java.lang.reflect.Type (Meta Text))
@@ -1007,9 +1031,6 @@
outputT)]]
(wrap [methodT exceptionsT]))))
-(exception: #export No-Candidate-Method)
-(exception: #export Too-Many-Candidate-Methods)
-
(def: (methods class-name method-name method-type arg-classes)
(-> Text Text Method-Type (List Text) (Meta [Type (List Type)]))
(do meta;Monad
@@ -1023,13 +1044,13 @@
(wrap [passes? method])))))]
(case (list;filter product;left candidates)
#;Nil
- (&;throw No-Candidate-Method (format class-name "#" method-name))
+ (&;throw No-Candidates (format class-name "#" method-name))
(#;Cons candidate #;Nil)
(|> candidate product;right (method-to-type method-type))
_
- (&;throw Too-Many-Candidate-Methods (format class-name "#" method-name)))))
+ (&;throw Too-Many-Candidates (format class-name "#" method-name)))))
(def: (constructor-to-type constructor)
(-> (Constructor Object) (Meta [Type (List Type)]))
@@ -1066,9 +1087,6 @@
objectT)]]
(wrap [constructorT exceptionsT]))))
-(exception: #export No-Candidate-Constructor)
-(exception: #export Too-Many-Candidate-Constructors)
-
(def: (constructor-methods class-name arg-classes)
(-> Text (List Text) (Meta [Type (List Type)]))
(do meta;Monad
@@ -1082,13 +1100,13 @@
(wrap [passes? constructor])))))]
(case (list;filter product;left candidates)
#;Nil
- (&;throw No-Candidate-Constructor (format class-name "(" (text;join-with ", " arg-classes) ")"))
+ (&;throw No-Candidates (format class-name "(" (text;join-with ", " arg-classes) ")"))
(#;Cons candidate #;Nil)
(|> candidate product;right constructor-to-type)
_
- (&;throw Too-Many-Candidate-Constructors class-name))))
+ (&;throw Too-Many-Candidates class-name))))
(def: (decorate-inputs typesT inputsA)
(-> (List Text) (List la;Analysis) (List la;Analysis))
@@ -1122,7 +1140,7 @@
(code;text unboxed) (decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//virtual proc)
(-> Text @;Proc)
@@ -1145,7 +1163,7 @@
(code;text unboxed) objectA (decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//special proc)
(-> Text @;Proc)
@@ -1162,9 +1180,7 @@
(code;text unboxed) (decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
-
-(exception: #export Not-Interface)
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//interface proc)
(-> Text @;Proc)
@@ -1175,7 +1191,7 @@
(do meta;Monad
[#let [argsT (list/map product;left argsTC)]
class (load-class class-name)
- _ (&;assert (Not-Interface class-name)
+ _ (&;assert Non-Interface class-name
(Modifier.isInterface [(Class.getModifiers [] class)]))
[methodT exceptionsT] (methods class-name method #Interface argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
@@ -1185,7 +1201,7 @@
(decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//constructor proc)
(-> Text @;Proc)
@@ -1201,7 +1217,7 @@
(wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: member-procs
@;Bundle
diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux
index 5bc1f96c9..ef02919f4 100644
--- a/new-luxc/source/luxc/lang/analysis/reference.lux
+++ b/new-luxc/source/luxc/lang/analysis/reference.lux
@@ -14,9 +14,7 @@
(-> Ident (Meta Analysis))
(do meta;Monad
[actualT (meta;find-def-type def-name)
- expectedT meta;expected-type
- _ (&;with-type-env
- (tc;check expectedT actualT))]
+ _ (&;infer actualT)]
(wrap (code;symbol def-name))))
(def: (analyse-variable var-name)
@@ -26,9 +24,7 @@
(case ?var
(#;Some [actualT ref])
(do @
- [expectedT meta;expected-type
- _ (&;with-type-env
- (tc;check expectedT actualT))]
+ [_ (&;infer actualT)]
(wrap (#;Some (` ((~ (code;int (variableL;from-ref ref))))))))
#;None
@@ -41,8 +37,8 @@
(do meta;Monad
[?var (analyse-variable simple-name)]
(case ?var
- (#;Some analysis)
- (wrap analysis)
+ (#;Some varA)
+ (wrap varA)
#;None
(do @
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index 9308fcfef..b7047e105 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -26,14 +26,13 @@
(exception: #export Not-Variant-Type)
(exception: #export Not-Tuple-Type)
-(exception: #export Cannot-Infer-Numeric-Tag)
-
-(type: Type-Error
- (-> Type Text))
+(exception: #export Not-Quantified-Type)
-(def: (not-quantified type)
- Type-Error
- (format "Not a quantified type: " (%type type)))
+(exception: #export Cannot-Infer-Numeric-Tag)
+(exception: #export Record-Keys-Must-Be-Tags)
+(exception: #export Cannot-Repeat-Tag)
+(exception: #export Tag-Does-Not-Belong-To-Record)
+(exception: #export Record-Size-Mismatch)
(def: #export (analyse-sum analyse tag valueC)
(-> &;Analyser Nat Code (Meta la;Analysis))
@@ -79,23 +78,19 @@
"Value: " (%code valueC) "\n"
" Type: " (%type expectedT)))))
- (#;UnivQ _)
- (do @
- [[var-id var] (&;with-type-env
- tc;existential)]
- (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
- (analyse-sum analyse tag valueC)))
-
- (#;ExQ _)
- (&common;with-var
- (function [[var-id var]]
- (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
+ (^template [ ]
+ ( _)
+ (do @
+ [[instance-id instanceT] (&;with-type-env )]
+ (&;with-expected-type (maybe;assume (type;apply (list instanceT) expectedT))
(analyse-sum analyse tag valueC))))
+ ([#;UnivQ tc;existential]
+ [#;ExQ tc;var])
(#;Apply inputT funT)
(case (type;apply (list inputT) funT)
#;None
- (&;fail (not-quantified funT))
+ (&;throw Not-Quantified-Type (%type funT))
(#;Some outputT)
(&;with-expected-type outputT
@@ -188,23 +183,19 @@
(type;tuple (list/map product;left membersTA))))]
(wrap (la;product (list/map product;right membersTA))))))
- (#;UnivQ _)
- (do @
- [[var-id var] (&;with-type-env
- tc;existential)]
- (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
- (analyse-product analyse membersC)))
-
- (#;ExQ _)
- (&common;with-var
- (function [[var-id var]]
- (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
+ (^template [ ]
+ ( _)
+ (do @
+ [[instance-id instanceT] (&;with-type-env )]
+ (&;with-expected-type (maybe;assume (type;apply (list instanceT) expectedT))
(analyse-product analyse membersC))))
+ ([#;UnivQ tc;existential]
+ [#;ExQ tc;var])
(#;Apply inputT funT)
(case (type;apply (list inputT) funT)
#;None
- (&;fail (not-quantified funT))
+ (&;throw Not-Quantified-Type (%type funT))
(#;Some outputT)
(&;with-expected-type outputT
@@ -248,7 +239,8 @@
(wrap [key val]))
_
- (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key)))))
+ (&;throw Record-Keys-Must-Be-Tags (format " Key: " (%code key) "\n"
+ "Record: " (%code (code;record record))))))
record))
## Lux already possesses the means to analyse tuples, so
@@ -269,10 +261,10 @@
size-ts (list;size tag-set)]
_ (if (n.= size-ts size-record)
(wrap [])
- (&;fail (format "Record size does not match tag-set size." "\n"
- "Expected: " (|> size-ts nat-to-int %i) "\n"
- " Actual: " (|> size-record nat-to-int %i) "\n"
- "For type: " (%type recordT))))
+ (&;throw Record-Size-Mismatch
+ (format "Expected: " (|> size-ts nat-to-int %i) "\n"
+ " Actual: " (|> size-record nat-to-int %i) "\n"
+ " Type: " (%type recordT))))
#let [tuple-range (list;n.range +0 (n.dec size-ts))
tag->idx (dict;from-list ident;Hash (list;zip2 tag-set tuple-range))]
idx->val (monad;fold @
@@ -281,12 +273,17 @@
[key (meta;normalize key)]
(case (dict;get key tag->idx)
#;None
- (&;fail (format "Tag " (%code (code;tag key))
- " does not belong to tag-set for type " (%type recordT)))
+ (&;throw Tag-Does-Not-Belong-To-Record
+ (format " Tag: " (%code (code;tag key)) "\n"
+ "Type: " (%type recordT)))
(#;Some idx)
(if (dict;contains? idx idx->val)
- (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key))))
+ (&;throw Cannot-Repeat-Tag
+ (format " Tag: " (%code (code;tag key)) "\n"
+ "Record: " (%code (code;record (list/map (function [[keyI valC]]
+ [(code;tag keyI) valC])
+ record)))))
(wrap (dict;put idx val idx->val))))))
(: (Dict Nat Code)
(dict;new number;Hash))
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index c4ebf3642..cf3137aff 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -32,6 +32,7 @@
(&;Analyser)
(expressionA;analyser &eval;eval))
+(exception: #export Macro-Expansion-Failed)
(exception: #export Unrecognized-Statement)
(def: (translate code)
@@ -79,7 +80,7 @@
(#e;Success [compiler' output])
(#e;Error error)
- ((&;fail error) compiler)))
+ ((&;throw Macro-Expansion-Failed error) compiler)))
_ (monad;map @ translate expansion)]
(wrap []))
(&;throw Unrecognized-Statement (%code code))))
diff --git a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux
index 82b7c5d44..733f630d5 100644
--- a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux
@@ -21,7 +21,7 @@
(def: #export (translate-procedure translate name args)
(-> (-> ls;Synthesis (Meta $;Inst)) Text (List ls;Synthesis)
(Meta $;Inst))
- (<| (maybe;default (&;throw Unknown-Procedure name))
+ (<| (maybe;default (&;throw Unknown-Procedure (%t name)))
(do maybe;Monad
[proc (dict;get name procedures)]
(wrap (proc translate args)))))
diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
index 7168514c1..a5e06aac3 100644
--- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
@@ -10,7 +10,7 @@
["l" lexer])
(coll [list "list/" Functor]
[dict #+ Dict]))
- [meta #+ with-gensyms "meta/" Monad]
+ [meta "meta/" Monad]
(meta [code]
["s" syntax #+ syntax:])
[host])
@@ -25,6 +25,15 @@
["ls" synthesis]))
["@" ../common])
+(exception: #export Wrong-Syntax)
+(def: (wrong-syntax procedure args)
+ (-> Text (List ls;Synthesis) Text)
+ (format "Procedure: " procedure "\n"
+ "Arguments: " (%code (code;tuple args))))
+
+(exception: #export Invalid-Syntax-For-JVM-Type)
+(exception: #export Invalid-Syntax-For-Argument-Generation)
+
(do-template [ ]
[(def:
$;Inst
@@ -295,7 +304,7 @@
($i;array arrayJT))))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: (array//read proc translate inputs)
(-> Text @;Proc)
@@ -321,7 +330,7 @@
loadI)))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: (array//write proc translate inputs)
(-> Text @;Proc)
@@ -350,7 +359,7 @@
storeI)))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: array-procs
@;Bundle
@@ -406,7 +415,7 @@
false))))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: (object//instance? proc translate inputs)
(-> Text @;Proc)
@@ -419,7 +428,7 @@
($i;wrap #$;Boolean))))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: object-procs
@;Bundle
@@ -470,7 +479,7 @@
(wrap ($i;GETSTATIC class field ($t;class unboxed (list))))))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: (static//put proc translate inputs)
(-> Text @;Proc)
@@ -502,7 +511,7 @@
($i;string hostL;unit)))))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: (virtual//get proc translate inputs)
(-> Text @;Proc)
@@ -533,7 +542,7 @@
($i;GETFIELD class field ($t;class unboxed (list)))))))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: (virtual//put proc translate inputs)
(-> Text @;Proc)
@@ -570,9 +579,7 @@
($i;PUTFIELD class field ($t;class unboxed (list)))))))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(exception: #export Invalid-Syntax-For-Argument-Generation)
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: base-type
(l;Lexer $;Type)
@@ -601,7 +608,7 @@
(-> Text (Meta $;Type))
(case (l;run argD java-type)
(#e;Error error)
- (&;fail error)
+ (&;throw Invalid-Syntax-For-JVM-Type argD)
(#e;Success type)
(meta/wrap type)))
@@ -647,7 +654,7 @@
(meta/wrap #;None)
_
- (:: meta;Monad map (|>. #;Some) (translate-type description))))
+ (meta/map (|>. #;Some) (translate-type description))))
(def: (prepare-return returnT returnI)
(-> (Maybe $;Type) $;Inst $;Inst)
@@ -679,7 +686,7 @@
(wrap (prepare-return returnT callI)))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(do-template [ ]
[(def: ( proc translate inputs)
@@ -700,7 +707,7 @@
(wrap (prepare-return returnT callI)))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))]
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))]
[invoke//virtual $i;INVOKEVIRTUAL false]
[invoke//special $i;INVOKESPECIAL false]
@@ -721,7 +728,7 @@
false))))
_
- (&;fail (format "Wrong syntax for '" proc "'."))))
+ (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
(def: member-procs
@;Bundle
@@ -741,8 +748,7 @@
(@;install "virtual" invoke//virtual)
(@;install "special" invoke//special)
(@;install "interface" invoke//interface)
- (@;install "constructor" invoke//constructor)
- )))
+ (@;install "constructor" invoke//constructor))))
)))
(def: #export procedures
diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux
index feb64c293..2a2173fa9 100644
--- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux
@@ -21,6 +21,7 @@
[";T" common]))))
(exception: #export Invalid-Definition-Value)
+(exception: #export Cannot-Evaluate-Definition)
(host;import java.lang.Object
(toString [] String))
@@ -56,13 +57,16 @@
[field (Class.getField [commonT;value-field] class)]
(Field.get [#;None] field))
(#e;Success #;None)
- (&;throw Invalid-Definition-Value (format current-module ";" def-name))
+ (&;throw Invalid-Definition-Value (%ident [current-module def-name]))
(#e;Success (#;Some valueV))
(wrap valueV)
(#e;Error error)
- (&;fail error)))
+ (&;throw Cannot-Evaluate-Definition
+ (format "Definition: " (%ident [current-module def-name]) "\n"
+ "Error:\n"
+ error))))
_ (&module;define [current-module def-name] [valueT metaV valueV])
_ (if (meta;type? metaV)
(case (meta;declared-tags metaV)
@@ -77,6 +81,4 @@
(def: #export (translate-program program-args programI)
(-> Text $;Inst (Meta Unit))
- (do meta;Monad
- []
- (&;fail "'lux program' is unimplemented.")))
+ (&;fail "\"lux program\" is unimplemented."))
diff --git a/new-luxc/source/luxc/lang/translation/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/structure.jvm.lux
index 3ef03ac2c..68219b87c 100644
--- a/new-luxc/source/luxc/lang/translation/structure.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/structure.jvm.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control [monad #+ do])
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
(data text/format
(coll [list]))
[meta]
@@ -16,13 +17,15 @@
(translation [";T" common])))
[../runtime])
+(exception: #export Not-A-Tuple)
+
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
(def: #export (translate-tuple translate members)
(-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst))
(do meta;Monad
[#let [size (list;size members)]
- _ (&;assert "Cannot translate tuples with less than 2 elements."
+ _ (&;assert Not-A-Tuple (%code (` [(~@ members)]))
(n.>= +2 size))
membersI (|> members
list;enumerate
diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux
index 2bb7eedcd..7b60af8f2 100644
--- a/new-luxc/source/luxc/module.lux
+++ b/new-luxc/source/luxc/module.lux
@@ -1,14 +1,21 @@
(;module:
lux
- (lux (control [monad #+ do])
- (data [text "T/" Eq]
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data [text "text/" Eq]
text/format
["e" error]
- (coll [list "L/" Fold Functor]))
- [meta #+ Monad])
+ (coll [list "list/" Fold Functor]))
+ [meta]
+ (meta [code]))
(luxc ["&" base]
["&;" scope]))
+(exception: #export Unknown-Module)
+(exception: #export Cannot-Declare-Tag-Twice)
+(exception: #export Cannot-Declare-Tags-For-Unnamed-Type)
+(exception: #export Cannot-Declare-Tags-For-Foreign-Type)
+
(def: (new-module hash)
(-> Nat Module)
{#;module-hash hash
@@ -54,7 +61,7 @@
(def: #export (with-module hash name action)
(All [a] (-> Nat Text (Meta a) (Meta [Module a])))
- (do Monad
+ (do meta;Monad
[_ (create hash name)
output (&;with-current-module name
(&scope;with-scope name action))
@@ -107,7 +114,7 @@
(#e;Success [compiler (get@ module)])
#;None
- (meta;run compiler (&;fail (format "Unknown module: " module-name))))
+ (meta;run compiler (&;throw Unknown-Module module-name)))
))]
[tags-by-module #;tags (List [Text [Nat (List Ident) Bool Type]])]
@@ -117,7 +124,7 @@
(def: (ensure-undeclared-tags module-name tags)
(-> Text (List Text) (Meta Unit))
- (do Monad
+ (do meta;Monad
[bindings (tags-by-module module-name)
_ (monad;map @
(function [tag]
@@ -126,36 +133,41 @@
(wrap [])
(#;Some _)
- (&;fail (format "Cannot re-declare tag: " tag))))
+ (&;throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n"
+ " Tag: " tag))))
tags)]
(wrap [])))
(def: #export (declare-tags tags exported? type)
(-> (List Text) Bool Type (Meta Unit))
- (do Monad
+ (do meta;Monad
[current-module meta;current-module-name
[type-module type-name] (case type
(#;Named type-ident _)
(wrap type-ident)
_
- (&;fail (format "Cannot define tags for an unnamed type: " (%type type))))
+ (&;throw Cannot-Declare-Tags-For-Unnamed-Type
+ (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n"
+ "Type: " (%type type))))
_ (ensure-undeclared-tags current-module tags)
- _ (meta;assert (format "Cannot define tags for a type belonging to a foreign module: " (%type type))
- (T/= current-module type-module))]
+ _ (&;assert Cannot-Declare-Tags-For-Foreign-Type
+ (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n"
+ "Type: " (%type type))
+ (text/= current-module type-module))]
(function [compiler]
(case (|> compiler (get@ #;modules) (&;pl-get current-module))
(#;Some module)
- (let [namespaced-tags (L/map (|>. [current-module]) tags)]
+ (let [namespaced-tags (list/map (|>. [current-module]) tags)]
(#e;Success [(update@ #;modules
(&;pl-update current-module
(|>. (update@ #;tags (function [tag-bindings]
- (L/fold (function [[idx tag] table]
- (&;pl-put tag [idx namespaced-tags exported? type] table))
- tag-bindings
- (list;enumerate tags))))
+ (list/fold (function [[idx tag] table]
+ (&;pl-put tag [idx namespaced-tags exported? type] table))
+ tag-bindings
+ (list;enumerate tags))))
(update@ #;types (&;pl-put type-name [namespaced-tags exported? type]))))
compiler)
[]]))
#;None
- (meta;run compiler (&;fail (format "Unknown module: " current-module)))))))
+ (meta;run compiler (&;throw Unknown-Module current-module))))))
--
cgit v1.2.3