aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/analyser')
-rw-r--r--new-luxc/source/luxc/analyser/procedure.lux6
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux102
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux38
3 files changed, 106 insertions, 40 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux
index 53ad8276c..225fb7b23 100644
--- a/new-luxc/source/luxc/analyser/procedure.lux
+++ b/new-luxc/source/luxc/analyser/procedure.lux
@@ -15,9 +15,9 @@
(|> ./common;procedures
(dict;merge ./host;procedures)))
-(def: #export (analyse-procedure analyse proc-name proc-args)
- (-> &;Analyser Text (List Code) (Meta la;Analysis))
+(def: #export (analyse-procedure analyse eval proc-name proc-args)
+ (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis))
(<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name))))
(do maybe;Monad<Maybe>
[proc (dict;get proc-name procedures)]
- (wrap (proc analyse proc-args)))))
+ (wrap (proc analyse eval proc-args)))))
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
index 6c2e810b5..f64c537cb 100644
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ b/new-luxc/source/luxc/analyser/procedure/common.lux
@@ -12,11 +12,14 @@
[io])
(luxc ["&" base]
(lang ["la" analysis])
- (analyser ["&;" common])))
+ (analyser ["&;" common]
+ [";A" function]
+ [";A" case]
+ [";A" type])))
## [Utils]
(type: #export Proc
- (-> &;Analyser (List Code) (Meta la;Analysis)))
+ (-> &;Analyser &;Eval (List Code) (Meta la;Analysis)))
(type: #export Bundle
(Dict Text Proc))
@@ -42,7 +45,7 @@
(def: (simple proc input-types output-type)
(-> Text (List Type) Type Proc)
(let [num-expected (list;size input-types)]
- (function [analyse args]
+ (function [analyse eval args]
(let [num-actual (list;size args)]
(if (n.= num-expected num-actual)
(do Monad<Meta>
@@ -77,17 +80,17 @@
## "lux is" represents reference/pointer equality.
(def: (lux-is proc)
(-> Text Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
((binary varT varT Bool proc)
- analyse args)))))
+ 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 args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -105,11 +108,74 @@
_
(&;fail (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))))))))
+
+(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))))))))
+
+(do-template [<name> <analyser>]
+ [(def: (<name> proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list typeC valueC))
+ (<analyser> analyse eval typeC valueC)
+
+ _
+ (&;fail (wrong-arity proc +2 (list;size args))))))))]
+
+ [lux//check typeA;analyse-check]
+ [lux//coerce typeA;analyse-coerce])
+
+(def: (lux//check//type proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list valueC))
+ (do meta;Monad<Meta>
+ [valueA (&;with-expected-type Type
+ (analyse valueC))
+ expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected Type))]
+ (wrap valueA))
+
+ _
+ (&;fail (wrong-arity proc +1 (list;size args))))))
+
(def: lux-procs
Bundle
(|> (dict;new text;Hash<Text>)
(install "is" lux-is)
- (install "try" lux-try)))
+ (install "try" lux-try)
+ (install "function" lux//function)
+ (install "case" lux//case)
+ (install "check" lux//check)
+ (install "coerce" lux//coerce)
+ (install "check type" lux//check//type)))
(def: io-procs
Bundle
@@ -222,27 +288,27 @@
(def: (array-get proc)
(-> Text Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
((binary Nat (type (Array varT)) varT proc)
- analyse args)))))
+ analyse eval args)))))
(def: (array-put proc)
(-> Text Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
- analyse args)))))
+ analyse eval args)))))
(def: (array-remove proc)
(-> Text Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
((binary Nat (type (Array varT)) (type (Array varT)) proc)
- analyse args)))))
+ analyse eval args)))))
(def: array-procs
Bundle
@@ -281,7 +347,7 @@
(def: (atom-new proc)
(-> Text Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -301,19 +367,19 @@
(def: (atom-read proc)
(-> Text Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
((unary (type (A;Atom varT)) varT proc)
- analyse args)))))
+ analyse eval args)))))
(def: (atom-compare-and-swap proc)
(-> Text Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
((trinary varT varT (type (A;Atom varT)) Bool proc)
- analyse args)))))
+ analyse eval args)))))
(def: atom-procs
Bundle
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index 84592d4ee..4db7b4dda 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -147,7 +147,7 @@
(def: (array-length proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -167,7 +167,7 @@
(def: (array-new proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case args
(^ (list lengthC))
(do meta;Monad<Meta>
@@ -261,7 +261,7 @@
(def: (array-read proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -282,7 +282,7 @@
(def: (array-write proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -315,7 +315,7 @@
(def: (object-null proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case args
(^ (list))
(do meta;Monad<Meta>
@@ -328,7 +328,7 @@
(def: (object-null? proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -347,7 +347,7 @@
(def: (object-synchronized proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -448,7 +448,7 @@
(def: (object-throw proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -472,7 +472,7 @@
(def: (object-class proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case args
(^ (list classC))
(case classC
@@ -492,7 +492,7 @@
(def: (object-instance? proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(&common;with-var
(function [[var-id varT]]
(case args
@@ -793,7 +793,7 @@
(def: (static-get proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case args
(^ (list classC fieldC))
(case [classC fieldC]
@@ -811,7 +811,7 @@
(def: (static-put proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case args
(^ (list classC fieldC valueC))
(case [classC fieldC]
@@ -834,7 +834,7 @@
(def: (virtual-get proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case args
(^ (list classC fieldC objectC))
(case [classC fieldC]
@@ -853,7 +853,7 @@
(def: (virtual-put proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case args
(^ (list classC fieldC valueC objectC))
(case [classC fieldC]
@@ -1104,7 +1104,7 @@
(def: (invoke//static proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case (: (e;Error [Text Text (List [Text Code])])
(s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any))))))
(#e;Success [class method argsTC])
@@ -1121,7 +1121,7 @@
(def: (invoke//virtual proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case (: (e;Error [Text Text Code (List [Text Code])])
(s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))))))
(#e;Success [class method objectC argsTC])
@@ -1144,7 +1144,7 @@
(def: (invoke//special proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]])
(p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!)))
(#e;Success [_ [class method objectC argsTC _]])
@@ -1163,7 +1163,7 @@
(def: (invoke//interface proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case (: (e;Error [Text Text Code (List [Text Code])])
(s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))))))
(#e;Success [class-name method objectC argsTC])
@@ -1183,7 +1183,7 @@
(def: (invoke//constructor proc)
(-> Text @;Proc)
- (function [analyse args]
+ (function [analyse eval args]
(case (: (e;Error [Text (List [Text Code])])
(s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any))))))
(#e;Success [class argsTC])
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 17:36:58 +0000