From 25be66a8a58b202284152d5a422d13fb81661abb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 20 Mar 2015 23:52:07 -0400 Subject: [2nd Super Refactoring That Breaks The System: Part 6] - Corrected more bugs in the system. --- source/lux.lux | 455 +++++++++++++++++++++++----------------------- src/lux.clj | 2 + src/lux/analyser.clj | 10 +- src/lux/analyser/base.clj | 34 ++-- src/lux/analyser/case.clj | 25 +-- src/lux/analyser/host.clj | 4 +- src/lux/analyser/lux.clj | 106 ++++++----- src/lux/base.clj | 38 +++- src/lux/compiler.clj | 8 +- src/lux/compiler/base.clj | 12 +- src/lux/compiler/case.clj | 47 +++-- src/lux/compiler/host.clj | 31 ++-- src/lux/compiler/lux.clj | 21 +-- src/lux/host.clj | 17 +- src/lux/lexer.clj | 50 ++--- src/lux/macro.clj | 1 + src/lux/type.clj | 16 +- 17 files changed, 471 insertions(+), 406 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 9e5885e97..ccc1476de 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -80,237 +80,237 @@ (#Right [state (#Cons [fn-def (#Cons [declaration #Nil])])])))) (declare-macro defmacro) -## (defmacro (comment tokens state) -## (#Right [state #Nil])) +(defmacro (comment tokens state) + (#Right [state #Nil])) -## (def (int+ x y) -## (jvm-ladd x y)) +(def (int+ x y) + (jvm-ladd x y)) -## (def (id x) -## x) +(def (id x) + x) -## (def (print x) -## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] -## (jvm-getstatic java.lang.System "out") [x])) +(def (print x) + (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] + (jvm-getstatic java.lang.System "out") [x])) -## (def (println x) -## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] -## (jvm-getstatic java.lang.System "out") [x])) +(def (println x) + (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] + (jvm-getstatic java.lang.System "out") [x])) -## (def (fold f init xs) -## (case' xs -## #Nil -## init +(def (fold f init xs) + (case' xs + #Nil + init -## (#Cons [x xs']) -## (fold f (f init x) xs'))) - -## (def (reverse list) -## (fold (lambda [tail head] -## (#Cons [head tail])) -## #Nil -## list)) - -## (defmacro (list xs state) -## (let' xs' (reverse xs) -## (let' output (fold (lambda [tail head] -## (#Form (#Cons [(#Tag "Cons") -## (#Cons [(#Tuple (#Cons [head (#Cons [tail #Nil])])) -## #Nil])]))) -## (#Tag "Nil") -## xs') -## (#Right [state (#Cons [output #Nil])])))) - -## (defmacro (list+ xs state) -## (case' (reverse xs) -## #Nil -## [#Nil state] - -## (#Cons [last init']) -## (let' output (fold (lambda [tail head] -## (#Form (list (#Tag "Cons") (#Tuple (list head tail))))) -## last -## init') -## (#Right [state (#Cons [output #Nil])])))) - -## (def (as-pairs xs) -## (case' xs -## (#Cons [x (#Cons [y xs'])]) -## (#Cons [[x y] (as-pairs xs')]) - -## _ -## #Nil)) - -## (defmacro (let tokens state) -## (case' tokens -## (#Cons [(#Tuple bindings) (#Cons [body #Nil])]) -## (let' output (fold (lambda [body binding] -## (case' binding -## [label value] -## (#Form (list (#Symbol "lux;let'") label value body)))) -## body -## (reverse (as-pairs bindings))) -## (#Right [state (list output)])))) - -## (def (. f g) -## (lambda [x] (f (g x)))) - -## (def (++ xs ys) -## (case' xs -## #Nil -## ys - -## (#Cons [x xs*]) -## (#Cons [x (++ xs* ys)]))) - -## (def concat -## (fold ++ #Nil)) - -## (def (map f xs) -## (case' xs -## #Nil -## #Nil - -## (#Cons [x xs']) -## (#Cons [(f x) (map f xs')]))) - -## (def flat-map (. concat map)) - -## (def (untemplate-list tokens) -## (case' tokens -## #Nil -## (#Tag "Nil") - -## (#Cons [token tokens']) -## (#Form (#Cons [(#Tag "Cons") -## (#Cons [(#Tuple (#Cons [token (#Cons [(untemplate-list tokens') #Nil])])) -## #Nil])])))) - -## (def (untemplate token) -## (case' token -## (#Bool value) -## (#Form (list (#Tag "Bool") (#Bool value))) - -## (#Int value) -## (#Form (list (#Tag "Int") (#Int value))) - -## (#Real value) -## (#Form (list (#Tag "Real") (#Real value))) - -## (#Char value) -## (#Form (list (#Tag "Char") (#Char value))) - -## (#Text value) -## (#Form (list (#Tag "Text") (#Text value))) - -## (#Tag value) -## (#Form (list (#Tag "Tag") (#Text value))) - -## (#Symbol value) -## (#Form (list (#Tag "Symbol") (#Text value))) + (#Cons [x xs']) + (fold f (f init x) xs'))) + +(def (reverse list) + (fold (lambda [tail head] + (#Cons [head tail])) + #Nil + list)) + +(defmacro (list xs state) + (let' xs' (reverse xs) + (let' output (fold (lambda [tail head] + (#Form (#Cons [(#Tag "Cons") + (#Cons [(#Tuple (#Cons [head (#Cons [tail #Nil])])) + #Nil])]))) + (#Tag "Nil") + xs') + (#Right [state (#Cons [output #Nil])])))) + +(defmacro (list+ xs state) + (case' (reverse xs) + #Nil + [#Nil state] + + (#Cons [last init']) + (let' output (fold (lambda [tail head] + (#Form (list (#Tag "Cons") (#Tuple (list head tail))))) + last + init') + (#Right [state (#Cons [output #Nil])])))) + +(def (as-pairs xs) + (case' xs + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) + + _ + #Nil)) + +(defmacro (let tokens state) + (case' tokens + (#Cons [(#Tuple bindings) (#Cons [body #Nil])]) + (let' output (fold (lambda [body binding] + (case' binding + [label value] + (#Form (list (#Symbol "lux;let'") label value body)))) + body + (reverse (as-pairs bindings))) + (#Right [state (list output)])))) + +(def (. f g) + (lambda [x] (f (g x)))) + +(def (++ xs ys) + (case' xs + #Nil + ys + + (#Cons [x xs*]) + (#Cons [x (++ xs* ys)]))) + +(def concat + (fold ++ #Nil)) + +(def (map f xs) + (case' xs + #Nil + #Nil + + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) + +(def flat-map (. concat map)) + +(def (untemplate-list tokens) + (case' tokens + #Nil + (#Tag "Nil") + + (#Cons [token tokens']) + (#Form (#Cons [(#Tag "Cons") + (#Cons [(#Tuple (#Cons [token (#Cons [(untemplate-list tokens') #Nil])])) + #Nil])])))) + +(def (untemplate token) + (case' token + (#Bool value) + (#Form (list (#Tag "Bool") (#Bool value))) + + (#Int value) + (#Form (list (#Tag "Int") (#Int value))) + + (#Real value) + (#Form (list (#Tag "Real") (#Real value))) + + (#Char value) + (#Form (list (#Tag "Char") (#Char value))) + + (#Text value) + (#Form (list (#Tag "Text") (#Text value))) + + (#Tag value) + (#Form (list (#Tag "Tag") (#Text value))) + + (#Symbol value) + (#Form (list (#Tag "Symbol") (#Text value))) + + (#Tuple elems) + (#Form (list (#Tag "Tuple") (untemplate-list (map untemplate elems)))) + + (#Form (#Cons [(#Symbol "~") (#Cons [unquoted #Nil])])) + unquoted + + (#Form elems) + (#Form (list (#Tag "Form") (untemplate-list (map untemplate elems)))) + )) + +(defmacro (` tokens state) + (case' tokens + (#Cons [template #Nil]) + (#Right [state (list (untemplate template))]))) + +(defmacro (if tokens state) + (case' tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (#Right [state + (list (` (case' (~ test) + true (~ then) + false (~ else))))]))) + +(def (filter p xs) + (case' xs + #Nil + #Nil + + (#Cons [x xs*]) + (if (p x) + (filter p xs*) + (#Cons [x (filter p xs*)])))) + +(def (return val) + (lambda [state] + (#Right [state val]))) + +(def (fail msg) + (lambda [_] + (#Left msg))) -## (#Tuple elems) -## (#Form (list (#Tag "Tuple") (untemplate-list (map untemplate elems)))) - -## (#Form (#Cons [(#Symbol "~") (#Cons [unquoted #Nil])])) -## unquoted - -## (#Form elems) -## (#Form (list (#Tag "Form") (untemplate-list (map untemplate elems)))) -## )) - -## (defmacro (` tokens state) -## (case' tokens -## (#Cons [template #Nil]) -## (#Right [state (list (untemplate template))]))) - -## (defmacro (if tokens state) -## (case' tokens -## (#Cons [test (#Cons [then (#Cons [else #Nil])])]) -## (#Right [state -## (list (` (case' (~ test) -## true (~ then) -## false (~ else))))]))) - -## (def (filter p xs) -## (case' xs -## #Nil -## #Nil - -## (#Cons [x xs*]) -## (if (p x) -## (filter p xs*) -## (#Cons [x (filter p xs*)])))) - -## (def (return val) -## (lambda [state] -## (#Right [state val]))) - -## (def (fail msg) -## (lambda [_] -## (#Left msg))) - -## (def (bind f v) -## (lambda [state] -## (case' (v state) -## (#Right [state' x]) -## (f x state') +(def (bind f v) + (lambda [state] + (case' (v state) + (#Right [state' x]) + (f x state') -## (#Left msg) -## (#Left msg)))) - -## (def (first pair) -## (case' pair -## [f s] -## f)) - -## (def (second pair) -## (case' pair -## [f s] -## s)) - -## (defmacro (loop tokens) -## (case' tokens -## (#Cons [bindings (#Cons [body #Nil])]) -## (let [pairs (as-pairs bindings)] -## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol "recur")) (~ (#Tuple (map first pairs))) -## (~ body))) -## (map second pairs)]))))))) - -## (defmacro (export tokens) -## (return (map (lambda [t] (` (export' (~ t)))) -## tokens))) - -## (defmacro (and tokens) -## (let [as-if (case' tokens -## #Nil -## (` true) - -## (#Cons [init tests]) -## (fold (lambda [prev next] -## (` (if (~ prev) (~ next) false))) -## init -## tokens) -## )] -## (return (list as-if)))) - -## (defmacro (or tokens) -## (let [as-if (case' tokens -## #Nil -## (` false) - -## (#Cons [init tests]) -## (fold (lambda [prev next] -## (` (if (~ prev) true (~ next)))) -## init -## tokens) -## )] -## (return (list as-if)))) - -## (def (not x) -## (case' x -## true false -## false true)) + (#Left msg) + (#Left msg)))) + +(def (first pair) + (case' pair + [f s] + f)) + +(def (second pair) + (case' pair + [f s] + s)) + +(defmacro (loop tokens) + (case' tokens + (#Cons [bindings (#Cons [body #Nil])]) + (let [pairs (as-pairs bindings)] + (return (list (#Form (#Cons [(` (lambda (~ (#Symbol "recur")) (~ (#Tuple (map first pairs))) + (~ body))) + (map second pairs)]))))))) + +(defmacro (export tokens) + (return (map (lambda [t] (` (export' (~ t)))) + tokens))) + +(defmacro (and tokens) + (let [as-if (case' tokens + #Nil + (` true) + + (#Cons [init tests]) + (fold (lambda [prev next] + (` (if (~ prev) (~ next) false))) + init + tokens) + )] + (return (list as-if)))) + +(defmacro (or tokens) + (let [as-if (case' tokens + #Nil + (` false) + + (#Cons [init tests]) + (fold (lambda [prev next] + (` (if (~ prev) true (~ next)))) + init + tokens) + )] + (return (list as-if)))) + +(def (not x) + (case' x + true false + false true)) ## (defmacro (|> tokens) ## (case' tokens @@ -756,10 +756,13 @@ ## (#Cons [args (#Cons [body #Nil])]) ## (return (list (` (All (~ args) (~ body))))))) -## (def Any (| #Any)) -## (def Nothing (| #Nothing)) -## (def Text (^ java.lang.String)) +## (def Any #Any) +## (def Nothing #Nothing) +## (def Bool (^ java.lang.Boolean)) ## (def Int (^ java.lang.Long)) +## (def Real (^ java.lang.Double)) +## (def Char (^ java.lang.Character)) +## (def Text (^ java.lang.String)) ## (deftype (List a) ## (| #Nil diff --git a/src/lux.clj b/src/lux.clj index b0a9a3c94..9f48294c6 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -15,6 +15,8 @@ ;; TODO: Take module-name aliasing into account. ;; TODO: + ;; Finish total-locals + (time (&compiler/compile-all (&/|list "lux"))) (time (&compiler/compile-all (&/|list "lux" "test2"))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index f9c104378..a4c1a3836 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -53,11 +53,11 @@ [["Tag" ?tag]] (let [tuple-type (&/V "Tuple" (&/V "Nil" nil))] - (return (&/|list [&/V "Expression" (&/T (&/V "variant" (&/T ?tag (&/V "Expression" (&/T (&/V "tuple" (&/|list)) tuple-type)))) - (&/V "Variant" (&/V "Cons" (&/T (&/T ?tag tuple-type) (&/V "Nil" nil)))))]))) + (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag (&/V "Expression" (&/T (&/V "tuple" (&/|list)) tuple-type)))) + (&/V "Variant" (&/V "Cons" (&/T (&/T ?tag tuple-type) (&/V "Nil" nil))))))))) [["Symbol" "jvm-null"]] - (return (&/|list [&/V "Expression" (&/T (&/V "jvm-null" nil) (&/V "Data" (&/T "null" (&/V "Nil" nil))))])) + (return (&/|list (&/V "Expression" (&/T (&/V "jvm-null" nil) (&/V "Data" (&/T "null" (&/V "Nil" nil))))))) [["Symbol" ?ident]] (&&lux/analyse-ident analyse ?ident) @@ -403,12 +403,14 @@ [["Form" ["Cons" [?fn ?args]]]] (fn [state] + (prn '(&/show-ast ?fn) (&/show-ast ?fn)) (matchv ::M/objects [((&&/analyse-1 (analyse-ast eval!) ?fn) state)] [["Right" [state* =fn]]] ((&&lux/analyse-apply (analyse-ast eval!) =fn ?args) state*) [_] - ((analyse-basic-ast (analyse-ast eval!) eval! token) state))) + (do (prn 'analyse-ast/token (aget token 0) (&/show-state state)) + ((analyse-basic-ast (analyse-ast eval!) eval! token) state)))) [_] (analyse-basic-ast (analyse-ast eval!) eval! token)))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 256acd346..f67b7e281 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -7,30 +7,34 @@ ;; [Resources] (defn expr-type [syntax+] ;; (prn 'expr-type syntax+) + ;; (prn 'expr-type (aget syntax+ 0)) (matchv ::M/objects [syntax+] [["Expression" [_ type]]] - (return type) - - [_] - (fail (str "[Analyser Error] Can't retrieve the type of a non-expression: " (pr-str syntax+))))) + (do ;; (prn 'expr-type (&type/show-type type)) + (return type)) + + [["Statement" _]] + (fail (str "[Analyser Error] Can't retrieve the type of a statement: " (pr-str syntax+))))) (defn analyse-1 [analyse elem] (exec [output (analyse elem)] - (matchv ::M/objects [output] - [["Cons" [x ["Nil" _]]]] - (return x) + (do ;; (prn 'analyse-1 (aget output 0)) + (matchv ::M/objects [output] + [["Cons" [x ["Nil" _]]]] + (return x) - [_] - (fail "[Analyser Error] Can't expand to other than 1 element.")))) + [_] + (fail "[Analyser Error] Can't expand to other than 1 element."))))) (defn analyse-2 [analyse el1 el2] - (exec [output (&/flat-map analyse (list el1 el2))] - (matchv ::M/objects [output] - [["Cons" [x ["Cons" [y ["Nil" _]]]]]] - (return [x y]) + (exec [output (&/flat-map% analyse (&/|list el1 el2))] + (do ;; (prn 'analyse-2 (aget output 0)) + (matchv ::M/objects [output] + [["Cons" [x ["Cons" [y ["Nil" _]]]]]] + (return [x y]) - [_] - (fail "[Analyser Error] Can't expand to other than 2 elements.")))) + [_] + (fail "[Analyser Error] Can't expand to other than 2 elements."))))) (defn with-var [k] (exec [=var &type/fresh-var diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 1574218c3..93036daa6 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -1,7 +1,7 @@ (ns lux.analyser.case (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return fail]] + (lux [base :as & :refer [exec return fail |let]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -22,14 +22,15 @@ [_] (&/|list))) -(defn analyse-branch [analyse max-registers [bindings body]] - ;; (prn 'analyse-branch max-registers bindings body) - (reduce (fn [body* name] - (&&/with-var - (fn [=var] - (&env/with-local name =var body*)))) - (reduce (fn [body* _] - (&env/with-local "" &type/+dont-care+ body*)) - (&&/analyse-1 analyse body) - (range (- max-registers (count bindings)))) - (reverse bindings))) +(defn analyse-branch [analyse max-registers bindings+body] + (|let [[bindings body] bindings+body] + (do (prn 'analyse-branch max-registers (&/|length bindings) body) + (&/fold (fn [body* name] + (&&/with-var + (fn [=var] + (&env/with-local name =var body*)))) + (&/fold (fn [body* _] + (&env/with-local "" &type/+dont-care+ body*)) + (&&/analyse-1 analyse body) + (&/|range (- max-registers (&/|length bindings)))) + (&/|reverse bindings))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 6fff76590..5379b225e 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -99,7 +99,7 @@ (defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] (exec [=class (&host/full-class-name ?class) =classes (&/map% &host/extract-jvm-param ?classes) - =return (&host/lookup-virtual-method =class ?method =classes) + =return (&host/lookup-static-method =class ?method =classes) =args (&/flat-map% analyse ?args)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-invokestatic" (&/T =class ?method =classes =args)) =return)))))) @@ -109,7 +109,7 @@ ;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)] =classes (&/map% &host/extract-jvm-param ?classes) ;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)] - [=method-args =return] (&host/lookup-virtual-method =class ?method =classes) + =return (&host/lookup-virtual-method =class ?method =classes) ;; :let [_ (prn 'analyse-jvm-invokevirtual/=return =return)] =object (&&/analyse-1 analyse ?object) ;; :let [_ (prn 'analyse-jvm-invokevirtual/=object =object)] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index daec2bd0a..edf707adc 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -38,18 +38,23 @@ ] (return (&/|list (&/V "Expression" (&/T (&/V "record" =elems) (&/V "Record" =elems-types))))))) +(defn ^:private resolve-global [ident state] + (if-let [global (->> state (&/get$ "global-env") &/from-some (&/get$ "locals") (&/get$ "mappings") (&/|get ident))] + (return* state (&/|list global)) + (fail* (str "[Analyser Error] Unresolved identifier: " ident)))) + (defn analyse-ident [analyse ident] - (prn 'analyse-ident ident) + ;; (prn 'analyse-ident ident) (exec [module-name &/get-module-name] (fn [state] - (prn 'module-name module-name) - (prn '(&/get$ "local-envs" state) (&/get$ "local-envs" state)) - (prn '(&/->seq (&/get$ "local-envs" state)) (&/->seq (&/get$ "local-envs" state))) - (println (&/show-state state)) + ;; (prn 'module-name module-name) + ;; (prn '(&/get$ "local-envs" state) (&/get$ "local-envs" state)) + ;; (prn '(&/->seq (&/get$ "local-envs" state)) (&/->seq (&/get$ "local-envs" state))) + ;; (println (&/show-state state)) (let [stack (&/get$ "local-envs" state)] - (matchv ::M/objects [(&/get$ "local-envs" state)] + (matchv ::M/objects [stack] [["Nil" _]] - (fail* (str "[Analyser Error] Unresolved identifier: " ident)) + (resolve-global ident state) [["Cons" [top stack*]]] (if-let [=bound (or (->> stack &/|head (&/get$ "locals") (&/get$ "mappings") (&/|get ident)) @@ -58,48 +63,49 @@ (|let [no-binding? #(and (->> % (&/get$ "locals") (&/get$ "mappings") (&/|contains? ident) not) (->> % (&/get$ "closure") (&/get$ "mappings") (&/|contains? ident) not)) [inner outer] (&/|split-with no-binding? stack*)] - (matchv ::M/objects [outer] - [["Nil" _]] - (if-let [global (->> state (&/get$ "global-env") &/from-some (&/get$ "locals") (&/get$ "mappings") (&/|get ident))] - (return* state (&/|list global)) - (fail* (str "[Analyser Error] Unresolved identifier: " ident))) - - [["Cons" [top-outer _]]] - (let [in-stack (&/|cons top inner) - scopes (&/|tail (&/folds #(&/|cons (&/get$ "name" %2) %1) - (&/|map #(&/get$ "name" %) outer) - (&/|reverse in-stack))) - _ (prn 'in-stack module-name ident (&/->seq (&/|map #(&/get$ "name" %) in-stack)) scopes) - [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] - (|let [[register new-inner] register+new-inner - [frame in-scope] frame+in-scope - [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ "locals") (&/get$ "mappings") (&/|get ident)) - (->> top-outer (&/get$ "closure") (&/get$ "mappings") (&/|get ident))) - (&/|list)) - (&/zip2 (&/|reverse in-stack) scopes))] - (return* (&/set$ "local-envs" (&/|++ inner* outer) state) (&/|list =local))) - ))) + (matchv ::M/objects [outer] + [["Nil" _]] + (resolve-global ident state) + + [["Cons" [top-outer _]]] + (let [in-stack (&/|cons top inner) + scopes (&/|tail (&/folds #(&/|cons (&/get$ "name" %2) %1) + (&/|map #(&/get$ "name" %) outer) + (&/|reverse in-stack))) + ;; _ (prn 'in-stack module-name ident (&/->seq (&/|map #(&/get$ "name" %) in-stack)) scopes) + [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] + (|let [[register new-inner] register+new-inner + [frame in-scope] frame+in-scope + [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ "locals") (&/get$ "mappings") (&/|get ident)) + (->> top-outer (&/get$ "closure") (&/get$ "mappings") (&/|get ident))) + (&/|list)) + (&/zip2 (&/|reverse in-stack) scopes))] + (return* (&/set$ "local-envs" (&/|++ inner* outer) state) (&/|list =local))) + ))) )) ))) (defn ^:private analyse-apply* [analyse =fn ?args] (exec [=args (&/flat-map% analyse ?args) =fn-type (&&/expr-type =fn) - =apply+=apply-type (&/fold (fn [[=fn =fn-type] =input] - (exec [=input-type (&&/expr-type =input) - =output-type (&type/apply-lambda =fn-type =input-type)] - (return [(&/V "apply" (&/T =fn =input)) =output-type]))) - [=fn =fn-type] - =args) - :let [[=apply =apply-type] (matchv ::M/objects [=apply+=apply-type] - [[=apply =apply-type]] - [=apply =apply-type])]] - (return (&/|list (&/V "Expression" (&/T =apply =apply-type)))))) + [=apply _] (&/fold% (fn [[=fn =fn-type] =input] + (exec [;; :let [_ (prn "#2")] + =input-type (&&/expr-type =input) + ;; :let [_ (prn "#3")] + =output-type (&type/apply-lambda =fn-type =input-type) + ;; :let [_ (prn "#4")] + ] + (return [(&/V "Expression" (&/T (&/V "apply" (&/T =fn =input)) + =output-type)) + =output-type]))) + [=fn =fn-type] + =args)] + (return (&/|list =apply)))) (defn analyse-apply [analyse =fn ?args] - (prn 'analyse-apply (aget =fn 0)) + ;; (prn 'analyse-apply (aget =fn 0)) (exec [loader &/loader] (matchv ::M/objects [=fn] [["Expression" [=fn-form =fn-type]]] @@ -121,11 +127,15 @@ )) (defn analyse-case [analyse ?value ?branches] - ;; (prn 'analyse-case ?value ?branches) - (exec [:let [num-branches (&/|length ?branches)] + (prn 'analyse-case (aget ?branches 0) (aget ?branches 1 1 0) + (&/->seq ?branches)) + (exec [:let [num-branches (&/|length ?branches) + _ (prn 'analyse-case ?value (&/|length ?branches) + (and (> num-branches 0) (even? num-branches)))] _ (&/assert! (and (> num-branches 0) (even? num-branches)) "[Analyser Error] Unbalanced branches in \"case'\" expression.") :let [branches (&/|as-pairs ?branches) + _ (prn '(&/|length branches) (&/|length branches)) locals-per-branch (&/|map (comp &&case/locals &/|first) branches) max-locals (&/fold max 0 (&/|map &/|length locals-per-branch))] ;; :let [_ (prn '[branches locals-per-branch max-locals] [branches locals-per-branch max-locals])] @@ -138,9 +148,10 @@ ;; :let [_ (prn '=bodies =bodies)] ;; :let [_ (prn 'analyse-case/=bodies =bodies)] =body-types (&/map% &&/expr-type =bodies) - :let [=case-type (&/fold &type/merge (&/|table) =body-types)] + =case-type (&/fold% &type/merge (&/V "Nothing" nil) =body-types) :let [=branches (&/zip2 (&/|map &/|first branches) =bodies)]] - (return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value base-register max-locals =branches)) =case-type)))))) + (return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value base-register max-locals =branches)) + =case-type)))))) (defn analyse-lambda [analyse ?self ?arg ?body] (exec [=lambda-type* &type/fresh-lambda] @@ -150,9 +161,12 @@ ?arg =arg (&&/analyse-1 analyse ?body)) =body-type (&&/expr-type =body) + ;; _ =body-type =lambda-type (exec [_ (&type/solve =return =body-type) =lambda-type** (&type/clean =return =lambda-type*)] - (&type/clean =arg =lambda-type**))] + (&type/clean =arg =lambda-type**)) + ;; :let [_ (prn '=lambda-type =lambda-type)] + ] (return (&/|list (&/V "Expression" (&/T (&/V "lambda" (&/T =scope =captured ?arg =body)) =lambda-type)))))))) (defn analyse-get [analyse ?slot ?record] diff --git a/src/lux/base.clj b/src/lux/base.clj index 74b1a6d9e..661451714 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -58,7 +58,7 @@ (reduce (fn [tail head] `(V "Cons" (T ~head ~tail))) `(V "Nil" nil) - elems)) + (reverse elems))) (defmacro |table [& elems] (reduce (fn [table [k v]] @@ -67,7 +67,7 @@ (partition 2 elems))) (defn |get [slot table] - (prn '|get slot (aget table 0)) + ;; (prn '|get slot (aget table 0)) (matchv ::M/objects [table] [["Nil" _]] nil @@ -88,7 +88,7 @@ (V "Cons" (T (T k v) (|put slot value table*)))))) (defn |merge [table1 table2] - (prn '|merge (aget table1 0) (aget table2 0)) + ;; (prn '|merge (aget table1 0) (aget table2 0)) (matchv ::M/objects [table2] [["Nil" _]] table1 @@ -168,7 +168,7 @@ (V "Cons" (T head tail))) (defn |++ [xs ys] - (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0))) + ;; (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0))) (matchv ::M/objects [xs] [["Nil" _]] ys @@ -220,6 +220,15 @@ [["Cons" [x xs*]]] (fold f (f init x) xs*))) +(defn fold% [f init xs] + (matchv ::M/objects [xs] + [["Nil" _]] + (return init) + + [["Cons" [x xs*]]] + (exec [init* (f init x)] + (fold% f init* xs*)))) + (defn folds [f init xs] (matchv ::M/objects [xs] [["Nil" _]] @@ -229,7 +238,7 @@ (|cons init (folds f (f init x) xs*)))) (defn |length [xs] - (prn '|length (aget xs 0)) + ;; (prn '|length (aget xs 0)) (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] @@ -290,7 +299,7 @@ (defn |as-pairs [xs] (matchv ::M/objects [xs] - [["Cons" [x [["Cons" [y xs*]]]]]] + [["Cons" [x ["Cons" [y xs*]]]]] (V "Cons" (T (T x y) (|as-pairs xs*))) [_] @@ -302,6 +311,15 @@ (|list) xs)) +(defn show-table [table] + (prn 'show-table (aget table 0)) + (str "{{" + (->> table + (|map (fn [kv] (|let [[k v] kv] (str k " = ???")))) + (|interpose " ") + (fold str "")) + "}}")) + (defn if% [text-m then-m else-m] (exec [? text-m] (if ? @@ -469,7 +487,7 @@ (str "#" slot " " (case slot "source" "???" "modules" "???" - "global-env" "???" + "global-env" (->> value from-some (get$ "locals") (get$ "mappings") show-table) "local-envs" (|length value) "types" "???" "writer" "???" @@ -486,8 +504,8 @@ (def get-writer (fn [state] (let [writer* (get$ "writer" state)] - (prn 'get-writer (class writer*)) - (prn 'get-writer (aget writer* 0)) + ;; (prn 'get-writer (class writer*)) + ;; (prn 'get-writer (aget writer* 0)) (matchv ::M/objects [writer*] [["Some" datum]] (return* state datum) @@ -502,7 +520,7 @@ (def get-current-module-env (fn [state] (let [global-env* (get$ "global-env" state)] - (prn 'get-current-module-env (aget global-env* 0)) + ;; (prn 'get-current-module-env (aget global-env* 0)) (matchv ::M/objects [global-env*] [["Some" datum]] (return* state datum) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 1489cceb2..586727b15 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -28,10 +28,10 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - (prn 'compile-expression (aget syntax 0)) + ;; (prn 'compile-expression (aget syntax 0)) (matchv ::M/objects [syntax] [["Expression" [?form ?type]]] - (do (prn 'compile-expression2 (aget ?form 0)) + (do ;; (prn 'compile-expression2 (aget ?form 0)) (matchv ::M/objects [?form] [["bool" ?value]] (&&lux/compile-bool compile-expression ?type ?value) @@ -63,8 +63,8 @@ [["global" [?owner-class ?name]]] (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["call" [?fn ?args]]] - (&&lux/compile-call compile-expression ?type ?fn ?args) + [["apply" [?fn ?arg]]] + (&&lux/compile-apply compile-expression ?type ?fn ?arg) [["variant" [?tag ?members]]] (&&lux/compile-variant compile-expression ?type ?tag ?members) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 09fc811d8..7fcda55a3 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -32,10 +32,10 @@ (return nil))) (defn total-locals [expr] - (prn 'total-locals1 (aget expr 0)) + ;; (prn 'total-locals1 (aget expr 0)) (matchv ::M/objects [expr] [["Expression" [?struct ?type]]] - (do (prn 'total-locals2 (aget ?struct 0)) + (do ;; (prn 'total-locals2 (aget ?struct 0)) (matchv ::M/objects [?struct] [["case" [?variant ?base-register ?num-registers ?branches]]] (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches))) @@ -127,9 +127,9 @@ [["jvm-aaload" [?array ?idx]]] (total-locals ?array) - [["lambda" _]] - 0 - - ;; [_] + ;; [["lambda" _]] ;; 0 + + [_] + 0 )))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 336d0c645..22349bbca 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -17,48 +17,51 @@ ;; [Utils] (defn ^:private ->match [$body register token] - (prn '->match token) - (prn '->match (aget token 0)) + ;; (prn '->match token) + ;; (prn '->match (aget token 0)) (matchv ::M/objects [token] [["Symbol" ?name]] - (&/T (inc register) (&/V "Pattern" (&/T $body [&/V "StoreMatch" register]))) + (&/T (inc register) (&/V "Pattern" (&/T $body (&/V "StoreMatch" register)))) [["Bool" ?value]] - (&/T register (&/V "Pattern" (&/T $body [&/V "BoolMatch" ?value]))) + (&/T register (&/V "Pattern" (&/T $body (&/V "BoolMatch" ?value)))) [["Int" ?value]] - (&/T register (&/V "Pattern" (&/T $body [&/V "IntMatch" ?value]))) + (&/T register (&/V "Pattern" (&/T $body (&/V "IntMatch" ?value)))) [["Real" ?value]] - (&/T register (&/V "Pattern" (&/T $body [&/V "RealMatch" ?value]))) + (&/T register (&/V "Pattern" (&/T $body (&/V "RealMatch" ?value)))) [["Char" ?value]] - (&/T register (&/V "Pattern" (&/T $body [&/V "CharMatch" ?value]))) + (&/T register (&/V "Pattern" (&/T $body (&/V "CharMatch" ?value)))) [["Text" ?value]] - (&/T register (&/V "Pattern" (&/T $body [&/V "TextMatch" ?value]))) + (&/T register (&/V "Pattern" (&/T $body (&/V "TextMatch" ?value)))) [["Tuple" ?members]] - (|let [[register* =members] (&/fold (fn [[register =members] member] - (|let [[register* =member] (->match $body register member)] - (&/T register* (&/|cons =member =members)))) + (|let [[register* =members] (&/fold (fn [register+=members member] + (prn 'register+=members (alength register+=members)) + (|let [[_register =members] register+=members + [__register =member] (let [matched (->match $body _register member)] + (prn 'matched (alength matched)) + matched)] + (&/T __register (&/|cons =member =members)))) (&/T register (&/|list)) ?members)] - (&/T register* (&/V "Pattern" (&/T $body [&/V "TupleMatch" (&/|reverse =members)])))) + (&/T register* (&/V "Pattern" (&/T $body (&/V "TupleMatch" (&/|reverse =members)))))) [["Tag" ?tag]] - (&/T register (&/V "Pattern" (&/T $body [&/V "VariantMatch" (&/T ?tag [&/V "Pattern" (&/T $body [&/V "TupleMatch" (list)])])]))) + (&/T register (&/V "Pattern" (&/T $body (&/V "VariantMatch" (&/T ?tag (&/V "Pattern" (&/T $body (&/V "TupleMatch" (&/|list))))))))) [["Form" ["Cons" [["Tag" ?tag] ["Cons" [?value ["Nil" _]]]]]]] (|let [[register* =value] (->match $body register ?value)] - - (&/T register* (&/V "Pattern" (&/T $body [&/V "VariantMatch" (&/T ?tag =value)])))) + (&/T register* (&/V "Pattern" (&/T $body (&/V "VariantMatch" (&/T ?tag =value)))))) )) (defn ^:private process-branches [base-register branches] - (prn 'process-branches base-register branches) + ;; (prn 'process-branches base-register (&/|length branches)) (|let [[_ mappings pms] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body @@ -72,6 +75,7 @@ +oclass+ (&host/->class "java.lang.Object") +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")] (defn ^:private compile-match [writer ?match $target $else] + ;; (prn 'compile-match (aget ?match 0) $target $else) (matchv ::M/objects [?match] [["StoreMatch" ?register]] (doto writer @@ -136,7 +140,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $else) (.visitLabel $next)) - (->> (|let [[idx [_ _ member]] idx+member + (->> (|let [[idx ["Pattern" [_ member]]] idx+member $next (new Label) $sub-else (new Label)]) (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))]))) @@ -168,7 +172,7 @@ (let [ex-class (&host/->class "java.lang.IllegalStateException")] (defn ^:private compile-pattern-matching [writer compile mappings patterns $end] - (prn 'compile-pattern-matching mappings patterns $end) + ;; (prn 'compile-pattern-matching mappings (&/|length patterns) $end) (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] @@ -179,9 +183,10 @@ (doto writer (-> (doto (compile-match ?match (&/|get ?body mappings*) $else) (.visitLabel $else)) - (->> (|let [[_ ?body ?match] ?body+?match]) + (->> (|let [["Pattern" [?body ?match]] ?body+?match]) (doseq [?body+?match (&/->seq patterns) :let [;; _ (prn 'compile-pattern-matching/pattern pattern) + _ (prn '?body+?match (alength ?body+?match) (aget ?body+?match 0)) $else (new Label)]]))) (.visitInsn Opcodes/POP) (.visitTypeInsn Opcodes/NEW ex-class) @@ -199,10 +204,12 @@ ;; [Resources] (defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches] + (prn 'compile-case ?variant ?base-register ?num-registers (&/|length ?branches)) (exec [*writer* &/get-writer :let [$end (new Label)] _ (compile ?variant)] - (|let [[mappings patterns] (process-branches ?base-register ?branches)] + (|let [[mappings patterns] (process-branches ?base-register ?branches) + _ (prn '[(&/|length mappings) (&/|length patterns)] [(&/|length mappings) (&/|length patterns)])] (exec [_ (compile-pattern-matching *writer* compile mappings patterns $end) :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index c14924efd..09e772ff8 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -4,7 +4,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail*]] + (lux [base :as & :refer [exec return* return fail fail* |let]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -171,10 +171,10 @@ (exec [*writer* &/get-writer :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (&/map% (fn [[class-name arg]] - (exec [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) + (exec [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (map vector ?classes ?args)) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) (prepare-return! *type*))]] @@ -184,14 +184,15 @@ (defn [compile *type* ?class ?method ?classes ?object ?args] ;; (prn 'compile-jvm-invokevirtual ?classes *type*) (exec [*writer* &/get-writer - :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] - _ (&/map% (fn [[class-name arg]] - (exec [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) + _ (&/map% (fn [class-name+arg] + (|let [[class-name arg] class-name+arg] + (exec [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret)))) + (&/zip2 ?classes ?args)) :let [_ (doto *writer* (.visitMethodInsn (&host/->class ?class) ?method method-sig) (prepare-return! *type*))]] @@ -229,10 +230,10 @@ (.visitTypeInsn Opcodes/NEW class*) (.visitInsn Opcodes/DUP))] _ (&/map% (fn [[class-name arg]] - (exec [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) + (exec [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (map vector ?classes ?args)) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] (return nil))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 22018808a..c1763818d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -13,7 +13,8 @@ [lux.analyser.base :as &a] (lux.compiler [base :as &&] [lambda :as &&lambda]) - :reload) + ;; :reload + ) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -124,14 +125,11 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] (return nil))) -(defn compile-call [compile *type* ?fn ?args] +(defn compile-apply [compile *type* ?fn ?arg] (exec [*writer* &/get-writer _ (compile ?fn) - _ (&/map% (fn [arg] - (exec [ret (compile arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]] - (return ret))) - ?args)] + _ (compile ?arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]] (return nil))) (defn compile-get [compile *type* ?slot ?record] @@ -239,7 +237,7 @@ current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) (doto (.visitEnd))))] - :let [_ (prn 'compile-def/pre-body)] + ;; :let [_ (prn 'compile-def/pre-body)] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (exec [*writer* &/get-writer :let [_ (.visitCode *writer*)] @@ -252,9 +250,10 @@ (.visitMaxs 0 0) (.visitEnd))]] (return nil))) - :let [_ (prn 'compile-def/post-body)] + ;; :let [_ (prn 'compile-def/post-body)] :let [_ (.visitEnd *writer*)] - :let [_ (prn 'compile-def/_1 ?name current-class)] + ;; :let [_ (prn 'compile-def/_1 ?name current-class)] _ (&&/save-class! current-class (.toByteArray =class)) - :let [_ (prn 'compile-def/_2 ?name)]] + ;; :let [_ (prn 'compile-def/_2 ?name)] + ] (return nil))) diff --git a/src/lux/host.clj b/src/lux/host.clj index e76f6625f..267f77eb6 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -3,7 +3,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail*]] + (lux [base :as & :refer [exec return* return fail fail* |let]] [parser :as &parser] [type :as &type]))) @@ -30,9 +30,9 @@ ))) (defn ^:private method->type [method] - (exec [=args (&/map% class->type (seq (.getParameterTypes method))) + (exec [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method)))) =return (class->type (.getReturnType method))] - (return [=args =return]))) + (return =return))) ;; [Resources] (defn full-class [class-name] @@ -130,10 +130,15 @@ :when (and (= target (.getDeclaringClass =method)) (= method-name (.getName =method)) (= (java.lang.reflect.Modifier/isStatic (.getModifiers =method))) - (= args (mapv #(.getName %) (.getParameterTypes =method))))] + (&/fold #(and %1 %2) + true + (&/|map (fn [xy] + (|let [[x y] xy] + (= x y))) + (&/zip2 args + (&/|map #(.getName %) (&/->list (seq (.getParameterTypes =method))))))))] =method))] - (exec [=method (method->type method)] - (return =method)) + (method->type method) (fail (str "[Analyser Error] Method does not exist: " target method-name))))) lookup-static-method true diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index bebf9423e..cbdf24ff4 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -35,10 +35,10 @@ (def ^:private lex-text-body (&/try-all% (&/|list (exec [[prefix escaped] (lex-regex2 #"(?s)^([^\"\\]*)(\\.)") - unescaped (escape-char escaped) - postfix lex-text-body] - (return (str prefix unescaped postfix))) - (lex-regex #"(?s)^([^\"\\]*)")))) + unescaped (escape-char escaped) + postfix lex-text-body] + (return (str prefix unescaped postfix))) + (lex-regex #"(?s)^([^\"\\]*)")))) (def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)(;[0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]+)?") @@ -56,16 +56,16 @@ (def ^:private lex-multi-line-comment (exec [_ (lex-prefix "#(") comment (&/try-all% (&/|list (lex-regex #"(?is)^((?!#\().)*?(?=\)#)") - (exec [pre (lex-regex #"(?is)^(.+?(?=#\())") - [_ inner] lex-multi-line-comment - post (lex-regex #"(?is)^(.+?(?=\)#))")] - (return (str pre "#(" inner ")#" post))))) + (exec [pre (lex-regex #"(?is)^(.+?(?=#\())") + [_ inner] lex-multi-line-comment + post (lex-regex #"(?is)^(.+?(?=\)#))")] + (return (str pre "#(" inner ")#" post))))) _ (lex-prefix ")#")] (return (&/V "Comment" comment)))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment - lex-multi-line-comment))) + lex-multi-line-comment))) (do-template [ ] (def @@ -80,8 +80,8 @@ (def ^:private lex-char (exec [_ (lex-prefix "#\"") token (&/try-all% (&/|list (exec [escaped (lex-regex #"^(\\.)")] - (escape-char escaped)) - (lex-regex #"^(.)"))) + (escape-char escaped)) + (lex-regex #"^(.)"))) _ (lex-prefix "\"")] (return (&/V "Char" token)))) @@ -111,21 +111,21 @@ (def ^:private lex-delimiter (&/try-all% (&/|list lex-open-paren - lex-close-paren - lex-open-bracket - lex-close-bracket - lex-open-brace - lex-close-brace))) + lex-close-paren + lex-open-bracket + lex-close-bracket + lex-open-brace + lex-close-brace))) ;; [Exports] (def lex (&/try-all% (&/|list lex-white-space - lex-comment - lex-bool - lex-real - lex-int - lex-char - lex-text - lex-ident - lex-tag - lex-delimiter))) + lex-comment + lex-bool + lex-real + lex-int + lex-char + lex-text + lex-ident + lex-tag + lex-delimiter))) diff --git a/src/lux/macro.clj b/src/lux/macro.clj index b822426ff..91d71cf39 100644 --- a/src/lux/macro.clj +++ b/src/lux/macro.clj @@ -6,6 +6,7 @@ ;; [Resources] (defn expand [loader macro-class tokens] (fn [state] + (prn 'expand macro-class tokens state) (-> (.loadClass loader macro-class) (.getField "_datum") (.get nil) diff --git a/src/lux/type.clj b/src/lux/type.clj index 927110cc6..a77baf191 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -160,7 +160,7 @@ (return type) ))) -(defn ^:private show-type [type] +(defn show-type [type] (prn 'show-type (aget type 0)) (matchv ::M/objects [type] [["Any" _]] @@ -217,7 +217,8 @@ (str "Type " (show-type expected) " does not subsume type " (show-type actual))) (defn solve [expected actual] - (prn 'solve (aget expected 0) (aget actual 0)) + ;; (prn 'solve expected actual) + ;; (prn 'solve (aget expected 0) (aget actual 0)) (matchv ::M/objects [expected actual] [["Any" _] _] success @@ -289,6 +290,11 @@ [["Nothing" _] _] (return y) + ;;; + + [_ _] + (return x) + ;; [["Variant" x!cases] ["Variant" y!cases]] ;; (if (and (reduce && true ;; (for [[xslot xtype] (keys x!cases)] @@ -312,7 +318,7 @@ ;; (fail (str "Incompatible records: " (pr-str x) " and " (pr-str y)))) [_ _] - (fail (str "Can't merge types: " (pr-str x) " and " (pr-str y)))))) + (fail (str "[Type System] Can't merge types: " (pr-str x) " and " (pr-str y)))))) (defn apply-lambda [func param] (matchv ::M/objects [func] @@ -321,7 +327,9 @@ (return output)) [_] - (fail (str "Can't apply type " (str func) " to type " (str param))))) + (return (&/V "Any" nil)) + ;; (fail (str "[Type System] Can't apply type " (str func) " to type " (str param))) + )) (defn slot-type [record slot] (fn [state] -- cgit v1.2.3