aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/analysis/type.lux27
-rw-r--r--new-luxc/source/luxc/lang/extension/analysis.lux19
-rw-r--r--stdlib/source/lux/lang/extension.lux (renamed from new-luxc/source/luxc/lang/extension.lux)59
-rw-r--r--stdlib/source/lux/lang/extension/analysis/common.lux (renamed from new-luxc/source/luxc/lang/extension/analysis/common.lux)146
-rw-r--r--stdlib/source/lux/lang/extension/analysis/host.jvm.lux (renamed from new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux)560
-rw-r--r--stdlib/source/lux/lang/synthesis.lux (renamed from new-luxc/source/luxc/lang/synthesis.lux)0
6 files changed, 383 insertions, 428 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/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.lux b/stdlib/source/lux/lang/extension.lux
index 254dd18ca..03fd81d71 100644
--- a/new-luxc/source/luxc/lang/extension.lux
+++ b/stdlib/source/lux/lang/extension.lux
@@ -6,34 +6,30 @@
[text]
(coll (dictionary ["dict" unordered #+ Dict])))
[macro])
- [//]
- (// ["la" analysis]
- ["ls" synthesis]))
+ [// #+ Eval]
+ (// [".L" analysis #+ Analyser]
+ [".L" synthesis]))
(do-template [<name>]
[(exception: #export (<name> {message Text})
message)]
- [Unknown-Analysis]
- [Unknown-Synthesis]
- [Unknown-Translation]
- [Unknown-Statement]
+ [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]
+ [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)))
+ (-> Analyser Eval (List Code) (Meta analysisL.Analysis)))
(type: #export Synthesis
- (-> (-> la.Analysis ls.Synthesis) (List Code) Code))
-
-(type: #export Syntheses (Dict Text Synthesis))
+ (-> (-> analysisL.Analysis synthesisL.Synthesis) (List Code) Code))
(type: #export Translation
(-> (List Code) (Meta Code)))
@@ -41,11 +37,14 @@
(type: #export Statement
(-> (List Code) (Meta Any)))
+(type: #export (Extension e)
+ (Dict Text e))
+
(type: #export Extensions
- {#analysis (Dict Text Analysis)
- #synthesis Syntheses
- #translation (Dict Text Translation)
- #statement (Dict Text Statement)})
+ {#analysis (Extension Analysis)
+ #synthesis (Extension Synthesis)
+ #translation (Extension Translation)
+ #statement (Extension Statement)})
(def: #export fresh
Extensions
@@ -78,10 +77,10 @@
#.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]
+ [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>]
@@ -94,7 +93,7 @@
(|> ..get
(:: macro.Monad<Meta> map (get@ <category>))))]
- [no-syntheses all-syntheses Syntheses #synthesis (dict.new text.Hash<Text>)]
+ [no-syntheses all-syntheses (Extension Synthesis) #synthesis (dict.new text.Hash<Text>)]
)
(do-template [<name> <type> <category> <exception>]
@@ -107,8 +106,8 @@
_ (..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]
+ [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/common.lux b/stdlib/source/lux/lang/extension/analysis/common.lux
index f22cdcdd1..8c0116721 100644
--- a/new-luxc/source/luxc/lang/extension/analysis/common.lux
+++ b/stdlib/source/lux/lang/extension/analysis/common.lux
@@ -1,7 +1,8 @@
(.module:
lux
(lux (control [monad #+ do]
- ["ex" exception #+ exception:])
+ ["ex" exception #+ exception:]
+ [thread])
(concurrency [atom #+ Atom])
(data [text]
text/format
@@ -10,23 +11,27 @@
(dictionary ["dict" unordered #+ Dict])))
[macro]
(macro [code])
- (lang (type ["tc" check]))
+ [lang]
+ (lang (type ["tc" check])
+ [".L" analysis]
+ (analysis [".A" type]
+ [".A" case]
+ [".A" function]))
[io])
- (luxc ["&" lang]
- (lang ["la" analysis]
- (analysis ["&." common]
- [".A" function]
- [".A" case]
- [".A" type])))
[///])
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
+(exception: #export (incorrect-special-arity {name Text} {arity Nat} {args Nat})
+ (ex.report ["Special" (%t name)]
+ ["Expected arity" (|> arity .int %i)]
+ ["Actual arity" (|> args .int %i)]))
- [Incorrect-Procedure-Arity]
- [Invalid-Syntax]
- )
+(exception: #export (invalid-syntax {name Text} {arguments (List Code)})
+ (ex.report ["Special" name]
+ ["Inputs" (|> arguments
+ list.enumerate
+ (list/map (function (_ [idx argC])
+ (format "\n " (%n idx) " " (%code argC))))
+ (text.join-with ""))]))
## [Utils]
(type: #export Bundle
@@ -44,12 +49,6 @@
(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+)]
@@ -57,14 +56,14 @@
(let [num-actual (list.size args)]
(if (n/= num-expected num-actual)
(do macro.Monad<Meta>
- [_ (&.infer outputT)
+ [_ (typeA.infer outputT)
argsA (monad.map @
(function (_ [argT argC])
- (&.with-type argT
+ (typeA.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)))))))
+ (wrap (#analysisL.Special proc argsA)))
+ (lang.throw incorrect-special-arity [proc num-expected num-actual]))))))
(def: #export (nullary valueT proc)
(-> Type Text ///.Analysis)
@@ -88,7 +87,7 @@
(-> Text ///.Analysis)
(function (_ analyse eval args)
(do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
+ [[var-id varT] (typeA.with-env tc.var)]
((binary varT varT Bool proc)
analyse eval args))))
@@ -100,14 +99,14 @@
(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))
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (Either Text varT)))
+ opA (typeA.with-type (type (io.IO varT))
(analyse opC))]
- (wrap (la.procedure proc (list opA))))
+ (wrap (#analysisL.Special proc (list opA))))
_
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+ (lang.throw incorrect-special-arity [proc +1 (list.size args)]))))
(def: (lux//function proc)
(-> Text ///.Analysis)
@@ -116,50 +115,50 @@
(^ (list [_ (#.Symbol ["" func-name])]
[_ (#.Symbol ["" arg-name])]
body))
- (functionA.analyse-function analyse func-name arg-name body)
+ (functionA.function analyse func-name arg-name body)
_
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args))))))
+ (lang.throw incorrect-special-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)
+ (caseA.case analyse input branches)
_
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))
+ (lang.throw incorrect-special-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
+ (lang.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>]
+ (lang.throw invalid-syntax [proc argsC+]))))
+
+(do-template [<name> <type>]
[(def: (<name> proc)
(-> Text ///.Analysis)
(function (_ analyse eval args)
(case args
(^ (list typeC valueC))
- (<analyser> analyse eval typeC valueC)
+ (do macro.Monad<Meta>
+ [actualT (eval Type typeC)
+ _ (typeA.infer (:! Type actualT))]
+ (typeA.with-type <type>
+ (analyse valueC)))
_
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))]
+ (lang.throw incorrect-special-arity [proc +2 (list.size args)]))))]
- [lux//check typeA.analyse-check]
- [lux//coerce typeA.analyse-coerce])
+ [lux//check (:! Type actualT)]
+ [lux//coerce Any]
+ )
(def: (lux//check//type proc)
(-> Text ///.Analysis)
@@ -167,13 +166,13 @@
(case args
(^ (list valueC))
(do macro.Monad<Meta>
- [_ (&.infer (type Type))
- valueA (&.with-type Type
+ [_ (typeA.infer Type)
+ valueA (typeA.with-type Type
(analyse valueC))]
(wrap valueA))
_
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+ (lang.throw incorrect-special-arity [proc +1 (list.size args)]))))
(def: lux-procs
Bundle
@@ -284,7 +283,7 @@
(-> Text ///.Analysis)
(function (_ analyse eval args)
(do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
+ [[var-id varT] (typeA.with-env tc.var)]
((binary (type (Array varT)) Nat (type (Maybe varT)) proc)
analyse eval args))))
@@ -292,7 +291,7 @@
(-> Text ///.Analysis)
(function (_ analyse eval args)
(do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
+ [[var-id varT] (typeA.with-env tc.var)]
((trinary (type (Array varT)) Nat varT (type (Array varT)) proc)
analyse eval args))))
@@ -300,7 +299,7 @@
(-> Text ///.Analysis)
(function (_ analyse eval args)
(do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
+ [[var-id varT] (typeA.with-env tc.var)]
((binary (type (Array varT)) Nat (type (Array varT)) proc)
analyse eval args))))
@@ -343,20 +342,20 @@
(case args
(^ (list initC))
(do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer (type (Atom varT)))
- initA (&.with-type varT
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (Atom varT)))
+ initA (typeA.with-type varT
(analyse initC))]
- (wrap (la.procedure proc (list initA))))
+ (wrap (#analysisL.Special proc (list initA))))
_
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+ (lang.throw incorrect-special-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)]
+ [[var-id varT] (typeA.with-env tc.var)]
((unary (type (Atom varT)) varT proc)
analyse eval args))))
@@ -364,7 +363,7 @@
(-> Text ///.Analysis)
(function (_ analyse eval args)
(do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
+ [[var-id varT] (typeA.with-env tc.var)]
((trinary (type (Atom varT)) varT varT Bool proc)
analyse eval args))))
@@ -377,40 +376,37 @@
(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
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (All [!] (thread.Box ! varT))))
+ initA (typeA.with-type varT
(analyse initC))]
- (wrap (la.procedure proc (list initA))))
+ (wrap (#analysisL.Special proc (list initA))))
_
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+ (lang.throw incorrect-special-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)
+ [[thread-id threadT] (typeA.with-env tc.var)
+ [var-id varT] (typeA.with-env tc.var)]
+ ((unary (type (thread.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)
+ [[thread-id threadT] (typeA.with-env tc.var)
+ [var-id varT] (typeA.with-env tc.var)]
+ ((binary varT (type (thread.Box threadT varT)) Any proc)
analyse eval args))))
(def: box-procs
@@ -430,7 +426,7 @@
(install "schedule" (binary Nat (type (io.IO Any)) Any))
)))
-(def: #export procedures
+(def: #export specials
Bundle
(<| (prefix "lux")
(|> (dict.new text.Hash<Text>)
diff --git a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux
index 9ef06a4b1..31b811fac 100644
--- a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
+++ b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #- char]
+ [lux #- char int]
(lux (control [monad #+ do]
["p" parser]
["ex" exception #+ exception:])
@@ -17,31 +17,47 @@
[macro "macro/" Monad<Meta>]
(macro [code]
["s" syntax])
+ [lang]
(lang [type]
- (type ["tc" check]))
+ (type ["tc" check])
+ [".L" analysis #+ Analysis]
+ (analysis [".A" type]
+ [".A" inference]))
[host])
- (luxc ["&" lang]
- (lang ["&." host]
- ["la" analysis]
- (analysis ["&." common]
- [".A" inference])))
- ["@" //common]
+ ["/" //common]
[///]
)
+(host.import #long java/lang/reflect/Type
+ (getTypeName [] String))
+
+(def: jvm-type-name
+ (-> java/lang/reflect/Type Text)
+ (java/lang/reflect/Type::getTypeName []))
+
+(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type})
+ (jvm-type-name jvm-type))
+
(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
+ [(exception: #export (<name> {type Type})
+ (%type type))]
- [Wrong-Syntax]
+ [non-object]
+ [non-array]
+ [non-jvm-type]
+ )
- [JVM-Type-Is-Not-Class]
+(do-template [<name>]
+ [(exception: #export (<name> {name Text})
+ name)]
- [Non-Interface]
- [Non-Object]
- [Non-Array]
- [Non-Throwable]
- [Non-JVM-Type]
+ [non-interface]
+ [non-throwable]
+ )
+
+(do-template [<name>]
+ [(exception: #export (<name> {message Text})
+ message)]
[Unknown-Class]
[Primitives-Cannot-Have-Type-Parameters]
@@ -69,11 +85,6 @@
[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)))]
@@ -100,52 +111,52 @@
)
(def: conversion-procs
- @.Bundle
- (<| (@.prefix "convert")
+ /.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))
+ (/.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>)
+ /.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>))
+ (/.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]
@@ -154,16 +165,16 @@
(do-template [<name> <prefix> <type>]
[(def: <name>
- @.Bundle
- (<| (@.prefix <prefix>)
+ /.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 "+" (/.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]
@@ -171,11 +182,11 @@
)
(def: char-procs
- @.Bundle
- (<| (@.prefix "char")
+ /.Bundle
+ (<| (/.prefix "char")
(|> (dict.new text.Hash<Text>)
- (@.install "=" (@.binary Character Character Boolean))
- (@.install "<" (@.binary Character Character Boolean))
+ (/.install "=" (/.binary Character Character Boolean))
+ (/.install "<" (/.binary Character Character Boolean))
)))
(def: #export boxes
@@ -190,28 +201,28 @@
["char" "java.lang.Character"])
(dict.from-list text.Hash<Text>)))
-(def: (array-length proc)
+(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))
+ [_ (typeA.infer Nat)
+ [var-id varT] (typeA.with-env tc.var)
+ arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))]
- (wrap (la.procedure proc (list arrayA))))
+ (wrap (#analysisL.Special proc (list arrayA))))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
-(def: (array-new proc)
+(def: (array//new proc)
(-> Text ///.Analysis)
(function (_ analyse eval args)
(case args
(^ (list lengthC))
(do macro.Monad<Meta>
- [lengthA (&.with-type Nat
+ [lengthA (typeA.with-type Nat
(analyse lengthC))
expectedT macro.expected-type
[level elem-class] (: (Meta [Nat Text])
@@ -224,23 +235,25 @@
(recur outputT level)
#.None
- (&.throw Non-Array (%type expectedT)))
+ (lang.throw non-array expectedT))
(^ (#.Primitive "#Array" (list elemT)))
- (recur elemT (n/inc level))
+ (recur elemT (inc level))
(#.Primitive class _)
(wrap [level class])
_
- (&.throw Non-Array (%type expectedT)))))
+ (lang.throw non-array 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))))
+ (lang.throw non-array expectedT))]
+ (wrap (#analysisL.Special proc (list (analysisL.nat (dec level))
+ (analysisL.text elem-class)
+ lengthA))))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
(def: (check-jvm objectT)
(-> Type (Meta Text))
@@ -266,17 +279,17 @@
(check-jvm outputT)
#.None
- (&.throw Non-Object (%type objectT)))
+ (lang.throw non-object objectT))
_
- (&.throw Non-Object (%type objectT))))
+ (lang.throw non-object 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)
+ (lang.throw Primitives-Are-Not-Objects name)
(macro/wrap name))))
(def: (box-array-element-type elemT)
@@ -290,62 +303,62 @@
(#.Primitive name _)
(if (dict.contains? name boxes)
- (&.throw Primitives-Cannot-Have-Type-Parameters name)
+ (lang.throw Primitives-Cannot-Have-Type-Parameters name)
(macro/wrap [elemT name]))
_
- (&.throw Invalid-Type-For-Array-Element (%type elemT))))
+ (lang.throw Invalid-Type-For-Array-Element (%type elemT))))
-(def: (array-read proc)
+(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))
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer varT)
+ arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))
- ?elemT (&.with-type-env
+ ?elemT (typeA.with-env
(tc.read var-id))
[elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
- idxA (&.with-type Nat
+ idxA (typeA.with-type Nat
(analyse idxC))]
- (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA))))
+ (wrap (#analysisL.Special proc (list (analysisL.text elem-class) idxA arrayA))))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +2 (list.size args)]))))
-(def: (array-write proc)
+(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))
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (Array varT)))
+ arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))
- ?elemT (&.with-type-env
+ ?elemT (typeA.with-env
(tc.read var-id))
[valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
- idxA (&.with-type Nat
+ idxA (typeA.with-type Nat
(analyse idxC))
- valueA (&.with-type valueT
+ valueA (typeA.with-type valueT
(analyse valueC))]
- (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA))))
+ (wrap (#analysisL.Special proc (list (analysisL.text elem-class) idxA valueA arrayA))))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +3 (list.size args)]))))
(def: array-procs
- @.Bundle
- (<| (@.prefix "array")
+ /.Bundle
+ (<| (/.prefix "array")
(|> (dict.new text.Hash<Text>)
- (@.install "length" array-length)
- (@.install "new" array-new)
- (@.install "read" array-read)
- (@.install "write" array-write)
+ (/.install "length" array//length)
+ (/.install "new" array//new)
+ (/.install "read" array//read)
+ (/.install "write" array//write)
)))
(def: (object//null proc)
@@ -356,10 +369,10 @@
(do macro.Monad<Meta>
[expectedT macro.expected-type
_ (check-object expectedT)]
- (wrap (la.procedure proc (list))))
+ (wrap (#analysisL.Special proc (list))))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +0 (list.size args)]))))
(def: (object//null? proc)
(-> Text ///.Analysis)
@@ -367,14 +380,14 @@
(case args
(^ (list objectC))
(do macro.Monad<Meta>
- [_ (&.infer Bool)
- [objectT objectA] (&common.with-unknown-type
+ [_ (typeA.infer Bool)
+ [objectT objectA] (typeA.with-inference
(analyse objectC))
_ (check-object objectT)]
- (wrap (la.procedure proc (list objectA))))
+ (wrap (#analysisL.Special proc (list objectA))))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
(def: (object//synchronized proc)
(-> Text ///.Analysis)
@@ -382,23 +395,20 @@
(case args
(^ (list monitorC exprC))
(do macro.Monad<Meta>
- [[monitorT monitorA] (&common.with-unknown-type
+ [[monitorT monitorA] (typeA.with-inference
(analyse monitorC))
_ (check-object monitorT)
exprA (analyse exprC)]
- (wrap (la.procedure proc (list monitorA exprA))))
+ (wrap (#analysisL.Special proc (list monitorA exprA))))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
+ (lang.throw /.incorrect-special-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))
@@ -444,7 +454,7 @@
(host.import (java/lang/Class c)
(getName [] String)
(getModifiers [] int)
- (#static forName [String boolean ClassLoader] #try (Class Object))
+ (#static forName [String] #try (Class Object))
(isAssignableFrom [(Class Object)] boolean)
(getTypeParameters [] (Array (TypeVariable (Class c))))
(getGenericInterfaces [] (Array java/lang/reflect/Type))
@@ -456,13 +466,13 @@
(def: (load-class name)
(-> Text (Meta (Class Object)))
(do macro.Monad<Meta>
- [class-loader &host.class-loader]
- (case (Class::forName [name false class-loader])
+ []
+ (case (Class::forName [name])
(#e.Success [class])
(wrap class)
(#e.Error error)
- (&.throw Unknown-Class name))))
+ (lang.throw Unknown-Class name))))
(def: (sub-class? super sub)
(-> Text Text (Meta Bool))
@@ -477,19 +487,19 @@
(case args
(^ (list exceptionC))
(do macro.Monad<Meta>
- [_ (&.infer Nothing)
- [exceptionT exceptionA] (&common.with-unknown-type
+ [_ (typeA.infer Nothing)
+ [exceptionT exceptionA] (typeA.with-inference
(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))))
+ (lang.throw non-throwable exception-class)))]
+ (wrap (#analysisL.Special proc (list exceptionA))))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
(def: (object//class proc)
(-> Text ///.Analysis)
@@ -499,15 +509,15 @@
(case classC
[_ (#.Text class)]
(do macro.Monad<Meta>
- [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
+ [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
_ (load-class class)]
- (wrap (la.procedure proc (list (code.text class)))))
+ (wrap (#analysisL.Special proc (list (analysisL.text class)))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
+ (lang.throw /.invalid-syntax [proc args]))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
(def: (object//instance? proc)
(-> Text ///.Analysis)
@@ -517,24 +527,20 @@
(case classC
[_ (#.Text class)]
(do macro.Monad<Meta>
- [_ (&.infer Bool)
- [objectT objectA] (&common.with-unknown-type
+ [_ (typeA.infer Bool)
+ [objectT objectA] (typeA.with-inference
(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))))
+ (wrap (#analysisL.Special proc (list (analysisL.text class))))
+ (lang.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
+ (lang.throw /.invalid-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 []))
+ (lang.throw /.incorrect-special-arity [proc +2 (list.size args)]))))
(def: (java-type-to-class type)
(-> java/lang/reflect/Type (Meta Text))
@@ -545,7 +551,7 @@
(java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type)))
## else
- (&.throw Cannot-Convert-To-Class (type-descriptor type))))
+ (lang.throw Cannot-Convert-To-Class (jvm-type-name type))))
(type: Mappings
(Dict Text Type))
@@ -561,7 +567,7 @@
(macro/wrap var-type)
#.None
- (&.throw Unknown-Type-Var var-name)))
+ (lang.throw Unknown-Type-Var var-name)))
(host.instance? WildcardType java-type)
(let [java-type (:! WildcardType java-type)]
@@ -581,9 +587,9 @@
(#.Primitive class-name (list))
arity
- (|> (list.n/range +0 (n/dec arity))
+ (|> (list.n/range +0 (dec arity))
list.reverse
- (list/map (|>> (n/* +2) n/inc #.Bound))
+ (list/map (|>> (n/* +2) inc #.Bound))
(#.Primitive class-name)
(type.univ-q arity)))))
@@ -598,7 +604,7 @@
(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))))
+ (lang.throw jvm-type-is-not-a-class raw)))
(host.instance? GenericArrayType java-type)
(do macro.Monad<Meta>
@@ -608,7 +614,7 @@
(wrap (#.Primitive "#Array" (list innerT))))
## else
- (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
+ (lang.throw Cannot-Convert-To-Lux-Type (jvm-type-name java-type))))
(def: (correspond-type-params class type)
(-> (Class Object) Type (Meta Mappings))
@@ -619,16 +625,16 @@
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)))
+ (lang.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)))
+ (lang.throw Type-Parameter-Mismatch
+ (format "Expected: " (%i (.int num-class-params)) "\n"
+ " Actual: " (%i (.int num-type-params)) "\n"
+ " Class: " class-name "\n"
+ " Type: " (%type type)))
## else
(macro/wrap (|> params
@@ -637,7 +643,7 @@
))
_
- (&.throw Non-JVM-Type (%type type))))
+ (lang.throw non-jvm-type type)))
(def: (object//cast proc)
(-> Text ///.Analysis)
@@ -647,7 +653,7 @@
(do macro.Monad<Meta>
[toT macro.expected-type
to-name (check-jvm toT)
- [valueT valueA] (&common.with-unknown-type
+ [valueT valueA] (typeA.with-inference
(analyse valueC))
from-name (check-jvm valueT)
can-cast? (: (Meta Bool)
@@ -656,7 +662,7 @@
(^or [<primitive> <object>]
[<object> <primitive>])
(do @
- [_ (&.infer (#.Primitive to-name (list)))]
+ [_ (typeA.infer (#.Primitive to-name (list)))]
(wrap true)))
(["boolean" "java.lang.Boolean"]
["byte" "java.lang.Byte"]
@@ -669,22 +675,22 @@
_
(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)))
+ [_ (lang.assert Primitives-Are-Not-Objects from-name
+ (not (dict.contains? from-name boxes)))
+ _ (lang.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)]
+ [_ (typeA.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))
+ _ (lang.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 @
@@ -703,32 +709,32 @@
(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")))
+ (lang.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"))))
+ (wrap (#analysisL.Special proc (list (analysisL.text from-name)
+ (analysisL.text to-name)
+ valueA)))
+ (lang.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)))))
+ (lang.throw /.invalid-syntax [proc args]))))
(def: object-procs
- @.Bundle
- (<| (@.prefix "object")
+ /.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)
+ (/.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)
@@ -740,13 +746,13 @@
(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"))))
+ (lang.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)))))
+ (lang.throw Unknown-Field (format class-name "#" field-name)))))
(def: (static-field class-name field-name)
(-> Text Text (Meta [Type Bool]))
@@ -758,7 +764,7 @@
(do @
[fieldT (java-type-to-lux-type fresh-mappings fieldJT)]
(wrap [fieldT (Modifier::isFinal [modifiers])])))
- (&.throw Not-Static-Field (format class-name "#" field-name)))))
+ (lang.throw Not-Static-Field (format class-name "#" field-name)))))
(def: (virtual-field class-name field-name objectT)
(-> Text Text Type (Meta [Type Bool]))
@@ -778,20 +784,20 @@
(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))]
+ _ (lang.assert Type-Parameter-Mismatch
+ (format "Expected: " (%i (.int num-params)) "\n"
+ " Actual: " (%i (.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))))
+ (lang.throw non-object objectT)))
fieldT (java-type-to-lux-type mappings fieldJT)]
(wrap [fieldT (Modifier::isFinal [modifiers])]))
- (&.throw Not-Virtual-Field (format class-name "#" field-name)))))
+ (lang.throw Not-Virtual-Field (format class-name "#" field-name)))))
(def: (static//get proc)
(-> Text ///.Analysis)
@@ -802,13 +808,13 @@
[[_ (#.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)))))
+ (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field)))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
+ (lang.throw /.invalid-syntax [proc args]))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +2 (list.size args)]))))
(def: (static//put proc)
(-> Text ///.Analysis)
@@ -818,19 +824,19 @@
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
(do macro.Monad<Meta>
- [_ (&.infer Any)
+ [_ (typeA.infer Any)
[fieldT final?] (static-field class field)
- _ (&.assert Cannot-Set-Final-Field (format class "#" field)
- (not final?))
- valueA (&.with-type fieldT
+ _ (lang.assert Cannot-Set-Final-Field (format class "#" field)
+ (not final?))
+ valueA (typeA.with-type fieldT
(analyse valueC))]
- (wrap (la.procedure proc (list (code.text class) (code.text field) valueA))))
+ (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) valueA))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
+ (lang.throw /.invalid-syntax [proc args]))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +3 (list.size args)]))))
(def: (virtual//get proc)
(-> Text ///.Analysis)
@@ -840,16 +846,16 @@
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
(do macro.Monad<Meta>
- [[objectT objectA] (&common.with-unknown-type
+ [[objectT objectA] (typeA.with-inference
(analyse objectC))
[fieldT final?] (virtual-field class field objectT)]
- (wrap (la.procedure proc (list (code.text class) (code.text field) objectA))))
+ (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) objectA))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
+ (lang.throw /.invalid-syntax [proc args]))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +3 (list.size args)]))))
(def: (virtual//put proc)
(-> Text ///.Analysis)
@@ -859,21 +865,21 @@
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
(do macro.Monad<Meta>
- [[objectT objectA] (&common.with-unknown-type
+ [[objectT objectA] (typeA.with-inference
(analyse objectC))
- _ (&.infer objectT)
+ _ (typeA.infer objectT)
[fieldT final?] (virtual-field class field objectT)
- _ (&.assert Cannot-Set-Final-Field (format class "#" field)
- (not final?))
- valueA (&.with-type fieldT
+ _ (lang.assert Cannot-Set-Final-Field (format class "#" field)
+ (not final?))
+ valueA (typeA.with-type fieldT
(analyse valueC))]
- (wrap (la.procedure proc (list (code.text class) (code.text field) valueA objectA))))
+ (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) valueA objectA))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
+ (lang.throw /.invalid-syntax [proc args]))
_
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +4 (list.size args))))))
+ (lang.throw /.incorrect-special-arity [proc +4 (list.size args)]))))
(def: (java-type-to-parameter type)
(-> java/lang/reflect/Type (Meta Text))
@@ -893,7 +899,7 @@
(wrap (format componentP "[]")))
## else
- (&.throw Cannot-Convert-To-Parameter (type-descriptor type))))
+ (lang.throw Cannot-Convert-To-Parameter (jvm-type-name type))))
(type: Method-Type
#Static
@@ -947,13 +953,13 @@
(def: idx-to-bound
(-> Nat Type)
- (|>> (n/* +2) n/inc #.Bound))
+ (|>> (n/* +2) 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.n/range offset (|> amount dec (n/+ offset)))
(list/map idx-to-bound))))
(def: (method-to-type method-type method)
@@ -1016,13 +1022,13 @@
(wrap [passes? method])))))]
(case (list.filter product.left candidates)
#.Nil
- (&.throw No-Candidates (format class-name "#" method-name))
+ (lang.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)))))
+ (lang.throw Too-Many-Candidates (format class-name "#" method-name)))))
(def: (constructor-to-type constructor)
(-> (Constructor Object) (Meta [Type (List Type)]))
@@ -1072,20 +1078,20 @@
(wrap [passes? constructor])))))]
(case (list.filter product.left candidates)
#.Nil
- (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")"))
+ (lang.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))))
+ (lang.throw Too-Many-Candidates class-name))))
(def: (decorate-inputs typesT inputsA)
- (-> (List Text) (List la.Analysis) (List la.Analysis))
+ (-> (List Text) (List Analysis) (List Analysis))
(|> inputsA
- (list.zip2 (list/map code.text typesT))
+ (list.zip2 (list/map analysisL.text typesT))
(list/map (function (_ [type value])
- (la.product (list type value))))))
+ (analysisL.product-analysis (list type value))))))
(def: (invoke//static proc)
(-> Text ///.Analysis)
@@ -1098,11 +1104,11 @@
[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)))))
+ (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method)
+ (analysisL.text outputJC) (decorate-inputs argsT argsA)))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
+ (lang.throw /.invalid-syntax [proc args]))))
(def: (invoke//virtual proc)
(-> Text ///.Analysis)
@@ -1121,11 +1127,11 @@
_
(undefined))]
outputJC (check-jvm outputT)]
- (wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text outputJC) objectA (decorate-inputs argsT argsA)))))
+ (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method)
+ (analysisL.text outputJC) objectA (decorate-inputs argsT argsA)))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
+ (lang.throw /.invalid-syntax [proc args]))))
(def: (invoke//special proc)
(-> Text ///.Analysis)
@@ -1138,11 +1144,11 @@
[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)))))
+ (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method)
+ (analysisL.text outputJC) (decorate-inputs argsT argsA)))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
+ (lang.throw /.invalid-syntax [proc args]))))
(def: (invoke//interface proc)
(-> Text ///.Analysis)
@@ -1153,17 +1159,17 @@
(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)]))
+ _ (lang.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)))))
+ (wrap (#analysisL.Special proc
+ (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC)
+ (decorate-inputs argsT argsA)))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
+ (lang.throw /.invalid-syntax [proc args]))))
(def: (invoke//constructor proc)
(-> Text ///.Analysis)
@@ -1175,36 +1181,36 @@
[#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)))))
+ (wrap (#analysisL.Special proc (list& (analysisL.text class) (decorate-inputs argsT argsA)))))
_
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
+ (lang.throw /.invalid-syntax [proc args]))))
(def: member-procs
- @.Bundle
- (<| (@.prefix "member")
+ /.Bundle
+ (<| (/.prefix "member")
(|> (dict.new text.Hash<Text>)
- (dict.merge (<| (@.prefix "static")
+ (dict.merge (<| (/.prefix "static")
(|> (dict.new text.Hash<Text>)
- (@.install "get" static//get)
- (@.install "put" static//put))))
- (dict.merge (<| (@.prefix "virtual")
+ (/.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")
+ (/.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)
+ (/.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")
+(def: #export specials
+ /.Bundle
+ (<| (/.prefix "jvm")
(|> (dict.new text.Hash<Text>)
(dict.merge conversion-procs)
(dict.merge int-procs)
diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux
index 33c8aa063..33c8aa063 100644
--- a/new-luxc/source/luxc/lang/synthesis.lux
+++ b/stdlib/source/lux/lang/synthesis.lux
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 06:13:49 +0000