aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser/procedure
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux17
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux58
2 files changed, 41 insertions, 34 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
index f64c537cb..0fad41958 100644
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ b/new-luxc/source/luxc/analyser/procedure/common.lux
@@ -7,8 +7,9 @@
(coll [list "list/" Functor<List>]
[array]
[dict #+ Dict]))
- [meta #+ Monad<Meta>]
- (meta (type ["tc" check]))
+ [meta]
+ (meta [code]
+ (type ["tc" check]))
[io])
(luxc ["&" base]
(lang ["la" analysis])
@@ -48,7 +49,7 @@
(function [analyse eval args]
(let [num-actual (list;size args)]
(if (n.= num-expected num-actual)
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[argsA (monad;map @
(function [[argT argC]]
(&;with-expected-type argT
@@ -57,7 +58,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected output-type))]
- (wrap (#la;Procedure proc argsA)))
+ (wrap (la;procedure proc argsA)))
(&;fail (wrong-arity proc num-expected num-actual)))))))
(def: #export (nullary valueT proc)
@@ -95,7 +96,7 @@
(function [[var-id varT]]
(case args
(^ (list opC))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[opA (&;with-expected-type (type (io;IO varT))
(analyse opC))
outputT (&;with-type-env
@@ -103,7 +104,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected outputT))]
- (wrap (#la;Procedure proc (list opA))))
+ (wrap (la;procedure proc (list opA))))
_
(&;fail (wrong-arity proc +1 (list;size args))))))))
@@ -352,7 +353,7 @@
(function [[var-id varT]]
(case args
(^ (list initC))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[initA (&;with-expected-type varT
(analyse initC))
outputT (&;with-type-env
@@ -360,7 +361,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected outputT))]
- (wrap (#la;Procedure proc (list initA))))
+ (wrap (la;procedure proc (list initA))))
_
(&;fail (wrong-arity proc +1 (list;size args))))))))
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index 4db7b4dda..015379a1b 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -15,7 +15,8 @@
[array]
[dict #+ Dict]))
[meta "meta/" Monad<Meta>]
- (meta ["s" syntax]
+ (meta [code]
+ ["s" syntax]
[type]
(type ["tc" check]))
[host])
@@ -156,7 +157,7 @@
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
_ (&;infer Nat)]
- (wrap (#la;Procedure proc (list arrayA))))
+ (wrap (la;procedure proc (list arrayA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -196,7 +197,7 @@
(&;fail (invalid-array-type expectedT)))))
_ (&;assert "Must have at least 1 level of nesting in array type."
(n.> +0 level))]
- (wrap (#la;Procedure proc (list (#la;Nat (n.dec level)) (#la;Text elem-class) lengthA))))
+ (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))
@@ -275,7 +276,7 @@
idxA (&;with-expected-type Nat
(analyse idxC))
_ (&;infer elemT)]
- (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA arrayA))))
+ (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA))))
_
(&;fail (@;wrong-arity proc +2 (list;size args))))))))
@@ -298,7 +299,7 @@
valueA (&;with-expected-type valueT
(analyse valueC))
_ (&;infer (type (Array elemT)))]
- (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA valueA arrayA))))
+ (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA))))
_
(&;fail (@;wrong-arity proc +3 (list;size args))))))))
@@ -321,7 +322,7 @@
(do meta;Monad<Meta>
[expectedT meta;expected-type
_ (check-object expectedT)]
- (wrap (#la;Procedure proc (list))))
+ (wrap (la;procedure proc (list))))
_
(&;fail (@;wrong-arity proc +0 (list;size args))))))
@@ -340,7 +341,7 @@
(tc;read var-id))
_ (check-object objectT)
_ (&;infer Bool)]
- (wrap (#la;Procedure proc (list objectA))))
+ (wrap (la;procedure proc (list objectA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -359,7 +360,7 @@
(tc;read var-id))
_ (check-object monitorT)
exprA (analyse exprC)]
- (wrap (#la;Procedure proc (list monitorA exprA))))
+ (wrap (la;procedure proc (list monitorA exprA))))
_
(&;fail (@;wrong-arity proc +2 (list;size args))))))))
@@ -465,7 +466,7 @@
(wrap [])
(&;throw Not-Throwable exception-class)))
_ (&;infer Bottom)]
- (wrap (#la;Procedure proc (list exceptionA))))
+ (wrap (la;procedure proc (list exceptionA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -480,7 +481,7 @@
(do meta;Monad<Meta>
[_ (load-class class)
_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))]
- (wrap (#la;Procedure proc (list (#la;Text class)))))
+ (wrap (la;procedure proc (list (code;text class)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -509,7 +510,7 @@
(if ?
(do @
[_ (&;infer Bool)]
- (wrap (#la;Procedure proc (list (#la;Text class)))))
+ (wrap (la;procedure proc (list (code;text class)))))
(&;throw Cannot-Be-Instance (format object-class " !<= " class))))
_
@@ -801,7 +802,8 @@
(do meta;Monad<Meta>
[[fieldT final?] (static-field class field)
[unboxed castT] (infer-out fieldT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed)))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -824,7 +826,8 @@
_ (&;with-type-env
(tc;check fieldT valueT))
_ (&;infer Unit)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed) valueA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -843,7 +846,8 @@
[[objectT objectA] (analyse-object class analyse objectC)
[fieldT final?] (virtual-field class field objectT)
[unboxed castT] (infer-out fieldT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed) objectA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -867,7 +871,7 @@
_ (&;with-type-env
(tc;check fieldT valueT))
_ (&;infer objectT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -1089,8 +1093,9 @@
(def: (decorate-inputs typesT inputsA)
(-> (List Text) (List la;Analysis) (List la;Analysis))
(|> inputsA
- (list;zip2 (list/map (|>. #la;Text) typesT))
- (list/map (|>. #la;Product))))
+ (list;zip2 (list/map code;text typesT))
+ (list/map (function [[type value]]
+ (la;product (list type value))))))
(def: (sub-type-analyser analyse)
(-> &;Analyser &;Analyser)
@@ -1113,8 +1118,8 @@
[methodT exceptionsT] (methods class method #Static argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1136,8 +1141,8 @@
_
(undefined))]
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) objectA (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) objectA (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1153,8 +1158,8 @@
[methodT exceptionsT] (methods class method #Special argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1175,8 +1180,9 @@
[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)))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class-name) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc
+ (list& (code;text class-name) (code;text method) (code;text unboxed)
+ (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1192,7 +1198,7 @@
[methodT exceptionsT] (constructor-methods class argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))