From e0f63b0cfda4d7dd0d233d13ce88b5da889dea02 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 31 Oct 2017 01:53:56 -0400
Subject: - Now, all special forms are handled as procedures. - "lux case" now
takes its branches as a non-empty record.
---
new-luxc/source/luxc/analyser.lux | 51 +----------
new-luxc/source/luxc/analyser/procedure.lux | 6 +-
new-luxc/source/luxc/analyser/procedure/common.lux | 102 +++++++++++++++++----
.../source/luxc/analyser/procedure/host.jvm.lux | 38 ++++----
.../test/test/luxc/analyser/procedure/common.lux | 15 +--
.../test/test/luxc/analyser/procedure/host.jvm.lux | 3 +-
6 files changed, 120 insertions(+), 95 deletions(-)
(limited to 'new-luxc')
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index f0712794d..04d8d58b7 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -8,7 +8,7 @@
[meta]
(meta [type]
(type ["tc" check]))
- [host #+ do-to])
+ [host])
(luxc ["&" base]
[";L" host]
(lang ["la" analysis])
@@ -18,9 +18,7 @@
["&&;" function]
["&&;" primitive]
["&&;" reference]
- ["&&;" type]
["&&;" structure]
- ["&&;" case]
["&&;" procedure]))
(for {"JVM" (as-is (host;import java.lang.reflect.Method
@@ -53,20 +51,7 @@
})
(exception: #export Macro-Expression-Must-Have-Single-Expansion)
-
-(def: (to-branches raw)
- (-> (List Code) (Meta (List [Code Code])))
- (case raw
- (^ (list))
- (:: meta;Monad<Meta> wrap (list))
-
- (^ (list& patternH bodyH inputT))
- (do meta;Monad<Meta>
- [outputT (to-branches inputT)]
- (wrap (list& [patternH bodyH] outputT)))
-
- _
- (&;fail "Uneven expressions for pattern-matching.")))
+(exception: #export Unrecognized-Syntax)
(def: #export (analyser eval)
(-> &;Eval &;Analyser)
@@ -105,36 +90,8 @@
(#;Symbol reference)
(&&reference;analyse-reference reference)
- (^ (#;Form (list [_ (#;Text "lux function")]
- [_ (#;Symbol ["" func-name])]
- [_ (#;Symbol ["" arg-name])]
- body)))
- (&&function;analyse-function analyse func-name arg-name body)
-
- (^template [<special> <analyser>]
- (^ (#;Form (list [_ (#;Text <special>)] type value)))
- (<analyser> analyse eval type value))
- (["lux check" &&type;analyse-check]
- ["lux coerce" &&type;analyse-coerce])
-
- (^ (#;Form (list [_ (#;Text "lux check type")] 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))
-
- (^ (#;Form (list& [_ (#;Text "lux case")]
- input
- branches)))
- (do meta;Monad<Meta>
- [paired (to-branches branches)]
- (&&case;analyse-case analyse input paired))
-
(^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
- (&&procedure;analyse-procedure analyse proc-name proc-args)
+ (&&procedure;analyse-procedure analyse eval proc-name proc-args)
(^template [<tag> <analyser>]
(^ (#;Form (list& [_ (<tag> tag)]
@@ -180,5 +137,5 @@
(&&function;analyse-apply analyse funcT =func args)))
_
- (&;fail (format "Unrecognized syntax: " (%code ast)))
+ (&;throw Unrecognized-Syntax (%code ast))
)))))))
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])
diff --git a/new-luxc/test/test/luxc/analyser/procedure/common.lux b/new-luxc/test/test/luxc/analyser/procedure/common.lux
index 8649de3d7..5e1619d38 100644
--- a/new-luxc/test/test/luxc/analyser/procedure/common.lux
+++ b/new-luxc/test/test/luxc/analyser/procedure/common.lux
@@ -16,6 +16,7 @@
(luxc ["&" base]
["&;" scope]
["&;" module]
+ [";L" eval]
(lang ["~" analysis])
[analyser]
(analyser ["@" procedure]
@@ -28,7 +29,7 @@
(-> Text (List Code) Type Bool)
(|> (&;with-scope
(&;with-expected-type output-type
- (@;analyse-procedure analyse procedure params)))
+ (@;analyse-procedure analyse evalL;eval procedure params)))
(meta;run (init-compiler []))
(case> (#e;Success _)
<success>
@@ -262,7 +263,7 @@
(|> (&scope;with-scope ""
(&scope;with-local [var-name arrayT]
(&;with-expected-type elemT
- (@;analyse-procedure analyse "lux array get"
+ (@;analyse-procedure analyse evalL;eval "lux array get"
(list idxC
(code;symbol ["" var-name]))))))
(meta;run (init-compiler []))
@@ -275,7 +276,7 @@
(|> (&scope;with-scope ""
(&scope;with-local [var-name arrayT]
(&;with-expected-type arrayT
- (@;analyse-procedure analyse "lux array put"
+ (@;analyse-procedure analyse evalL;eval "lux array put"
(list idxC
elemC
(code;symbol ["" var-name]))))))
@@ -289,7 +290,7 @@
(|> (&scope;with-scope ""
(&scope;with-local [var-name arrayT]
(&;with-expected-type arrayT
- (@;analyse-procedure analyse "lux array remove"
+ (@;analyse-procedure analyse evalL;eval "lux array remove"
(list idxC
(code;symbol ["" var-name]))))))
(meta;run (init-compiler []))
@@ -302,7 +303,7 @@
(|> (&scope;with-scope ""
(&scope;with-local [var-name arrayT]
(&;with-expected-type Nat
- (@;analyse-procedure analyse "lux array size"
+ (@;analyse-procedure analyse evalL;eval "lux array size"
(list (code;symbol ["" var-name]))))))
(meta;run (init-compiler []))
(case> (#e;Success _)
@@ -362,7 +363,7 @@
(|> (&scope;with-scope ""
(&scope;with-local [var-name atomT]
(&;with-expected-type elemT
- (@;analyse-procedure analyse "lux atom read"
+ (@;analyse-procedure analyse evalL;eval "lux atom read"
(list (code;symbol ["" var-name]))))))
(meta;run (init-compiler []))
(case> (#e;Success _)
@@ -374,7 +375,7 @@
(|> (&scope;with-scope ""
(&scope;with-local [var-name atomT]
(&;with-expected-type Bool
- (@;analyse-procedure analyse "lux atom compare-and-swap"
+ (@;analyse-procedure analyse evalL;eval "lux atom compare-and-swap"
(list elemC
elemC
(code;symbol ["" var-name]))))))
diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
index d1520e5b7..3cee1b160 100644
--- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
@@ -20,6 +20,7 @@
(luxc ["&" base]
["&;" scope]
["&;" module]
+ [";L" eval]
(lang ["~" analysis])
[analyser]
(analyser ["@" procedure]
@@ -36,7 +37,7 @@
[runtime-bytecode @runtime;generate]
(&;with-scope
(&;with-expected-type output-type
- (@;analyse-procedure analyse procedure params))))
+ (@;analyse-procedure analyse evalL;eval procedure params))))
(meta;run (init-compiler []))
(case> (#e;Success _)
<success>
--
cgit v1.2.3