diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/analyser.clj | 262 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 14 | ||||
| -rw-r--r-- | src/lux/base.clj | 45 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 2 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 26 |
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) |