From 658ff3e1e7d90ce72c8a02ef4cf7e177d8ac6f86 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 12 Jul 2015 21:04:56 -0400 Subject: - Added the beginnings of the standard library. - Fixed several bugs. --- src/lux/analyser.clj | 32 +++++++++++-- src/lux/analyser/case.clj | 11 ++++- src/lux/analyser/env.clj | 16 ++++--- src/lux/analyser/host.clj | 9 ++-- src/lux/analyser/lux.clj | 109 ++++++++++++++++++++++++++++++++------------ src/lux/analyser/module.clj | 79 +++++++++++++++++--------------- src/lux/base.clj | 14 +++++- src/lux/compiler.clj | 2 +- src/lux/compiler/host.clj | 27 +++++------ src/lux/compiler/lux.clj | 13 +++++- src/lux/lexer.clj | 20 ++++---- src/lux/type.clj | 37 +++++++++------ 12 files changed, 247 insertions(+), 122 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 039db810a..8c8be29d2 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -115,6 +115,12 @@ ["lux;Nil" _]]]]]]] (&&lux/analyse-export analyse ?ident) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-alias analyse ?alias ?module) + [_] (fail ""))) @@ -447,7 +453,7 @@ ;; Programs [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-program analyse ?args ?body) @@ -500,6 +506,9 @@ [["lux;Right" [state* output]]] (return* state* output) + [["lux;Left" ""]] + (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + [["lux;Left" msg]] (fail* (add-loc meta msg))) @@ -522,6 +531,21 @@ (fail* (add-loc meta msg)) )))) +(defn ^:private just-analyse [analyse-ast eval! compile-module syntax] + (&type/with-var + (fn [?var] + (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)] + (matchv ::M/objects [?var ?output-type] + [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] + (if (= ?e-id ?a-id) + (|do [?output-type* (&type/deref ?e-id)] + (return (&/T ?output-term ?output-type*))) + (return (&/T ?output-term ?output-type))) + + [_ _] + (return (&/T ?output-term ?output-type))) + )))) + (defn ^:private analyse-ast [eval! compile-module exo-type token] (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] @@ -530,10 +554,12 @@ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] (fn [state] - (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)] + (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state) + ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) + ] [["lux;Right" [state* =fn]]] (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*)) [_] ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 43e5ee5e7..6efe7fd5f 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -15,6 +15,15 @@ (fail "##9##")))] (resolve-type type*)) + [["lux;AllT" ?id]] + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type type $var)] + ;; (&type/actual-type =type)))) + [_] (&type/actual-type type))) @@ -68,7 +77,7 @@ (return (&/T (&/V "TupleTestAC" =tests) =kont)))) [_] - (fail "[Analyser Error] Tuple requires tuple-type.")) + (fail "[Analyser Error] Tuples require tuple-type.")) [["lux;RecordS" ?slots]] (|do [value-type* (resolve-type value-type)] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index fa7b9aa1a..de6bdb036 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -16,18 +16,20 @@ =return (body (&/update$ &/$ENVS (fn [stack] (let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] - (&/|cons (->> (&/|head stack) - (&/update$ &/$LOCALS #(&/update$ &/$COUNTER inc %)) - (&/update$ &/$LOCALS #(&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)) %))) + (&/|cons (&/update$ &/$LOCALS #(->> % + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/|head stack)) (&/|tail stack)))) state))] (matchv ::M/objects [=return] [["lux;Right" [?state ?value]]] (return* (&/update$ &/$ENVS (fn [stack*] - (&/|cons (->> (&/|head stack*) - (&/update$ &/$LOCALS #(&/update$ &/$COUNTER dec %)) - (&/update$ &/$LOCALS #(&/set$ &/$MAPPINGS old-mappings %))) - (&/|tail stack*))) + (&/|cons (&/update$ &/$LOCALS #(->> % + (&/update$ &/$COUNTER dec) + (&/set$ &/$MAPPINGS old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) ?state) ?value) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index b9361b8c3..3db4bd16d 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -352,7 +352,8 @@ ) (defn analyse-jvm-program [analyse ?args ?body] - (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] - (return (&/|list (&/V "jvm-program" =body))))) + (|let [[_module _name] ?args] + (|do [=body (&/with-scope "" + (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] + (return (&/|list (&/V "jvm-program" =body)))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6bbcd0fcf..d02599f10 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -76,6 +76,15 @@ (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) + [["lux;AllT" _]] + (|do [$var &type/existential + =type (&type/apply-type exo-type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type exo-type $var)] + ;; (&type/actual-type =type)))) + [_] (&type/actual-type exo-type)) types (matchv ::M/objects [exo-type*] @@ -83,7 +92,9 @@ (return ?table) [_] - (fail "[Analyser Error] The type of a record must be a record type.")) + (fail (str "[Analyser Error] The type of a record must be a record type:\n" + (&type/show-type exo-type*) + "\n"))) =slots (&/map% (fn [kv] (matchv ::M/objects [kv] [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] @@ -196,6 +207,9 @@ (|do [?fun-type* (&type/actual-type fun-type)] (matchv ::M/objects [?fun-type*] [["lux;AllT" _]] + ;; (|do [$var &type/existential + ;; type* (&type/apply-type ?fun-type* $var)] + ;; (analyse-apply* analyse exo-type type* ?args)) (&type/with-var (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) @@ -216,6 +230,9 @@ =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) + ;; [["lux;VarT" ?id-t]] + ;; (|do [ (&type/deref ?id-t)]) + [_] (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) @@ -229,7 +246,14 @@ (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (matchv ::M/objects [$def] [["lux;MacroD" macro]] - (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))] + (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) + :let [_ (when (and ;; (= "lux/control/monad" ?module) + (= "do" ?name)) + (->> (&/|map &/show-ast macro-expansion) + (&/|interpose "\n") + (&/fold str "") + (prn ?module "do")))] + ] (&/flat-map% (partial analyse exo-type) macro-expansion)) [_] @@ -254,16 +278,26 @@ exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - (matchv ::M/objects [exo-type] - [["lux;LambdaT" [?arg-t ?return-t]]] - (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type))) - - [_] - (fail (str "[Analyser Error] Functions require function types: " - (&type/show-type exo-type))))) + (|do [exo-type* (&type/actual-type exo-type)] + (matchv ::M/objects [exo-type] + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) + ;; (|do [$var &type/existential + ;; exo-type** (&type/apply-type exo-type* $var)] + ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + + [["lux;LambdaT" [?arg-t ?return-t]]] + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body))] + (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) + + [_] + (fail (str "[Analyser Error] Functions require function types: " + (&type/show-type exo-type*)))))) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (matchv ::M/objects [exo-type] @@ -281,6 +315,14 @@ [["lux;ExT" _]] (return (&/T _expr exo-type)) + [["lux;VarT" ?_id]] + (|do [?? (&type/bound? ?_id)] + ;; (return (&/T _expr exo-type)) + (if ?? + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) + (return (&/T _expr exo-type))) + ) + [_] (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) @@ -295,7 +337,7 @@ (return (&/|list output)))) (defn analyse-def [analyse ?name ?value] - (prn 'analyse-def/BEGIN ?name) + ;; (prn 'analyse-def/BEGIN ?name) (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? @@ -306,14 +348,16 @@ (matchv ::M/objects [=value] [[["lux;Global" [?r-module ?r-name]] _]] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) - :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) - _ (println)]] + ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) + ;; _ (println)] + ] (return (&/|list))) [_] (|do [=value-type (&&/expr-type =value) - :let [_ (prn 'analyse-def/END ?name) - _ (println) + :let [;; _ (prn 'analyse-def/END ?name) + _ (println 'DEF (str module-name ";" ?name)) + ;; _ (println) def-data (cond (&type/type= &type/Type =value-type) (&/V "lux;TypeD" nil) @@ -328,23 +372,32 @@ (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) (defn analyse-import [analyse compile-module ?path] - (prn 'analyse-import ?path) - (fn [state] - (let [already-compiled? (&/fold false #(or %1 (= %2 ?path)) (&/get$ &/$SEEN-SOURCES state))] - (&/run-state (|do [_ (&&module/add-import ?path) - _ (if already-compiled? - (return nil) - (compile-module ?path))] - (return (&/|list))) - (if already-compiled? - state - (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state)))))) + (|do [module-name &/get-module-name] + (if (= module-name ?path) + (fail (str "[Analyser Error] Module can't import itself: " ?path)) + (&/save-module + (fn [state] + (let [already-compiled? (&/fold #(or %1 (= %2 ?path)) false (&/get$ &/$SEEN-SOURCES state))] + (prn 'analyse-import module-name ?path already-compiled?) + (&/run-state (|do [_ (&&module/add-import ?path) + _ (if already-compiled? + (return nil) + (compile-module ?path))] + (return (&/|list))) + (if already-compiled? + state + (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state))))))))) (defn analyse-export [analyse name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] (return (&/|list)))) +(defn analyse-alias [analyse ex-alias ex-module] + (|do [module-name &/get-module-name + _ (&&module/alias module-name ex-alias ex-module)] + (return (&/|list)))) + (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index f0e5b82b4..27aa7374c 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,5 +1,6 @@ (ns lux.analyser.module - (:require [clojure.core.match :as M :refer [matchv]] + (:require [clojure.string :as string] + [clojure.core.match :as M :refer [matchv]] clojure.core.match.array (lux [base :as & :refer [|let |do return return* fail fail*]] [type :as &type] @@ -46,13 +47,14 @@ #(&/|put name (&/T false def-data) %) m)) ms))) - (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - (&/update$ &/$MAPPINGS (fn [mappings] - (&/|put (str "" &/+name-separator+ name) - (&/T (&/V "lux;Global" (&/T module name)) type) - mappings)) - locals)) - ?env)))) + ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] + ;; (&/update$ &/$MAPPINGS (fn [mappings] + ;; (&/|put (str "" &/+name-separator+ name) + ;; (&/T (&/V "lux;Global" (&/T module name)) type) + ;; mappings)) + ;; locals)) + ;; ?env))) + ) nil) [_] @@ -93,14 +95,15 @@ #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) m)) ms))) - (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - (&/update$ &/$MAPPINGS (fn [mappings] - (&/|put (str "" &/+name-separator+ a-name) - (&/T (&/V "lux;Global" (&/T r-module r-name)) type) - ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1) - mappings)) - locals)) - ?env)))) + ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] + ;; (&/update$ &/$MAPPINGS (fn [mappings] + ;; (&/|put (str "" &/+name-separator+ a-name) + ;; (&/T (&/V "lux;Global" (&/T r-module r-name)) type) + ;; ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1) + ;; mappings)) + ;; locals)) + ;; ?env))) + ) nil) [_] @@ -112,7 +115,7 @@ (return* state (->> state (&/get$ &/$MODULES) (&/|contains? name))))) -(defn alias-module [module reference alias] +(defn alias [module alias reference] (fn [state] (return* (->> state (&/update$ &/$MODULES @@ -136,23 +139,23 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] + (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? $$def]] - (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) - (if (or exported? (.equals ^Object current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] - (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) - ((find-def ?r-module ?r-name) - state)) - - [_] - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name))))) + (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (matchv ::M/objects [$def] + [[exported? $$def]] + (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) + (if (or exported? (.equals ^Object current-module module)) + (matchv ::M/objects [$$def] + [["lux;AliasD" [?r-module ?r-name]]] + (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) + ((find-def ?r-module ?r-name) + state)) + + [_] + (return* state (&/T (&/T module name) $$def))) + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (do (prn [module name] (str "[Analyser Error] Module doesn't exist: " module) (->> state (&/get$ &/$MODULES) &/|keys &/->seq)) @@ -171,7 +174,7 @@ [[exported? ["lux;ValueD" ?type]]] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str module ".$" (&/normalize-ident name))) + :let [macro (-> (.loadClass loader (str (string/replace module #"/" ".") ".$" (&/normalize-ident name))) (.getField "_datum") (.get nil))]] (fn [state*] @@ -191,9 +194,9 @@ (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) [[_ ["lux;TypeD" _]]] - (fail* (str "[Analyser Error] Definition doesn't have macro type: " module ";" name))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name)))) - (fail* (str "[Analyser Error] Module doesn't exist: " module))))) + (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) + (fail* (str "[Analyser Error] Module does not exist: " module))))) (defn export [module name] (fn [state] @@ -213,7 +216,7 @@ m)) ms)))) nil)) - (fail* (str "[Analyser Error] Can't export an inexistent definition: " module ";" name))) + (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) [_] (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) diff --git a/src/lux/base.clj b/src/lux/base.clj index aecb3fd13..d88bb2ec1 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -483,13 +483,25 @@ ;; "lux;seed" 0 ;; "lux;seen-sources" - (|list) + (|list "lux") ;; "lux;source" (V "lux;None" nil) ;; "lux;types" +init-bindings+ )) +(defn save-module [body] + (fn [state] + (matchv ::M/objects [(body state)] + [["lux;Right" [state* output]]] + (return* (->> state* + (set$ $ENVS (get$ $ENVS state)) + (set$ $SOURCE (get$ $SOURCE state))) + output) + + [["lux;Left" msg]] + (fail* msg)))) + (defn with-eval [body] (fn [state] (matchv ::M/objects [(body (set$ $EVAL? true state))] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 1970c548a..04f4fb4c2 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -342,7 +342,7 @@ .visitEnd))] _ (&&/save-class! (str id) bytecode) loader &/loader] - (-> (.loadClass ^ClassLoader loader (str module "." id)) + (-> (.loadClass ^ClassLoader loader (str (string/replace module #"/" ".") "." id)) (.getField "_eval") (.get nil) return)))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index bc1ab23f1..2a8bdac89 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -146,7 +146,7 @@ compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" ) -(do-template [ ] +(do-template [ ] (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer @@ -162,25 +162,26 @@ $end (new Label) _ (doto *writer* (.visitInsn ) - (.visitJumpInsn $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) (.visitJumpInsn Opcodes/GOTO $end) (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) (.visitLabel $end))]] (return nil))) - compile-jvm-leq Opcodes/LCMP Opcodes/IFEQ "java.lang.Long" "longValue" "()J" - compile-jvm-llt Opcodes/LCMP Opcodes/IFLT "java.lang.Long" "longValue" "()J" - compile-jvm-lgt Opcodes/LCMP Opcodes/IFGT "java.lang.Long" "longValue" "()J" + compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" + compile-jvm-llt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" + compile-jvm-lgt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" - compile-jvm-feq Opcodes/FCMPG Opcodes/IFEQ "java.lang.Float" "floatValue" "()F" - compile-jvm-flt Opcodes/FCMPG Opcodes/IFLT "java.lang.Float" "floatValue" "()F" - compile-jvm-fgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Float" "floatValue" "()F" + compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F" + compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" + compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" - compile-jvm-deq Opcodes/DCMPG Opcodes/IFEQ "java.lang.Double" "doubleValue" "()I" - compile-jvm-dlt Opcodes/DCMPG Opcodes/IFLT "java.lang.Double" "doubleValue" "()I" - compile-jvm-dgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Double" "doubleValue" "()I" + compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I" + compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I" + compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I" ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index ecb614732..7d6b2b502 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -25,6 +25,17 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) +(defn compile-int [compile *type* value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW "java/lang/Long") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (bit-shift-left (long value) 0) + ;; (bit-shift-left (long value) 32) + ) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Long" "" "(J)V"))]] + (return nil))) + (do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer @@ -35,7 +46,7 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] (return nil))) - compile-int "java/lang/Long" "(J)V" long + ;; compile-int "java/lang/Long" "(J)V" long compile-real "java/lang/Double" "(D)V" double compile-char "java/lang/Character" "(C)V" char ) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index a137ca863..fbfe1f757 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -67,8 +67,8 @@ (return (&/V "lux;Meta" (&/T meta (&/V token)))))) ^:private lex-bool "Bool" #"^(true|false)" - ^:private lex-int "Int" #"^-?(0|[1-9][0-9]*)" - ^:private lex-real "Real" #"^-?(0|[1-9][0-9]*)\.[0-9]+" + ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" + ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char @@ -89,14 +89,14 @@ (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] (&/try-all% (&/|list (|do [_ (&reader/read-text ";") - [_ local-token] (&reader/read-regex +ident-re+)] - (&/try-all% (&/|list (|do [unaliased (&module/dealias token)] - (return (&/T meta (&/T unaliased local-token)))) - (|do [? (&module/exists? token)] - (if ? - (return (&/T meta (&/T token local-token))) - (fail (str "[Lexer Error] Unknown module: " token)))) - ))) + [_ local-token] (&reader/read-regex +ident-re+) + ? (&module/exists? token)] + (if ? + (return (&/T meta (&/T token local-token))) + (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) + (&module/dealias token))] + (do ;; (prn "Unaliased: " unaliased ";" local-token) + (return (&/T meta (&/T unaliased local-token))))))) (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") diff --git a/src/lux/type.clj b/src/lux/type.clj index e0315f8e7..e7d6353e8 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -349,16 +349,18 @@ (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) [["lux;VariantT" cases]] - (str "(| " (->> cases - (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k ["Tuple" ["Nil" _]]]] - (str "#" k) - - [[k v]] - (str "(#" k " " (show-type v) ")")))) - (&/|interpose " ") - (&/fold str "")) ")") + (if (&/|empty? cases) + "(|)" + (str "(| " (->> cases + (&/|map (fn [kv] + (matchv ::M/objects [kv] + [[k ["lux;TupleT" ["lux;Nil" _]]]] + (str "#" k) + + [[k v]] + (str "(#" k " " (show-type v) ")")))) + (&/|interpose " ") + (&/fold str "")) ")")) [["lux;RecordT" fields]] @@ -485,7 +487,9 @@ (&/|cons (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] - (str "Type " (show-type expected) " does not subsume type " (show-type actual))) + (str "[Type Checker]\nExpected: " (show-type expected) + "\n\nActual: " (show-type actual) + "\n")) (defn beta-reduce [env type] (matchv ::M/objects [type] @@ -555,7 +559,7 @@ (apply-type type-fn* param)) [_] - (fail (str "[Type System] Can't apply type function " (show-type type-fn) " to type " (show-type param))))) + (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) (def init-fixpoints (&/|list)) @@ -826,10 +830,10 @@ [["lux;ExT" e!id] ["lux;ExT" a!id]] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) - (check-error expected actual)) + (fail (check-error expected actual))) [_ _] - (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual))) + (fail (check-error expected actual)) ))) (defn check [expected actual] @@ -850,7 +854,7 @@ (clean $var =return)))) [_] - (fail (str "[Type System] Can't apply type " (show-type func) " to type " (show-type param))) + (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] @@ -859,6 +863,9 @@ (|do [type* (apply-type ?all ?param)] (actual-type type*)) + [["lux;VarT" ?id]] + (deref ?id) + [_] (return type) )) -- cgit v1.2.3