aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/lux/analyser.clj262
-rw-r--r--src/lux/analyser/lux.clj14
-rw-r--r--src/lux/base.clj45
-rw-r--r--src/lux/compiler.clj2
-rw-r--r--src/lux/compiler/lambda.clj26
5 files changed, 184 insertions, 165 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 93092c9ac..cf2e4bab7 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -44,168 +44,156 @@
))
))
-(defn ^:private aba1 [analyse optimize eval! compile-module compilers exo-type token]
- (|let [[compile-def compile-program compile-class compile-interface] compilers]
+(defn ^:private just-analyse [analyser syntax]
+ (&type/with-var
+ (fn [?var]
+ (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)]
+ (|case [?var ?output-type]
+ [(&/$VarT ?e-id) (&/$VarT ?a-id)]
+ (if (= ?e-id ?a-id)
+ (|do [=output-type (&type/clean ?var ?output-type)]
+ (return (&&/|meta =output-type ?output-cursor ?output-term)))
+ (|do [=output-type (&type/clean ?var ?var)]
+ (return (&&/|meta =output-type ?output-cursor ?output-term))))
+
+ [_ _]
+ (|do [=output-type (&type/clean ?var ?output-type)]
+ (return (&&/|meta =output-type ?output-cursor ?output-term))))
+ ))))
+
+(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token]
+ (|let [analyse (partial analyse-ast optimize eval! compile-module compilers)
+ [cursor token] ?token
+ [compile-def compile-program compile-class compile-interface] compilers]
(|case token
;; Standard special forms
(&/$BoolS ?value)
- (|do [_ (&type/check exo-type &type/Bool)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor (&&/$bool ?value)))))
+ (|do [_ (&type/check exo-type &type/Bool)]
+ (return (&/|list (&&/|meta exo-type cursor (&&/$bool ?value)))))
(&/$IntS ?value)
- (|do [_ (&type/check exo-type &type/Int)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor (&&/$int ?value)))))
+ (|do [_ (&type/check exo-type &type/Int)]
+ (return (&/|list (&&/|meta exo-type cursor (&&/$int ?value)))))
(&/$RealS ?value)
- (|do [_ (&type/check exo-type &type/Real)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor (&&/$real ?value)))))
+ (|do [_ (&type/check exo-type &type/Real)]
+ (return (&/|list (&&/|meta exo-type cursor (&&/$real ?value)))))
(&/$CharS ?value)
- (|do [_ (&type/check exo-type &type/Char)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor (&&/$char ?value)))))
+ (|do [_ (&type/check exo-type &type/Char)]
+ (return (&/|list (&&/|meta exo-type cursor (&&/$char ?value)))))
(&/$TextS ?value)
- (|do [_ (&type/check exo-type &type/Text)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor (&&/$text ?value)))))
+ (|do [_ (&type/check exo-type &type/Text)]
+ (return (&/|list (&&/|meta exo-type cursor (&&/$text ?value)))))
(&/$TupleS ?elems)
- (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems)
+ (&/with-analysis-meta cursor exo-type
+ (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems))
(&/$RecordS ?elems)
- (&&lux/analyse-record analyse exo-type ?elems)
+ (&/with-analysis-meta cursor exo-type
+ (&&lux/analyse-record analyse exo-type ?elems))
(&/$TagS ?ident)
- (analyse-variant+ analyse exo-type ?ident &/$Nil)
+ (&/with-analysis-meta cursor exo-type
+ (analyse-variant+ analyse exo-type ?ident &/$Nil))
(&/$SymbolS ?ident)
- (&&lux/analyse-symbol analyse exo-type ?ident)
+ (&/with-analysis-meta cursor exo-type
+ (&&lux/analyse-symbol analyse exo-type ?ident))
+
+ (&/$FormS (&/$Cons [command-meta command] parameters))
+ (|case command
+ (&/$SymbolS _ command-name)
+ (case command-name
+ "_lux_case"
+ (|let [(&/$Cons ?value ?branches) parameters]
+ (&/with-analysis-meta cursor exo-type
+ (&&lux/analyse-case analyse exo-type ?value ?branches)))
+
+ "_lux_lambda"
+ (|let [(&/$Cons [_ (&/$SymbolS "" ?self)]
+ (&/$Cons [_ (&/$SymbolS "" ?arg)]
+ (&/$Cons ?body
+ (&/$Nil)))) parameters]
+ (&/with-analysis-meta cursor exo-type
+ (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body)))
+
+ "_lux_proc"
+ (|let [(&/$Cons [_ (&/$TupleS (&/$Cons [_ (&/$TextS ?category)]
+ (&/$Cons [_ (&/$TextS ?proc)]
+ (&/$Nil))))]
+ (&/$Cons [_ (&/$TupleS ?args)]
+ (&/$Nil))) parameters]
+ (&/with-analysis-meta cursor exo-type
+ (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args)))
+
+ "_lux_:"
+ (|let [(&/$Cons ?type
+ (&/$Cons ?value
+ (&/$Nil))) parameters]
+ (&/with-analysis-meta cursor exo-type
+ (&&lux/analyse-ann analyse eval! exo-type ?type ?value)))
+
+ "_lux_:!"
+ (|let [(&/$Cons ?type
+ (&/$Cons ?value
+ (&/$Nil))) parameters]
+ (&/with-analysis-meta cursor exo-type
+ (&&lux/analyse-coerce analyse eval! exo-type ?type ?value)))
+
+ "_lux_def"
+ (|let [(&/$Cons [_ (&/$SymbolS "" ?name)]
+ (&/$Cons ?value
+ (&/$Cons ?meta
+ (&/$Nil))
+ )) parameters]
+ (&/with-cursor cursor
+ (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta)))
+
+ "_lux_alias"
+ (|let [(&/$Cons [_ (&/$TextS ?alias)]
+ (&/$Cons [_ (&/$TextS ?module)]
+ (&/$Nil))) parameters]
+ (&/with-cursor cursor
+ (&&lux/analyse-alias analyse ?alias ?module)))
+
+ "_lux_import"
+ (|let [(&/$Cons [_ (&/$TextS ?path)]
+ (&/$Nil)) parameters]
+ (&/with-cursor cursor
+ (&&lux/analyse-import analyse compile-module ?path)))
+
+ "_lux_program"
+ (|let [(&/$Cons [_ (&/$SymbolS "" ?args)]
+ (&/$Cons ?body
+ (&/$Nil))) parameters]
+ (&/with-cursor cursor
+ (&&lux/analyse-program analyse optimize compile-program ?args ?body)))
+
+ ;; else
+ (&/with-analysis-meta cursor exo-type
+ (|do [=fn (just-analyse analyse (&/T [command-meta command]))]
+ (&&lux/analyse-apply analyse cursor exo-type =fn parameters))))
+
+ (&/$IntS idx)
+ (&/with-analysis-meta cursor exo-type
+ (&&lux/analyse-variant analyse (&/$Right exo-type) idx nil parameters))
+
+ (&/$TagS ?ident)
+ (&/with-analysis-meta cursor exo-type
+ (analyse-variant+ analyse exo-type ?ident parameters))
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")]
- (&/$Cons ?value ?branches)))
- (&&lux/analyse-case analyse exo-type ?value ?branches)
-
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")]
- (&/$Cons [_ (&/$SymbolS "" ?self)]
- (&/$Cons [_ (&/$SymbolS "" ?arg)]
- (&/$Cons ?body
- (&/$Nil))))))
- (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body)
-
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")]
- (&/$Cons [_ (&/$SymbolS "" ?name)]
- (&/$Cons ?value
- (&/$Cons ?meta
- (&/$Nil))
- ))))
- (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta)
-
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")]
- (&/$Cons [_ (&/$TextS ?path)]
- (&/$Nil))))
- (&&lux/analyse-import analyse compile-module ?path)
-
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")]
- (&/$Cons ?type
- (&/$Cons ?value
- (&/$Nil)))))
- (&&lux/analyse-ann analyse eval! exo-type ?type ?value)
-
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")]
- (&/$Cons ?type
- (&/$Cons ?value
- (&/$Nil)))))
- (&&lux/analyse-coerce analyse eval! exo-type ?type ?value)
-
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")]
- (&/$Cons [_ (&/$TextS ?alias)]
- (&/$Cons [_ (&/$TextS ?module)]
- (&/$Nil)))))
- (&&lux/analyse-alias analyse ?alias ?module)
-
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_proc")]
- (&/$Cons [_ (&/$TupleS (&/$Cons [_ (&/$TextS ?category)]
- (&/$Cons [_ (&/$TextS ?proc)]
- (&/$Nil))))]
- (&/$Cons [_ (&/$TupleS ?args)]
- (&/$Nil)))))
- (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args)
-
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_program")]
- (&/$Cons [_ (&/$SymbolS "" ?args)]
- (&/$Cons ?body
- (&/$Nil)))))
- (&&lux/analyse-program analyse optimize compile-program ?args ?body)
+ _
+ (&/with-analysis-meta cursor exo-type
+ (|do [=fn (just-analyse analyse (&/T [command-meta command]))]
+ (&&lux/analyse-apply analyse cursor exo-type =fn parameters))))
_
(&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token])))))
)))
-(defn ^:private analyse-basic-ast [analyse optimize eval! compile-module compilers exo-type token]
- (|case token
- [meta ?token]
- (fn [state]
- (|case ((aba1 analyse optimize eval! compile-module compilers exo-type ?token) state)
- (&/$Right state* output)
- (return* state* output)
-
- (&/$Left msg)
- (if (= "" msg)
- (fail* (&/add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token))))
- (fail* (&/add-loc (&/get$ &/$cursor state) msg)))
- ))))
-
-(defn ^:private just-analyse [analyser syntax]
- (&type/with-var
- (fn [?var]
- (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)]
- (|case [?var ?output-type]
- [(&/$VarT ?e-id) (&/$VarT ?a-id)]
- (if (= ?e-id ?a-id)
- (|do [=output-type (&type/clean ?var ?output-type)]
- (return (&&/|meta =output-type ?output-cursor ?output-term)))
- (|do [=output-type (&type/clean ?var ?var)]
- (return (&&/|meta =output-type ?output-cursor ?output-term))))
-
- [_ _]
- (|do [=output-type (&type/clean ?var ?output-type)]
- (return (&&/|meta =output-type ?output-cursor ?output-term))))
- ))))
-
-(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type token]
- (|let [[cursor _] token
- analyser (partial analyse-ast optimize eval! compile-module compilers)]
- (&/with-cursor cursor
- (&/with-expected-type exo-type
- (|case token
- [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))]
- (&&lux/analyse-variant analyser (&/$Right exo-type) idx nil ?values)
-
- [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))]
- (analyse-variant+ analyser exo-type ?ident ?values)
-
- [meta (&/$FormS (&/$Cons ?fn ?args))]
- (|case ?fn
- [_ (&/$SymbolS _)]
- (fn [state]
- (|case ((just-analyse analyser ?fn) state)
- (&/$Right state* =fn)
- ((&&lux/analyse-apply analyser exo-type =fn ?args) state*)
-
- _
- ((analyse-basic-ast analyser optimize eval! compile-module compilers exo-type token) state)))
-
- _
- (|do [=fn (just-analyse analyser ?fn)]
- (&&lux/analyse-apply analyser exo-type =fn ?args)))
-
- _
- (analyse-basic-ast analyser optimize eval! compile-module compilers exo-type token))))))
-
;; [Resources]
(defn analyse [optimize eval! compile-module compilers]
(|do [asts &parser/parse]
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 843f61d34..1a3634f8f 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -371,7 +371,7 @@
(&&/$apply =fn =args)
)))))
-(defn analyse-apply [analyse exo-type =fn ?args]
+(defn analyse-apply [analyse cursor exo-type =fn ?args]
(|do [loader &/loader
:let [[[=fn-type =fn-cursor] =fn-form] =fn]]
(|case =fn-form
@@ -544,7 +544,8 @@
(return (&/|list output))))
(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta]
- (|do [module-name &/get-module-name
+ (|do [;; _ &/ensure-statement
+ module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
(fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
@@ -559,7 +560,8 @@
)))
(defn analyse-import [analyse compile-module path]
- (|do [module-name &/get-module-name
+ (|do [;; _ &/ensure-statement
+ module-name &/get-module-name
_ (if (= module-name path)
(fail (str "[Analyser Error] Module can't import itself: " path))
(return nil))]
@@ -574,7 +576,8 @@
(return &/$Nil)))))
(defn analyse-alias [analyse ex-alias ex-module]
- (|do [module-name &/get-module-name
+ (|do [;; _ &/ensure-statement
+ module-name &/get-module-name
_ (&&module/alias module-name ex-alias ex-module)]
(return &/$Nil)))
@@ -614,7 +617,8 @@
(let [input-type (&/$AppT &type/List &type/Text)
output-type (&/$AppT &type/IO &/$UnitT)]
(defn analyse-program [analyse optimize compile-program ?args ?body]
- (|do [=body (&/with-scope ""
+ (|do [;; _ &/ensure-statement
+ =body (&/with-scope ""
(&&env/with-local ?args input-type
(&&/analyse-1 analyse output-type ?body)))
_ (compile-program (optimize =body))]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 89f9bb36a..54baf16bb 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -761,7 +761,7 @@
;; "lux;types"
+init-bindings+
;; "lux;expected"
- $VoidT
+ $None
;; "lux;seed"
0
;; "lux;host"
@@ -902,7 +902,7 @@
(defn with-expected-type [type body]
"(All [a] (-> Type (Lux a)))"
(fn [state]
- (let [output (body (set$ $expected type state))]
+ (let [output (body (set$ $expected ($Some type) state))]
(|case output
($Right ?state ?value)
(return* (set$ $expected (get$ $expected state) ?state)
@@ -913,7 +913,7 @@
(defn with-cursor [^objects cursor body]
"(All [a] (-> Cursor (Lux a)))"
- (|let [[_file-name _line _column] cursor]
+ (|let [[_file-name _ _] cursor]
(if (= "" _file-name)
body
(fn [state]
@@ -926,6 +926,45 @@
_
output))))))
+(defn with-analysis-meta [^objects cursor type body]
+ "(All [a] (-> Cursor Type (Lux a)))"
+ (|let [[_file-name _ _] cursor]
+ (if (= "" _file-name)
+ (fn [state]
+ (let [output (body (->> state
+ (set$ $expected ($Some type))))]
+ (|case output
+ ($Right ?state ?value)
+ (return* (->> ?state
+ (set$ $expected (get$ $expected state)))
+ ?value)
+
+ _
+ output)))
+ (fn [state]
+ (let [output (body (->> state
+ (set$ $cursor cursor)
+ (set$ $expected ($Some type))))]
+ (|case output
+ ($Right ?state ?value)
+ (return* (->> ?state
+ (set$ $cursor (get$ $cursor state))
+ (set$ $expected (get$ $expected state)))
+ ?value)
+
+ _
+ output))))))
+
+(def ensure-statement
+ "(Lux Unit)"
+ (fn [state]
+ (|case (get$ $expected state)
+ ($None)
+ (return* state unit-tag)
+
+ ($Some _)
+ (fail* "[Error] All statements must be top-level forms."))))
+
(def cursor
;; (Lux Cursor)
(fn [state]
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index fe256a942..27bb42e4f 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -40,7 +40,7 @@
(def ^:private !source->last-line (atom nil))
(defn compile-expression [syntax]
- (|let [[[?type [_file-name _line _column]] ?form] syntax]
+ (|let [[[?type [_file-name _line _]] ?form] syntax]
(|do [^MethodVisitor *writer* &/get-writer
:let [debug-label (new Label)
_ (when (not= _line (get @!source->last-line _file-name))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 2bc0c29eb..7ba93a32b 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -170,19 +170,14 @@
$end (new Label)
method-writer (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil)
frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object"))
- frame-stack (to-array [Opcodes/INTEGER])]
+ frame-stack (to-array [Opcodes/INTEGER])
+ arity-over-extent (- arity +degree+)]
(do (doto method-writer
(.visitCode)
get-num-partials!
- (.visitFrame Opcodes/F_NEW
- (int (alength frame-locals)) frame-locals
- (int (alength frame-stack)) frame-stack)
(.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*))
;; (< stage (- arity +degree+))
(-> (doto (.visitLabel $label)
- (.visitFrame Opcodes/F_NEW
- (int (alength frame-locals)) frame-locals
- (int (alength frame-stack)) frame-stack)
(.visitTypeInsn Opcodes/NEW class-name)
(.visitInsn Opcodes/DUP)
(-> (get-field! class-name (str &&/closure-prefix cidx))
@@ -195,12 +190,9 @@
(fill-nulls! (- (- num-partials +degree+) stage))
(.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env arity))
(.visitJumpInsn Opcodes/GOTO $end))
- (->> (cond (= stage (- arity +degree+))
+ (->> (cond (= stage arity-over-extent)
(doto method-writer
(.visitLabel $label)
- (.visitFrame Opcodes/F_NEW
- (int (alength frame-locals)) frame-locals
- (int (alength frame-stack)) frame-stack)
(.visitVarInsn Opcodes/ALOAD 0)
(-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name))
(->> (when (not= 0 stage))))
@@ -210,22 +202,18 @@
(.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity))
(.visitJumpInsn Opcodes/GOTO $end))
- (> stage (- arity +degree+))
- (let [base 1
- args-to-completion (- arity stage)
+ (> stage arity-over-extent)
+ (let [args-to-completion (- arity stage)
args-left (- +degree+ args-to-completion)]
(doto method-writer
(.visitLabel $label)
- (.visitFrame Opcodes/F_NEW
- (int (alength frame-locals)) frame-locals
- (int (alength frame-stack)) frame-stack)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name))
(-> (get-field! class-name (str &&/partial-prefix idx))
(->> (dotimes [idx stage])))
- (consecutive-args base args-to-completion)
+ (consecutive-args 1 args-to-completion)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity))
- (consecutive-applys (+ base args-to-completion) args-left)
+ (consecutive-applys (+ 1 args-to-completion) args-left)
(.visitJumpInsn Opcodes/GOTO $end)))
:else)