diff options
Diffstat (limited to 'new-luxc/source/luxc/analyser/procedure')
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/common.lux | 86 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 57 |
2 files changed, 72 insertions, 71 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux index ffb87a2ca..a0f739f3b 100644 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -6,32 +6,32 @@ text/format (coll [list "list/" Functor<List>] [array #+ Array] - ["d" dict])) + [dict #+ Dict])) [macro #+ Monad<Lux>] - (type ["TC" check]) + (type ["tc" check]) [io]) (luxc ["&" base] - (lang ["la" analysis #+ Analysis]) + (lang ["la" analysis]) (analyser ["&;" common]))) ## [Utils] (type: #export Proc - (-> &;Analyser (List Code) (Lux Analysis))) + (-> &;Analyser (List Code) (Lux la;Analysis))) (type: #export Bundle - (d;Dict Text Proc)) + (Dict Text Proc)) (def: #export (install name unnamed) (-> Text (-> Text Proc) (-> Bundle Bundle)) - (d;put name (unnamed name))) + (dict;put name (unnamed name))) (def: #export (prefix prefix bundle) (-> Text Bundle Bundle) (|> bundle - d;entries + dict;entries (list/map (function [[key val]] [(format prefix " " key) val])) - (d;from-list text;Hash<Text>))) + (dict;from-list text;Hash<Text>))) (def: #export (wrong-arity proc expected actual) (-> Text Nat Nat Text) @@ -52,8 +52,8 @@ (analyse argC))) (list;zip2 input-types args)) expected macro;expected-type - _ (&;within-type-env - (TC;check expected output-type))] + _ (&;with-type-env + (tc;check expected output-type))] (wrap (#la;Procedure proc argsA))) (&;fail (wrong-arity proc num-expected num-actual))))))) @@ -95,11 +95,11 @@ (do Monad<Lux> [opA (&;with-expected-type (type (io;IO varT)) (analyse opC)) - outputT (&;within-type-env - (TC;clean var-id (type (Either Text varT)))) + outputT (&;with-type-env + (tc;clean var-id (type (Either Text varT)))) expected macro;expected-type - _ (&;within-type-env - (TC;check expected outputT))] + _ (&;with-type-env + (tc;check expected outputT))] (wrap (#la;Procedure proc (list opA)))) _ @@ -107,14 +107,14 @@ (def: lux-procs Bundle - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "is" lux-is) (install "try" lux-try))) (def: io-procs Bundle (<| (prefix "io") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "log" (unary Text Unit)) (install "error" (unary Text Bottom)) (install "exit" (unary Nat Bottom)) @@ -123,7 +123,7 @@ (def: bit-procs Bundle (<| (prefix "bit") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "count" (unary Nat Nat)) (install "and" (binary Nat Nat Nat)) (install "or" (binary Nat Nat Nat)) @@ -136,7 +136,7 @@ (def: nat-procs Bundle (<| (prefix "nat") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "+" (binary Nat Nat Nat)) (install "-" (binary Nat Nat Nat)) (install "*" (binary Nat Nat Nat)) @@ -152,7 +152,7 @@ (def: int-procs Bundle (<| (prefix "int") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "+" (binary Int Int Int)) (install "-" (binary Int Int Int)) (install "*" (binary Int Int Int)) @@ -168,7 +168,7 @@ (def: deg-procs Bundle (<| (prefix "deg") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "+" (binary Deg Deg Deg)) (install "-" (binary Deg Deg Deg)) (install "*" (binary Deg Deg Deg)) @@ -185,7 +185,7 @@ (def: frac-procs Bundle (<| (prefix "frac") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "+" (binary Frac Frac Frac)) (install "-" (binary Frac Frac Frac)) (install "*" (binary Frac Frac Frac)) @@ -207,7 +207,7 @@ (def: text-procs Bundle (<| (prefix "text") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "=" (binary Text Text Bool)) (install "<" (binary Text Text Bool)) (install "prepend" (binary Text Text Text)) @@ -246,7 +246,7 @@ (def: array-procs Bundle (<| (prefix "array") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "new" (unary Nat Array)) (install "get" array-get) (install "put" array-put) @@ -257,7 +257,7 @@ (def: math-procs Bundle (<| (prefix "math") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "cos" (unary Frac Frac)) (install "sin" (unary Frac Frac)) (install "tan" (unary Frac Frac)) @@ -288,11 +288,11 @@ (do Monad<Lux> [initA (&;with-expected-type varT (analyse initC)) - outputT (&;within-type-env - (TC;clean var-id (type (A;Atom varT)))) + outputT (&;with-type-env + (tc;clean var-id (type (A;Atom varT)))) expected macro;expected-type - _ (&;within-type-env - (TC;check expected outputT))] + _ (&;with-type-env + (tc;check expected outputT))] (wrap (#la;Procedure proc (list initA)))) _ @@ -317,7 +317,7 @@ (def: atom-procs Bundle (<| (prefix "atom") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "new" atom-new) (install "read" atom-read) (install "compare-and-swap" atom-compare-and-swap) @@ -326,7 +326,7 @@ (def: process-procs Bundle (<| (prefix "process") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "concurrency-level" (nullary Nat)) (install "future" (unary (type (io;IO Top)) Unit)) (install "schedule" (binary Nat (type (io;IO Top)) Unit)) @@ -335,16 +335,16 @@ (def: #export procedures Bundle (<| (prefix "lux") - (|> (d;new text;Hash<Text>) - (d;merge lux-procs) - (d;merge bit-procs) - (d;merge nat-procs) - (d;merge int-procs) - (d;merge deg-procs) - (d;merge frac-procs) - (d;merge text-procs) - (d;merge array-procs) - (d;merge math-procs) - (d;merge atom-procs) - (d;merge process-procs) - (d;merge io-procs)))) + (|> (dict;new text;Hash<Text>) + (dict;merge lux-procs) + (dict;merge bit-procs) + (dict;merge nat-procs) + (dict;merge int-procs) + (dict;merge deg-procs) + (dict;merge frac-procs) + (dict;merge text-procs) + (dict;merge array-procs) + (dict;merge math-procs) + (dict;merge atom-procs) + (dict;merge process-procs) + (dict;merge io-procs)))) diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index a8af2748a..1dba7a5f8 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -5,6 +5,7 @@ ["ex" exception #+ exception:]) (concurrency ["A" atom]) (data ["R" result] + [maybe] [product] [text "text/" Eq<Text>] (text format @@ -18,7 +19,7 @@ [host]) (luxc ["&" base] ["&;" host] - (lang ["la" analysis #+ Analysis]) + (lang ["la" analysis]) (analyser ["&;" common])) ["@" ../common] ) @@ -245,7 +246,7 @@ (case elemT (#;Host name #;Nil) (let [boxed-name (|> (dict;get name boxes) - (default name))] + (maybe;default name))] (wrap [(#;Host boxed-name #;Nil) boxed-name])) @@ -267,8 +268,8 @@ (do macro;Monad<Lux> [arrayA (&;with-expected-type (type (Array varT)) (analyse arrayC)) - elemT (&;within-type-env - (tc;read-var var-id)) + elemT (&;with-type-env + (tc;read var-id)) [elemT elem-class] (box-array-element-type elemT) idxA (&;with-expected-type Nat (analyse idxC)) @@ -288,8 +289,8 @@ (do macro;Monad<Lux> [arrayA (&;with-expected-type (type (Array varT)) (analyse arrayC)) - elemT (&;within-type-env - (tc;read-var var-id)) + elemT (&;with-type-env + (tc;read var-id)) [valueT elem-class] (box-array-element-type elemT) idxA (&;with-expected-type Nat (analyse idxC)) @@ -334,8 +335,8 @@ (do macro;Monad<Lux> [objectA (&;with-expected-type varT (analyse objectC)) - objectT (&;within-type-env - (tc;read-var var-id)) + objectT (&;with-type-env + (tc;read var-id)) _ (check-object objectT) _ (&;infer Bool)] (wrap (#la;Procedure proc (list objectA)))) @@ -353,8 +354,8 @@ (do macro;Monad<Lux> [monitorA (&;with-expected-type varT (analyse monitorC)) - monitorT (&;within-type-env - (tc;read-var var-id)) + monitorT (&;with-type-env + (tc;read var-id)) _ (check-object monitorT) exprA (analyse exprC)] (wrap (#la;Procedure proc (list monitorA exprA)))) @@ -432,8 +433,8 @@ (do macro;Monad<Lux> [exceptionA (&;with-expected-type varT (analyse exceptionC)) - exceptionT (&;within-type-env - (tc;read-var var-id)) + exceptionT (&;with-type-env + (tc;read var-id)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) _ (: (Lux Unit) @@ -478,8 +479,8 @@ (do macro;Monad<Lux> [objectA (&;with-expected-type varT (analyse objectC)) - objectT (&;within-type-env - (tc;read-var var-id)) + objectT (&;with-type-env + (tc;read var-id)) object-class (check-object objectT) ? (sub-class? class object-class)] (if ? @@ -599,13 +600,13 @@ [to-name (check-jvm to) from-name (check-jvm from)] (cond (dict;contains? to-name boxes) - (let [box (assume (dict;get to-name boxes))] + (let [box (maybe;assume (dict;get to-name boxes))] (if (text/= box from-name) (wrap [box (#;Host to-name (list))]) (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name)))) (dict;contains? from-name boxes) - (let [box (assume (dict;get from-name boxes))] + (let [box (maybe;assume (dict;get from-name boxes))] (do @ [[_ castT] (cast to (#;Host box (list)))] (wrap [from-name castT]))) @@ -709,8 +710,8 @@ target-class)) sourceA (&;with-expected-type varT (analyse sourceC)) - sourceT (&;within-type-env - (tc;read-var var-id)) + sourceT (&;with-type-env + (tc;read var-id)) [unboxed castT] (cast targetT sourceT) _ (&;assert (format "Object cannot be a primitive: " unboxed) (text;empty? unboxed))] @@ -722,8 +723,8 @@ (do macro;Monad<Lux> [sourceA (&;with-expected-type varT (analyse sourceC)) - sourceT (&;within-type-env - (tc;read-var var-id)) + sourceT (&;with-type-env + (tc;read var-id)) [unboxed castT] (cast targetT sourceT)] (wrap [castT unboxed sourceA])))) @@ -738,8 +739,8 @@ [[fieldT final?] (static-field class field) expectedT macro;expected-type [unboxed castT] (cast expectedT fieldT) - _ (&;within-type-env - (tc;check expectedT castT))] + _ (&;with-type-env + (tc;check expectedT castT))] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed))))) _ @@ -760,8 +761,8 @@ _ (&;assert (Final-Field (format class "#" field)) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;within-type-env - (tc;check fieldT valueT)) + _ (&;with-type-env + (tc;check fieldT valueT)) _ (&;infer Unit)] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA)))) @@ -783,8 +784,8 @@ [fieldT final?] (virtual-field class field objectT) expectedT macro;expected-type [unboxed castT] (cast expectedT fieldT) - _ (&;within-type-env - (tc;check expectedT castT))] + _ (&;with-type-env + (tc;check expectedT castT))] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA)))) _ @@ -806,8 +807,8 @@ _ (&;assert (Final-Field (format class "#" field)) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;within-type-env - (tc;check fieldT valueT)) + _ (&;with-type-env + (tc;check fieldT valueT)) _ (&;infer Unit)] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA)))) |