aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lux/analyser.clj4
-rw-r--r--src/lux/analyser/case.clj65
-rw-r--r--src/lux/analyser/env.clj2
-rw-r--r--src/lux/analyser/host.clj46
-rw-r--r--src/lux/analyser/lux.clj165
-rw-r--r--src/lux/analyser/module.clj33
-rw-r--r--src/lux/base.clj4
-rw-r--r--src/lux/compiler.clj11
-rw-r--r--src/lux/compiler/cache.clj166
-rw-r--r--src/lux/compiler/host.clj69
-rw-r--r--src/lux/compiler/io.clj1
-rw-r--r--src/lux/compiler/lambda.clj1
-rw-r--r--src/lux/compiler/lux.clj13
-rw-r--r--src/lux/host.clj1
-rw-r--r--src/lux/lexer.clj6
-rw-r--r--src/lux/packager/program.clj6
-rw-r--r--src/lux/type.clj65
-rw-r--r--src/lux/type/host.clj19
18 files changed, 199 insertions, 478 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 0b911f9ed..4ead47916 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -694,7 +694,6 @@
))))
(defn ^:private analyse-ast [eval! compile-module compile-token exo-type token]
- ;; (prn 'analyse-ast (&/show-ast token))
(|let [[cursor _] token]
(&/with-cursor cursor
(&/with-expected-type exo-type
@@ -709,8 +708,7 @@
(fn [state]
(|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state)
(&/$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 compile-token) exo-type meta =fn ?args) state*))
+ ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)
_
((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state)))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 325b6cdd8..9640cf88a 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -62,7 +62,6 @@
(defn adjust-type* [up type]
"(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))"
- ;; (prn 'adjust-type* (&type/show-type type))
(|case type
(&/$UnivQ _aenv _abody)
(&type/with-var
@@ -159,63 +158,47 @@
(&/$TupleS ?members)
(|do [value-type* (adjust-type value-type)]
- (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*))
- (|case value-type*
- (&/$TupleT ?member-types)
- (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members))
- (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members)))
- (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]"))
- (|do [[=tests =kont] (&/fold (fn [kont* vm]
- (|let [[v m] vm]
- (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)]
- (return (&/T (&/Cons$ =test =tests) =kont)))))
- (|do [=kont kont]
- (return (&/T &/Nil$ =kont)))
- (&/|reverse (&/zip2 ?member-types ?members)))]
- (return (&/T (&/V $TupleTestAC =tests) =kont)))))
+ (|case value-type*
+ (&/$TupleT ?member-types)
+ (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members)))
+ (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]"))
+ (|do [[=tests =kont] (&/fold (fn [kont* vm]
+ (|let [[v m] vm]
+ (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)]
+ (return (&/T (&/Cons$ =test =tests) =kont)))))
+ (|do [=kont kont]
+ (return (&/T &/Nil$ =kont)))
+ (&/|reverse (&/zip2 ?member-types ?members)))]
+ (return (&/T (&/V $TupleTestAC =tests) =kont))))
- _
- (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*))))))
+ _
+ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))
(&/$RecordS pairs)
(|do [[rec-members rec-type] (&&record/order-record pairs)]
(analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont))
(&/$TagS ?ident)
- (|do [;; :let [_ (println "#00" (&/ident->text ?ident))]
- [=module =name] (&&/resolved-ident ?ident)
- ;; :let [_ (println "#01")]
+ (|do [[=module =name] (&&/resolved-ident ?ident)
value-type* (adjust-type value-type)
- ;; :let [_ (println "#02")]
idx (&module/tag-index =module =name)
group (&module/tag-group =module =name)
- ;; :let [_ (println "#03")]
case-type (&type/variant-case idx value-type*)
- ;; :let [_ (println "#04")]
- [=test =kont] (analyse-pattern case-type unit kont)
- ;; :let [_ (println "#05")]
- ]
+ [=test =kont] (analyse-pattern case-type unit kont)]
(return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont)))
(&/$FormS (&/$Cons [_ (&/$TagS ?ident)]
?values))
- (|do [;; :let [_ (println "#10" (&/ident->text ?ident))]
- [=module =name] (&&/resolved-ident ?ident)
- ;; :let [_ (println "#11")]
+ (|do [[=module =name] (&&/resolved-ident ?ident)
value-type* (adjust-type value-type)
- ;; :let [_ (println "#12" (&type/show-type value-type*))]
idx (&module/tag-index =module =name)
group (&module/tag-group =module =name)
- ;; :let [_ (println "#13")]
case-type (&type/variant-case idx value-type*)
- ;; :let [_ (println "#14" (&type/show-type case-type))]
[=test =kont] (case (int (&/|length ?values))
0 (analyse-pattern case-type unit kont)
1 (analyse-pattern case-type (&/|head ?values) kont)
;; 1+
- (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont))
- ;; :let [_ (println "#15")]
- ]
+ (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont))]
(return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont)))
_
@@ -319,7 +302,6 @@
(return (&/T =output =type)))))))
(defn ^:private check-totality [value-type struct]
- ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct))
(|case struct
($DefaultTotal ?total)
(return ?total)
@@ -371,20 +353,11 @@
(|do [value-type* (resolve-type value-type)]
(|case value-type*
(&/$VariantT ?members)
- (|do [totals (&/map2% (fn [sub-struct ?member]
- ;; (prn '$VariantTotal
- ;; (&/adt->text sub-struct)
- ;; (&type/show-type ?member))
- (check-totality ?member sub-struct))
- ?structs ?members)]
+ (|do [totals (&/map2% check-totality ?members ?structs)]
(return (&/fold #(and %1 %2) true totals)))
_
(fail "[Pattern-maching Error] Variant is not total."))))
-
- ;; _
- ;; (assert false (prn-str 'check-totality (&type/show-type value-type)
- ;; (&/adt->text struct)))
))
;; [Exports]
diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj
index a7ce52c1f..81397a3f6 100644
--- a/src/lux/analyser/env.clj
+++ b/src/lux/analyser/env.clj
@@ -15,9 +15,7 @@
(return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter)))))
(defn with-local [name type body]
- ;; (prn 'with-local name)
(fn [state]
- ;; (prn 'with-local name)
(let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings))
=return (body (&/update$ &/$envs
(fn [stack]
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 9a38022d8..33553985b 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -45,28 +45,22 @@
now)))
nil
exceptions)]
- (assert false (str "[Analyser Error] Unhandled exception: " missing-ex))
- ;; (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex))
+ (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex))
(&/return* state nil)))
)))
(defn ^:private with-catches [catches body]
"(All [a] (-> (List Text) (Lux a) (Lux a)))"
(fn [state]
- (let [;; _ (prn 'with-catches/_0 (&/->seq catches))
- old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching))
- ;; _ (prn 'with-catches/_1 (&/->seq (->> state (&/get$ &/$host) (&/get$ &/$catching))))
- state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))
- ;; _ (prn 'with-catches/_2 (&/->seq (->> state* (&/get$ &/$host) (&/get$ &/$catching))))
- ]
+ (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching))
+ state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))]
(|case (&/run-state body state*)
(&/$Left msg)
(&/V &/$Left msg)
(&/$Right state** output)
- (do ;; (prn 'with-catches/_3 (&/->seq (->> state** (&/get$ &/$host) (&/get$ &/$catching))))
- (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %)))
- output)))))
+ (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %)))
+ output))))
))
(defn ^:private ensure-object [type]
@@ -219,7 +213,6 @@
(defn analyse-jvm-getstatic [analyse exo-type class field]
(|do [class-loader &/loader
[gvars gtype] (&host/lookup-static-field class-loader class field)
- ;; :let [_ (prn 'analyse-jvm-getstatic class field (&/->seq gvars) gtype)]
:let [=type (&host-type/class->type (cast Class gtype))]
:let [output-type =type]
_ (&type/check exo-type output-type)
@@ -294,7 +287,6 @@
[gret exceptions parent-gvars gvars gargs] (if (= "<init>" method)
(return (&/T Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$))
(&host/lookup-virtual-method class-loader class method classes))
- ;; :let [_ (prn '<name> [class method] (&/adt->text =return+exceptions))]
_ (ensure-catching exceptions)
=object (&&/analyse-1+ analyse object)
[sub-class sub-params] (ensure-object (&&/expr-type* =object))
@@ -304,8 +296,6 @@
parent-gvars
super-params*)]
[output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args)
- ;; :let [_ (prn '<name> [class method] (&type/show-type exo-type) (&type/show-type output-type))]
- ;; :let [_ (prn '<name> '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))]
_ (&type/check exo-type (as-otype+ output-type))
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
@@ -319,11 +309,7 @@
(defn analyse-jvm-invokestatic [analyse exo-type class method classes args]
(|do [class-loader &/loader
[gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes)
- ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))]
_ (ensure-catching exceptions)
- ;; :let [_ (matchv ::M/objects [=return]
- ;; [[&/$DataT _return-class &/Nil$]]
- ;; (prn 'analyse-jvm-invokestatic class method _return-class))]
=args (&/map2% (fn [_class _arg]
(&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg))
classes
@@ -354,9 +340,6 @@
(|case gtype-vars
(&/$Nil)
(|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args)
- ;; :let [_ (prn 'analyse-jvm-new-helper/_0 gtype)
- ;; _ (prn 'analyse-jvm-new-helper/_1 gtype (->> arg-types (&/|map &type/show-type) &/->seq))
- ;; _ (prn 'analyse-jvm-new-helper/_2 gtype (->> args (&/|map &/show-ast) &/->seq))]
=args (&/map2% (partial &&/analyse-1 analyse) arg-types args)
gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))]
(return (&/T (make-gtype gtype gtype-vars*)
@@ -365,7 +348,6 @@
(&/$Cons ^TypeVariable gtv gtype-vars*)
(&type/with-var
(fn [$var]
- ;; (prn 'analyse-jvm-new-helper gtype gtv $var (&/|length gtype-vars) (&/|length gtype-args))
(|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)]
(analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args))))
))
@@ -373,10 +355,8 @@
(defn analyse-jvm-new [analyse exo-type class classes args]
(|do [class-loader &/loader
[exceptions gvars gargs] (&host/lookup-constructor class-loader class classes)
- ;; :let [_ (prn 'analyse-jvm-new class (&/->seq gvars) (&/->seq gargs))]
_ (ensure-catching exceptions)
[output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args)
- ;; :let [_ (prn 'analyse-jvm-new/POST class (->> classes &/->seq vec) (&type/show-type output-type))]
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
@@ -713,39 +693,27 @@
captured-slot-type "java.lang.Object"]
(defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods]
(&/with-closure
- (|do [;; :let [_ (prn 'analyse-jvm-anon-class/_0 super-class)]
- module &/get-module-name
+ (|do [module &/get-module-name
scope &/get-scope-name
- ;; :let [_ (prn 'analyse-jvm-anon-class/_1 super-class)]
:let [name (&host/location (&/|tail scope))
anon-class (str module "." name)]
- ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)]
=method-descs (&/map% dummy-method-desc methods)
_ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs)
=methods (&/map% (partial analyse-method analyse anon-class) methods)
- ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)]
_ (check-method-completion (&/Cons$ super-class interfaces) =methods)
- ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)]
=captured &&env/captured-vars
:let [=fields (&/|map (fn [^objects idx+capt]
{:name (str &c!base/closure-prefix (aget idx+capt 0))
:modifiers captured-slot-modifier
:anns (&/|list)
:type captured-slot-type})
- (&/enumerate =captured))
- ;; _ (prn '=methods (&/adt->text (&/|map :body =methods)))
- ;; =methods* (rename-captured-vars)
- ]
+ (&/enumerate =captured))]
:let [sources (&/|map captured-source =captured)]
- ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)]
- ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type))
_ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured)))
- ;; :let [_ (println 'DEF anon-class)]
_cursor &/cursor]
(return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor
(&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources))
)))
- ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)
))))
(defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally]
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 9dd8cecdc..e938fa343 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -45,8 +45,7 @@
(defn analyse-tuple [analyse ?exo-type ?elems]
(|case ?exo-type
(&/$Left exo-type)
- (|do [;; :let [_ (println 'analyse-tuple/$Left (&type/show-type exo-type))]
- exo-type* (&type/actual-type exo-type)]
+ (|do [exo-type* (&type/actual-type exo-type)]
(|case exo-type*
(&/$UnivQ _)
(&type/with-var
@@ -100,7 +99,6 @@
_
(fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]"))
- ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]"))
))))))
(defn with-attempt [m-value on-error]
@@ -127,10 +125,6 @@
(fail (str err "\n"
'analyse-variant-body " " (&type/show-type exo-type)
" " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
- ;; (assert false
- ;; (str err "\n"
- ;; 'analyse-variant-body " " (&type/show-type exo-type)
- ;; " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
))]
(|case output
(&/$Cons x (&/$Nil))
@@ -142,20 +136,14 @@
(defn analyse-variant [analyse ?exo-type idx ?values]
(|case ?exo-type
(&/$Left exo-type)
- (|do [;; :let [_ (println 'analyse-variant/Left 0 (&type/show-type exo-type))]
- exo-type* (&type/actual-type exo-type)
- ;; :let [_ (println 'analyse-variant/Left 1 (&type/show-type exo-type*))]
- ]
+ (|do [exo-type* (&type/actual-type exo-type)]
(|case exo-type*
(&/$UnivQ _)
(&type/with-var
(fn [$var]
(|do [exo-type** (&type/apply-type exo-type* $var)
- ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))]
[[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values))
- ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))]
=var (&type/resolve-type $var)
- ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))]
inferred-type (|case =var
(&/$VarT iid)
(|do [:let [=var* (next-bound-type variant-type)]
@@ -164,9 +152,7 @@
(return (&type/Univ$ &/Nil$ variant-type*)))
_
- (&type/clean $var variant-type))
- ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))]
- ]
+ (&type/clean $var variant-type))]
(return (&/|list (&&/|meta inferred-type variant-cursor
variant-analysis))))))
@@ -174,9 +160,7 @@
(analyse-variant analyse (&/V &/$Right exo-type*) idx ?values)))
(&/$Right exo-type)
- ;; [_ exo-type]
- (|do [;; :let [_ (println 'analyse-variant/Right 0 (&type/show-type exo-type))]
- exo-type* (|case exo-type
+ (|do [exo-type* (|case exo-type
(&/$VarT ?id)
(&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
(&type/actual-type exo-type*))
@@ -230,8 +214,6 @@
(defn ^:private analyse-global [analyse exo-type module name]
(|do [[[r-module r-name] $def] (&&module/find-def module name)
- ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)]
- ;; :let [_ (prn 'analyse-global/$def (aget $def 0))]
endo-type (|case $def
(&/$ValueD ?type _)
(return ?type)
@@ -263,52 +245,48 @@
state)
(&/$Cons ?genv (&/$Nil))
- (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq))
- (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))]
- (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0))
- (|case global
- [(&/$Global ?module* name*) _]
- ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*)
- ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)]
- endo-type (|case $def
- (&/$ValueD ?type _)
- (return ?type)
-
- (&/$MacroD _)
- (return &type/Macro)
-
- (&/$TypeD _)
- (return &type/Type))
- _ (if (and (clojure.lang.Util/identical &type/Type endo-type)
- (clojure.lang.Util/identical &type/Type exo-type))
- (return nil)
- (&type/check exo-type endo-type))
- _cursor &/cursor]
- (return (&/|list (&&/|meta endo-type _cursor
- (&/V &&/$var (&/V &/$Global (&/T r-module r-name)))
- ))))
- state)
+ (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))]
+ (|case global
+ [(&/$Global ?module* name*) _]
+ ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*)
+ endo-type (|case $def
+ (&/$ValueD ?type _)
+ (return ?type)
+
+ (&/$MacroD _)
+ (return &type/Macro)
+
+ (&/$TypeD _)
+ (return &type/Type))
+ _ (if (and (clojure.lang.Util/identical &type/Type endo-type)
+ (clojure.lang.Util/identical &type/Type exo-type))
+ (return nil)
+ (&type/check exo-type endo-type))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta endo-type _cursor
+ (&/V &&/$var (&/V &/$Global (&/T r-module r-name)))
+ ))))
+ state)
- _
- (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))
- (fail* "")))
+ _
+ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))
+ (fail* ""))
(&/$Cons top-outer _)
- (do ;; (prn 'analyse-symbol/_3 ?module name)
- (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1)
- (&/|map #(&/get$ &/$name %) outer)
- (&/|reverse inner)))
- [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope]
- (|let [[register new-inner] register+new-inner
- [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)]
- (&/T register* (&/Cons$ frame* new-inner))))
- (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))
- (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name)))
- &/Nil$)
- (&/|reverse inner) scopes)]
- ((|do [_ (&type/check exo-type (&&/expr-type* =local))]
- (return (&/|list =local)))
- (&/set$ &/$envs (&/|++ inner* outer) state))))
+ (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1)
+ (&/|map #(&/get$ &/$name %) outer)
+ (&/|reverse inner)))
+ [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope]
+ (|let [[register new-inner] register+new-inner
+ [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)]
+ (&/T register* (&/Cons$ frame* new-inner))))
+ (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))
+ (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name)))
+ &/Nil$)
+ (&/|reverse inner) scopes)]
+ ((|do [_ (&type/check exo-type (&&/expr-type* =local))]
+ (return (&/|list =local)))
+ (&/set$ &/$envs (&/|++ inner* outer) state)))
))))
(defn analyse-symbol [analyse exo-type ident]
@@ -319,22 +297,15 @@
))
(defn ^:private analyse-apply* [analyse exo-type fun-type ?args]
- ;; (prn 'analyse-apply* (aget fun-type 0))
(|case ?args
(&/$Nil)
- (|do [;; :let [_ (prn 'analyse-apply*/_0 (&type/show-type exo-type) (&type/show-type fun-type))]
- _ (&type/check exo-type fun-type)
- ;; :let [_ (prn 'analyse-apply*/_1 'SUCCESS (str "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))]
- ]
+ (|do [_ (&type/check exo-type fun-type)]
(return (&/T fun-type &/Nil$)))
(&/$Cons ?arg ?args*)
(|do [?fun-type* (&type/actual-type fun-type)]
(|case ?fun-type*
(&/$UnivQ _)
- ;; (|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)
@@ -359,9 +330,6 @@
" " "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))))]
(return (&/T =output-t (&/Cons$ =arg =args))))
- ;; [[&/$VarT ?id-t]]
- ;; (|do [ (&type/deref ?id-t)])
-
_
(fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))))
))
@@ -374,9 +342,7 @@
(|do [[real-name $def] (&&module/find-def ?module ?name)]
(|case $def
(&/$MacroD macro)
- (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))]
- macro-expansion #(-> macro (.apply ?args) (.apply %))
- ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))]
+ (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))
;; :let [_ (when (or (= "do" (aget real-name 1))
;; ;; (= "..?" (aget real-name 1))
;; ;; (= "try$" (aget real-name 1))
@@ -494,11 +460,7 @@
(return (&/|list output))))
(defn analyse-def [analyse compile-token ?name ?value]
- ;; (prn 'analyse-def/BEGIN ?name)
- ;; (when (= "monoid$" ?name)
- ;; (reset! &type/!flag true))
(|do [module-name &/get-module-name
- ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))]
? (&&module/defined? module-name ?name)]
(if ?
(fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
@@ -506,55 +468,36 @@
(&&/analyse-1+ analyse ?value))]
(|case =value
[_ (&&/$var (&/$Global ?r-module ?r-name))]
- (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))
- ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name))
- ;; _ (println)]
- ]
+ (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))]
(return &/Nil$))
_
- (do ;; (println 'DEF (str module-name ";" ?name))
- (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
- ;; _ (if (and (= "lux" module-name)
- ;; (= "Type" ?name))
- ;; (|do [newly-defined-Type
- ;; :let [_ (&type/redefine-type! newly-defined-Type)]]
- ;; (return nil))
- ;; (return nil))
- :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name))
- [[def-type def-cursor] def-analysis] =value
- _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type)
- )]]
- (return &/Nil$))))
+ (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
+ :let [[[def-type def-cursor] def-analysis] =value
+ _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type)
+ )]]
+ (return &/Nil$)))
))))
(defn analyse-declare-macro [analyse compile-token ?name]
- (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")]
- module-name &/get-module-name
- ;; :let [_ (prn 'analyse-declare-macro ?name "1")]
- _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))
- ;; :let [_ (prn 'analyse-declare-macro ?name "2")]
- ]
+ (|do [module-name &/get-module-name
+ _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))]
(return &/Nil$)))
(defn analyse-declare-tags [tags type-name]
(|do [module-name &/get-module-name
- ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))]
[_ def-data] (&&module/find-def module-name type-name)
- ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))]
def-type (&&module/ensure-type-def def-data)
_ (&&module/declare-tags module-name tags def-type)]
(return &/Nil$)))
(defn analyse-import [analyse compile-module compile-token path]
- ;; (prn 'analyse-import path)
(|do [module-name &/get-module-name
_ (if (= module-name path)
(fail (str "[Analyser Error] Module can't import itself: " path))
(return nil))]
(&/save-module
(|do [already-compiled? (&&module/exists? path)
- ;; :let [_ (prn 'analyse-import module-name path already-compiled?)]
active? (&/active-module? path)
_ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name))
_ (&&module/add-import path)
@@ -576,10 +519,8 @@
(defn analyse-check [analyse eval! exo-type ?type ?value]
(|do [=type (&&/analyse-1 analyse &type/Type ?type)
==type (eval! =type)
- ;; :let [_ (prn 'analyse-check/_0 (&type/show-type ==type))]
_ (&type/check exo-type ==type)
=value (&&/analyse-1 analyse ==type ?value)
- ;; :let [_ (prn 'analyse-check/_1 (&/adt->text =value))]
_cursor &/cursor
]
(return (&/|list (&&/|meta ==type _cursor
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index c645a9566..192e80153 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -60,7 +60,6 @@
nil))))
(defn define [module name ^objects def-data type]
- ;; (prn 'define module name (aget def-data 0) (&type/show-type type))
(fn [state]
(when (and (= "Macro" name) (= "lux" module))
(&type/set-macro-type! (aget def-data 1)))
@@ -116,7 +115,6 @@
(fail* (str "[Analyser Error] Unknown module: " module)))))
(defn def-alias [a-module a-name r-module r-name type]
- ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type))
(fn [state]
(|case (&/get$ &/$envs state)
(&/$Cons ?env (&/$Nil))
@@ -165,23 +163,19 @@
(defn find-def [module name]
(|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))]
- (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module)))
- (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
- (|let [[exported? $$def] $def]
- (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module))
- (if (or exported? (.equals ^Object current-module module))
- (|case $$def
- (&/$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)))))
+ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
+ (|let [[exported? $$def] $def]
+ (if (or exported? (.equals ^Object current-module module))
+ (|case $$def
+ (&/$AliasD ?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))))
(fail* (str "[Analyser Error] Module doesn't exist: " module))))))
(defn ensure-type-def [def-data]
@@ -321,8 +315,7 @@
(defn declare-tags [module tag-names type]
"(-> Text (List Text) Type (Lux (,)))"
- (|do [;; :let [_ (prn 'declare-tags module (&/->seq tag-names) (&type/show-type type))]
- _ (ensure-undeclared-tags module tag-names)
+ (|do [_ (ensure-undeclared-tags module tag-names)
type-name (&type/type-name type)
:let [[_module _name] type-name]
_ (&/assert! (= module _module)
diff --git a/src/lux/base.clj b/src/lux/base.clj
index d76348b9a..7357bd483 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -217,9 +217,6 @@
(if (.equals ^Object k slot)
(V $Cons (T (T slot value) table*))
(V $Cons (T (T k v) (|put slot value table*))))
-
- ;; _
- ;; (assert false (prn-str '|put (aget table 0)))
))
(defn |remove [slot table]
@@ -801,7 +798,6 @@
(return* state (get$ $cursor state))))
(defn show-ast [ast]
- ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0))
(|case ast
[_ ($BoolS ?value)]
(pr-str ?value)
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 76d3a1eb2..3052ead09 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -38,7 +38,6 @@
(def ^:private !source->last-line (atom nil))
(defn ^:private compile-expression [syntax]
- ;; (prn 'compile-expression (&/adt->text syntax))
(|let [[[?type [_file-name _line _column]] ?form] syntax]
(|do [^MethodVisitor *writer* &/get-writer
:let [debug-label (new Label)
@@ -52,8 +51,7 @@
(&&lux/compile-bool compile-expression ?value)
(&a/$int ?value)
- (do ;; (prn 'compile-expression (&/adt->text syntax))
- (&&lux/compile-int compile-expression ?value))
+ (&&lux/compile-int compile-expression ?value)
(&a/$real ?value)
(&&lux/compile-real compile-expression ?value)
@@ -445,7 +443,6 @@
id &/gen-id
[file-name _ _] &/cursor
:let [class-name (str (&host/->module-class module) "/" id)
- ;; _ (prn 'eval! id class-name)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
class-name nil "java/lang/Object" nil)
@@ -472,7 +469,6 @@
return))))
(defn ^:private compile-module [name]
- ;; (prn 'compile-module name (&&cache/cached? name))
(let [file-name (str name ".lux")]
(|do [file-content (&&io/read-file file-name)
:let [file-hash (hash file-content)]]
@@ -492,9 +488,7 @@
.visitEnd)
(-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version)
.visitEnd)
- (.visitSource file-name nil))
- ;; _ (prn 'compile-module name =class)
- ]]
+ (.visitSource file-name nil))]]
(fn [state]
(|case ((&/with-writer =class
(&/exhaust% compiler-step))
@@ -529,7 +523,6 @@
(&/fold str "")))
.visitEnd)
(.visitEnd))
- ;; _ (prn 'CLOSED name =class)
]
_ (&/flag-compiled-module name)]
(&&/save-class! &/module-class-name (.toByteArray =class)))
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
index f1b21f6fd..a35225acf 100644
--- a/src/lux/compiler/cache.clj
+++ b/src/lux/compiler/cache.clj
@@ -72,94 +72,78 @@
:let [redo-cache (|do [_ (delete module)
_ (compile-module module)]
(return false))]]
- (do ;; (prn 'load module 'sources already-loaded?
- ;; (&/->seq _modules))
- (if already-loaded?
- (return true)
- (if (cached? module)
- (do ;; (prn 'load/HASH module module-hash)
- (let [module* (&host/->class-name module)
- module-path (str &&/output-dir module)
- class-name (str module* "._")
- ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class"))))
- (&&/load-class! loader class-name))]
- (if (and (= module-hash (get-field &/hash-field module-meta))
- (= &&/version (get-field &/compiler-field module-meta)))
- (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator)))
- ;; _ (prn 'load/IMPORTS module imports)
- ]
- (|do [loads (&/map% (fn [_import]
- (|do [content (&&io/read-file (str _import ".lux"))
- _ (load _import (hash content) compile-module)]
- (&/cached-module? _import)))
- (if (= [""] imports)
- &/Nil$
- (&/->list imports)))]
- (if (->> loads &/->seq (every? true?))
- (do (doseq [^File file (seq (.listFiles (File. module-path)))
- :when (not (.isDirectory file))
- :let [file-name (.getName file)]
- :when (not= "_.class" file-name)]
- (let [real-name (second (re-find #"^(.*)\.class$" file-name))
- bytecode (read-file file)
- ;; _ (prn 'load module real-name)
- ]
- (swap! !classes assoc (str module* "." real-name) bytecode)))
- (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator)))
- ;; _ (prn module '(get-field &/tags-field module-meta)
- ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))))
- tag-groups (let [all-tags (get-field &/tags-field module-meta)]
- (if (= "" all-tags)
- &/Nil$
- (-> all-tags
- (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))
- (->> (map (fn [_group]
- ;; (prn '_group _group)
- (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))]
- ;; (prn '[_type _tags] [_type _tags])
- (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator)))))))))
- &/->list)))]
- ;; (prn 'load module defs)
- (|do [_ (&a-module/enter-module module)
- _ (&/flag-cached-module module)
- _ (&a-module/set-imports imports)
- _ (&/map% (fn [_def]
- (let [[_exported? _name _ann] (string/split _def #" ")
- ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann])
- ]
- (|do [_ (case _ann
- "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
- def-value (get-field &/datum-field def-class)]
- (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type))
- "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
- def-value (get-field &/datum-field def-class)]
- (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)]
- (&a-module/declare-macro module _name)))
- "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
- ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class)
- def-meta (get-field &/meta-field def-class)]
- (|case def-meta
- (&/$ValueD def-type _)
- (&a-module/define module _name def-meta def-type)))
- ;; else
- (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)]
- (|do [__type (&a-module/def-type __module __name)]
- (do ;; (prn '__type [__module __name] (&type/show-type __type))
- (&a-module/def-alias module _name __module __name __type)))))]
- (if (= &&/exported-true _exported?)
- (&a-module/export module _name)
- (return nil)))
- ))
- (if (= [""] defs)
- &/Nil$
- (&/->list defs)))
- _ (&/map% (fn [group]
- (|let [[_type _tags] group]
- (|do [=type (&a-module/type-def module _type)]
- (&a-module/declare-tags module _tags =type))))
- tag-groups)]
- (return true))))
- redo-cache)))
- redo-cache)
- ))
- redo-cache)))))
+ (if already-loaded?
+ (return true)
+ (if (cached? module)
+ (let [module* (&host/->class-name module)
+ module-path (str &&/output-dir module)
+ class-name (str module* "._")
+ ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class"))))
+ (&&/load-class! loader class-name))]
+ (if (and (= module-hash (get-field &/hash-field module-meta))
+ (= &&/version (get-field &/compiler-field module-meta)))
+ (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator)))]
+ (|do [loads (&/map% (fn [_import]
+ (|do [content (&&io/read-file (str _import ".lux"))
+ _ (load _import (hash content) compile-module)]
+ (&/cached-module? _import)))
+ (if (= [""] imports)
+ &/Nil$
+ (&/->list imports)))]
+ (if (->> loads &/->seq (every? true?))
+ (do (doseq [^File file (seq (.listFiles (File. module-path)))
+ :when (not (.isDirectory file))
+ :let [file-name (.getName file)]
+ :when (not= "_.class" file-name)]
+ (let [real-name (second (re-find #"^(.*)\.class$" file-name))
+ bytecode (read-file file)]
+ (swap! !classes assoc (str module* "." real-name) bytecode)))
+ (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator)))
+ tag-groups (let [all-tags (get-field &/tags-field module-meta)]
+ (if (= "" all-tags)
+ &/Nil$
+ (-> all-tags
+ (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))
+ (->> (map (fn [_group]
+ (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))]
+ (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator)))))))))
+ &/->list)))]
+ (|do [_ (&a-module/enter-module module)
+ _ (&/flag-cached-module module)
+ _ (&a-module/set-imports imports)
+ _ (&/map% (fn [_def]
+ (let [[_exported? _name _ann] (string/split _def #" ")]
+ (|do [_ (case _ann
+ "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
+ def-value (get-field &/datum-field def-class)]
+ (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type))
+ "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
+ def-value (get-field &/datum-field def-class)]
+ (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)]
+ (&a-module/declare-macro module _name)))
+ "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
+ def-meta (get-field &/meta-field def-class)]
+ (|case def-meta
+ (&/$ValueD def-type _)
+ (&a-module/define module _name def-meta def-type)))
+ ;; else
+ (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)]
+ (|do [__type (&a-module/def-type __module __name)]
+ (&a-module/def-alias module _name __module __name __type))))]
+ (if (= &&/exported-true _exported?)
+ (&a-module/export module _name)
+ (return nil)))
+ ))
+ (if (= [""] defs)
+ &/Nil$
+ (&/->list defs)))
+ _ (&/map% (fn [group]
+ (|let [[_type _tags] group]
+ (|do [=type (&a-module/type-def module _type)]
+ (&a-module/declare-tags module _tags =type))))
+ tag-groups)]
+ (return true))))
+ redo-cache)))
+ redo-cache)
+ )
+ redo-cache))))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 6d926e6da..c364091ba 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -220,7 +220,8 @@
^MethodVisitor *writer* &/get-writer
:let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))]
_ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)]
+ :let [_ (when (not= "<init>" ?method)
+ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))]
_ (&/map2% (fn [class-name arg]
(|do [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
@@ -233,27 +234,9 @@
compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL
compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE
- ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL
+ compile-jvm-invokespecial Opcodes/INVOKESPECIAL
)
-(defn compile-jvm-invokespecial [compile ?class ?method ?classes ?object ?args ?output-type]
- (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))]
- ^MethodVisitor *writer* &/get-writer
- :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))]
- _ (compile ?object)
- ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)]
- :let [_ (when (not= "<init>" ?method)
- (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))]
- _ (&/map2% (fn [class-name arg]
- (|do [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- ?classes ?args)
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig)
- (prepare-return! ?output-type))]]
- (return nil)))
-
(defn compile-jvm-null [compile]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
@@ -422,10 +405,10 @@
(defn ^:private compile-annotation [writer ann]
(doto ^AnnotationVisitor (.visitAnnotation writer (&host/->class (:name ann)) true)
- (-> (.visit param-name param-value)
- (->> (|let [[param-name param-value] param])
- (doseq [param (&/->seq (:params ann))])))
- (.visitEnd))
+ (-> (.visit param-name param-value)
+ (->> (|let [[param-name param-value] param])
+ (doseq [param (&/->seq (:params ann))])))
+ (.visitEnd))
nil)
(defn ^:private compile-field [^ClassWriter writer field]
@@ -466,10 +449,6 @@
(.visitInsn writer Opcodes/ARETURN)))
(defn ^:private compile-method [compile ^ClassWriter class-writer method]
- ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body))
- ;; (prn 'compile-method/_1 (&/adt->text (:inputs method)))
- ;; (prn 'compile-method/_2 (&/adt->text (:output method)))
- ;; (prn 'compile-method/_3 (&/adt->text (:body method)))
(|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")"
(&host/->type-signature (:output method)))]
(&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method))
@@ -518,9 +497,7 @@
)
(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env]
- (|do [;; :let [_ (prn 'compile-jvm-class/_0)]
- module &/get-module-name
- ;; :let [_ (prn 'compile-jvm-class/_1)]
+ (|do [module &/get-module-name
[file-name _ _] &/cursor
:let [full-name (str module "/" ?name)
super-class* (&host/->class ?super-class)
@@ -531,17 +508,12 @@
_ (&/|map (partial compile-annotation =class) ?anns)
_ (&/|map (partial compile-field =class)
?fields)]
- ;; :let [_ (prn 'compile-jvm-class/_2)]
_ (&/map% (partial compile-method compile =class) ?methods)
- ;; :let [_ (prn 'compile-jvm-class/_3)]
:let [_ (when env
- (add-anon-class-<init> =class full-name env))]
- ;; :let [_ (prn 'compile-jvm-class/_4)]
- ]
+ (add-anon-class-<init> =class full-name env))]]
(&&/save-class! ?name (.toByteArray (doto =class .visitEnd)))))
(defn compile-jvm-interface [compile ?name ?supers ?anns ?methods]
- ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str))
(|do [module &/get-module-name
[file-name _ _] &/cursor]
(let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
@@ -571,9 +543,7 @@
(return nil)))
catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)])
?catches)
- _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)
- ;; :let [_ (prn 'HANDLER ?ex-class (&host/->class ?ex-class) $handler-start $handler-end $from $to $catch-finally)]
- ]
+ _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)]
(doto *writer*
(.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class))
(.visitTryCatchBlock $handler-start $handler-end $catch-finally nil)))
@@ -591,7 +561,6 @@
compile-finally))
?catches
catch-boundaries)
- ;; :let [_ (prn 'handlers (&/->seq handlers))]
:let [_ (.visitLabel *writer* $catch-finally)]
_ (|case ?finally
(&/$Some ?finally*) (|do [_ (compile ?finally*)
@@ -694,16 +663,12 @@
(defn compile-jvm-program [compile ?body]
(|do [module-name &/get-module-name
- ;; :let [_ (prn 'compile-jvm-program module-name)]
^ClassWriter *writer* &/get-writer]
(&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil)
(.visitCode))
(|do [^MethodVisitor main-writer &/get-writer
- :let [;; _ (prn "#1" module-name *writer*)
- $loop (new Label)
- ;; _ (prn "#2")
+ :let [$loop (new Label)
$end (new Label)
- ;; _ (prn "#3")
_ (doto main-writer
;; Tail: Begin
(.visitLdcInsn (int 2)) ;; S
@@ -772,20 +737,14 @@
(.visitInsn Opcodes/POP) ;; V
(.visitVarInsn Opcodes/ASTORE (int 0)) ;;
)
- ;; _ (prn "#4")
]
_ (compile ?body)
- :let [;; _ (prn "#5")
- _ (doto main-writer
+ :let [_ (doto main-writer
(.visitInsn Opcodes/ACONST_NULL)
- (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))
- ;; _ (prn "#6")
- ]
+ (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))]
:let [_ (doto main-writer
(.visitInsn Opcodes/POP)
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
- (.visitEnd))
- ;; _ (prn "#7")
- ]]
+ (.visitEnd))]]
(return nil)))))
diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj
index 4cd6284b7..bc6fa854d 100644
--- a/src/lux/compiler/io.clj
+++ b/src/lux/compiler/io.clj
@@ -19,7 +19,6 @@
;; [Resources]
(defn read-file [^String file-name]
- ;; (prn 'read-file file-name)
(let [file (new java.io.File (str &&/input-dir "/" file-name))]
(if (.exists file)
(return (slurp file))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 77dc316b8..cb8ad0037 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -92,7 +92,6 @@
(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)]
(defn compile-lambda [compile ?scope ?env ?body]
- ;; (prn 'compile-lambda (->> ?scope &/->seq))
(|do [[file-name _ _] &/cursor
:let [name (&host/location (&/|tail ?scope))
class-name (str (&host/->module-class (&/|head ?scope)) "/" name)
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index f7cd905e8..01e4ffd5b 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -68,7 +68,6 @@
(return nil)))
(defn compile-variant [compile ?tag ?value]
- ;; (prn 'compile-variant ?tag (class ?tag))
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitLdcInsn (int 2))
@@ -118,8 +117,7 @@
(|do [^MethodVisitor **writer** &/get-writer]
(|case def-type
"type"
- (|do [:let [;; ?type* (&&type/->analysis ?type)
- _ (doto **writer**
+ (|do [:let [_ (doto **writer**
;; Tail: Begin
(.visitLdcInsn (int 2)) ;; S
(.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V
@@ -131,17 +129,12 @@
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
(.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;")
- ;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN
(.visitInsn Opcodes/AASTORE) ;; V
- )]
- ;; _ (compile ?type*)
- ;; :let [_ (.visitInsn **writer** Opcodes/AASTORE)]
- ]
+ )]]
(return nil))
"value"
- (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0))
- ?def-type (|case ?body
+ (|let [?def-type (|case ?body
[[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr)]
?type-expr
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 133c50e9b..916f94419 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -113,7 +113,6 @@
(do-template [<name> <static?>]
(defn <name> [class-loader target method-name args]
- ;; (prn '<name> target method-name)
(|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)]
(if-let [^Method method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader))
:when (and (.equals ^Object method-name (.getName =method))
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index fd694c51c..651f9ecce 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -109,10 +109,8 @@
? (&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)))))))
+ (|do [unaliased (&module/dealias token)]
+ (return (&/T meta (&/T unaliased local-token))))))
(return (&/T meta (&/T "" token)))
)))
(|do [[meta _] (&reader/read-text ";;")
diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj
index 7337bcb02..83927ba0d 100644
--- a/src/lux/packager/program.clj
+++ b/src/lux/packager/program.clj
@@ -33,7 +33,6 @@
(defn ^:private write-class! [^String path ^File file ^JarOutputStream out]
"(-> Text File JarOutputStream Unit)"
- ;; (prn 'write-class! path file)
(with-open [in (new BufferedInputStream (new FileInputStream file))]
(let [buffer (byte-array (* 10 kilobyte))]
(doto out
@@ -49,8 +48,7 @@
(let [output-dir-size (.length &&/output-dir)]
(defn ^:private write-module! [^File file ^JarOutputStream out]
"(-> File JarOutputStream Unit)"
- (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file)
- ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size))
+ (let [module-name (.substring (.getPath file) output-dir-size)
inner-files (.listFiles file)
inner-modules (filter #(.isDirectory ^File %) inner-files)
inner-classes (filter #(not (.isDirectory ^File %)) inner-files)]
@@ -80,7 +78,6 @@
(with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))]
(loop [^JarEntry entry (.getNextJarEntry is)]
(when entry
- ;; (prn 'add-jar! (.getName entry) (.isDirectory entry))
(when (and (not (.isDirectory entry))
(not (.startsWith (.getName entry) "META-INF/")))
(let [entry-data (read-stream is)]
@@ -94,7 +91,6 @@
;; [Resources]
(defn package [module]
"(-> Text (,))"
- ;; (prn 'package module)
(with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))]
(doseq [$group (.listFiles (new File &&/output-dir))]
(write-module! $group out))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index ed0dd8898..fb9c63783 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -36,10 +36,8 @@
(defn App$ [fun arg]
(&/V &/$AppT (&/T fun arg)))
(defn Tuple$ [members]
- ;; (assert (|list? members))
(&/V &/$TupleT members))
(defn Variant$ [members]
- ;; (assert (|list? members))
(&/V &/$VariantT members))
(defn Univ$ [env body]
(&/V &/$UnivQ (&/T env body)))
@@ -149,7 +147,6 @@
(deref id)
_
- ;; (assert false (str "[Type Error] Type is not a variable: " (show-type type)))
(fail (str "[Type Error] Type is not a variable: " (show-type type)))
))
@@ -406,8 +403,6 @@
"\n"))
(defn beta-reduce [env type]
- ;; (when @!flag
- ;; (prn 'beta-reduce (show-type type)))
(|case type
(&/$VariantT ?members)
(Variant$ (&/|map (partial beta-reduce env) ?members))
@@ -442,8 +437,6 @@
))
(defn apply-type [type-fn param]
- ;; (when @!flag
- ;; (prn 'apply-type (show-type type-fn) (show-type param)))
(|case type-fn
(&/$UnivQ local-env local-def)
(return (beta-reduce (->> local-env
@@ -528,40 +521,6 @@
(check* class-loader fixpoints invariant?? eA aA)
(fail (check-error expected actual)))
- ;; [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)]
- ;; (fn [state]
- ;; (|case ((|do [F1 (deref ?eid)]
- ;; (fn [state]
- ;; (|case ((|do [F2 (deref ?aid)]
- ;; (check* class-loader fixpoints invariant?? (App$ F1 A1) (App$ F2 A2)))
- ;; state)
- ;; (&/$Right state* output)
- ;; (return* state* output)
-
- ;; (&/$Left _)
- ;; ((check* class-loader fixpoints invariant?? (App$ F1 A1) actual)
- ;; state))))
- ;; state)
- ;; (&/$Right state* output)
- ;; (return* state* output)
-
- ;; (&/$Left _)
- ;; (|case ((|do [F2 (deref ?aid)]
- ;; (check* class-loader fixpoints invariant?? expected (App$ F2 A2)))
- ;; state)
- ;; (&/$Right state* output)
- ;; (return* state* output)
-
- ;; (&/$Left _)
- ;; ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid))
- ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? A1 A2)]
- ;; (return (&/T fixpoints** nil)))
- ;; state))))
-
- ;; (|do [_ (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid))
- ;; _ (check* class-loader fixpoints invariant?? A1 A2)]
- ;; (return (&/T fixpoints nil)))
-
[(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)]
(fn [state]
(|case ((|do [F1 (deref ?id)]
@@ -578,13 +537,6 @@
(return (&/T fixpoints** nil)))
state)))
- ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]]
- ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2)
- ;; e* (apply-type F2 A1)
- ;; a* (apply-type F2 A2)
- ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)]
- ;; (return (&/T fixpoints** nil)))
-
[(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)]
(fn [state]
(|case ((|do [F2 (deref ?id)]
@@ -601,17 +553,6 @@
(return (&/T fixpoints** nil)))
state)))
- ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]]
- ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id))
- ;; e* (apply-type F1 A1)
- ;; a* (apply-type F1 A2)
- ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)]
- ;; (return (&/T fixpoints** nil)))
-
- ;; [(&/$AppT eF eA) (&/$AppT aF aA)]
- ;; (|do [_ (check* class-loader fixpoints invariant?? eF aF)]
- ;; (check* class-loader fixpoints invariant?? eA aA))
-
[(&/$AppT F A) _]
(let [fp-pair (&/T expected actual)
_ (when (> (&/|length fixpoints) 40)
@@ -641,11 +582,7 @@
(|do [$arg existential
expected* (apply-type expected $arg)]
(check* class-loader fixpoints invariant?? expected* actual))
- ;; (with-var
- ;; (fn [$arg]
- ;; (|do [expected* (apply-type expected $arg)]
- ;; (check* class-loader fixpoints invariant?? expected* actual))))
-
+
[_ (&/$UnivQ _)]
(with-var
(fn [$arg]
diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj
index e121cee86..989c0d665 100644
--- a/src/lux/type/host.clj
+++ b/src/lux/type/host.clj
@@ -68,20 +68,17 @@
Unit (&/V &/$TupleT (&/|list))]
(defn class->type [^Class class]
"(-> Class Type)"
- (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class))
- (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))]
- (let [base (or arr-base simple-base)]
- ;; (prn 'class->type/_1 class base arr-brackets)
- (if (.equals "void" base)
- Unit
- (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner))))
- (&/V &/$DataT (&/T base &/Nil$))
- (range (count (or arr-brackets "")))))
- )))))
+ (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))]
+ (let [base (or arr-base simple-base)]
+ (if (.equals "void" base)
+ Unit
+ (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner))))
+ (&/V &/$DataT (&/T base &/Nil$))
+ (range (count (or arr-brackets "")))))
+ ))))
(defn instance-param [existential matchings refl-type]
"(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))"
- ;; (prn 'instance-param refl-type (class refl-type))
(cond (instance? Class refl-type)
(return (class->type refl-type))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 19:10:50 +0000