From 38fe9e91f451d9682ff7edf65fc395b85ddde961 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 10 Feb 2015 02:04:46 -0400 Subject: Super refactoring that breaks the system: Part 1 --- source/lux.lux | 1008 ++++++++++++++++++++++++++---------- source/luxc/lexer.lux | 119 +++++ source/luxc/parser.lux | 72 +++ source/luxc/util.lux | 169 +++++++ source/util.lux | 169 ------- src/lux.clj | 86 ++++ src/lux/analyser.clj | 1322 ++++++++++++++++++++++-------------------------- src/lux/compiler.clj | 784 +++++++++++++--------------- src/lux/host.clj | 98 ++++ src/lux/lexer.clj | 2 +- src/lux/macros.clj | 69 +++ src/lux/parser.clj | 18 +- src/lux/type.clj | 330 ++++++++---- src/lux/util.clj | 72 ++- 14 files changed, 2592 insertions(+), 1726 deletions(-) create mode 100644 source/luxc/lexer.lux create mode 100644 source/luxc/parser.lux create mode 100644 source/luxc/util.lux delete mode 100644 source/util.lux create mode 100644 src/lux/host.clj create mode 100644 src/lux/macros.clj diff --git a/source/lux.lux b/source/lux.lux index 63ab93a4c..4a53e088b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1,66 +1,66 @@ ## Base interfaces & classes -(jvm:interface Function +(jvm;interface Function (: apply (-> [java.lang.Object] java.lang.Object))) -(jvm:class Tuple0 java.lang.Object +(jvm;class Tuple0 java.lang.Object []) -(jvm:class Tuple1 java.lang.Object +(jvm;class Tuple1 java.lang.Object [[java.lang.Object _1]]) -(jvm:class Tuple2 java.lang.Object +(jvm;class Tuple2 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2]]) -(jvm:class Tuple3 java.lang.Object +(jvm;class Tuple3 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3]]) -(jvm:class Tuple4 java.lang.Object +(jvm;class Tuple4 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4]]) -(jvm:class Tuple5 java.lang.Object +(jvm;class Tuple5 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5]]) -(jvm:class Tuple6 java.lang.Object +(jvm;class Tuple6 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6]]) -(jvm:class Tuple7 java.lang.Object +(jvm;class Tuple7 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6] [java.lang.Object _7]]) -(jvm:class Tuple8 java.lang.Object +(jvm;class Tuple8 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6] [java.lang.Object _7] [java.lang.Object _8]]) -(jvm:class Variant java.lang.Object +(jvm;class Variant java.lang.Object [[java.lang.String tag]]) -(jvm:class Variant0 lux.Variant +(jvm;class Variant0 lux.Variant []) -(jvm:class Variant1 lux.Variant +(jvm;class Variant1 lux.Variant [[java.lang.Object _1]]) -(jvm:class Variant2 lux.Variant +(jvm;class Variant2 lux.Variant [[java.lang.Object _1] [java.lang.Object _2]]) -(jvm:class Variant3 lux.Variant +(jvm;class Variant3 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3]]) -(jvm:class Variant4 lux.Variant +(jvm;class Variant4 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4]]) -(jvm:class Variant5 lux.Variant +(jvm;class Variant5 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5]]) -(jvm:class Variant6 lux.Variant +(jvm;class Variant6 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6]]) -(jvm:class Variant7 lux.Variant +(jvm;class Variant7 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6] [java.lang.Object _7]]) -(jvm:class Variant8 lux.Variant +(jvm;class Variant8 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6] @@ -71,299 +71,785 @@ (def' lambda (lambda' _ tokens (lambda' _ state - (let' output (case tokens - (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))) - (#Form (#Cons (#Ident "lambda'") - (#Cons self - (#Cons arg - (#Cons (case args' - #Nil - body - - _ - (#Form (#Cons (#Ident "lux:lambda") - (#Cons (#Tuple args') - (#Cons body #Nil))))) - #Nil))))) - - (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)) - (#Form (#Cons (#Ident "lambda'") - (#Cons (#Ident "_") - (#Cons arg - (#Cons (case args' - #Nil - body - - _ - (#Form (#Cons (#Ident "lux:lambda") - (#Cons (#Tuple args') - (#Cons body #Nil))))) - #Nil)))))) + (let' output (case' tokens + (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))) + (#Form (#Cons (#Ident "lambda'") + (#Cons self + (#Cons arg + (#Cons (case args' + #Nil + body + + _ + (#Form (#Cons (#Ident "lux;lambda") + (#Cons (#Tuple args') + (#Cons body #Nil))))) + #Nil))))) + + (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)) + (#Form (#Cons (#Ident "lambda'") + (#Cons (#Ident "_") + (#Cons arg + (#Cons (case args' + #Nil + body + + _ + (#Form (#Cons (#Ident "lux;lambda") + (#Cons (#Tuple args') + (#Cons body #Nil))))) + #Nil)))))) [(#Cons output #Nil) state])))) (annotate def Macro) (def' def (lambda [tokens state] - (let' output (case tokens - (#Cons (#Ident name) (#Cons body #Nil)) - (#Form (#Cons (#Ident "def'") - (#Cons (#Ident name) - (#Cons body #Nil)))) - - (#Cons (#Form (#Cons (#Ident name) args)) - (#Cons body #Nil)) - (#Form (#Cons (#Ident "def'") - (#Cons (#Ident name) - (#Cons (#Form (#Cons (#Ident "lux:lambda") - (#Cons (#Ident name) - (#Cons (#Tuple args) - (#Cons body #Nil))))) - #Nil))))) - [(#Cons output #Nil) state]))) + (let' output (case' tokens + (#Cons (#Ident name) (#Cons body #Nil)) + (#Form (#Cons (#Ident "def'") + (#Cons (#Ident name) + (#Cons body #Nil)))) + + (#Cons (#Form (#Cons (#Ident name) args)) + (#Cons body #Nil)) + (#Form (#Cons (#Ident "def'") + (#Cons (#Ident name) + (#Cons (#Form (#Cons (#Ident "lux:lambda") + (#Cons (#Ident name) + (#Cons (#Tuple args) + (#Cons body #Nil))))) + #Nil))))) + [(#Cons output #Nil) state]))) (def (+ x y) - (jvm:iadd x y)) + (jvm;iadd x y)) (def (id x) x) -(def (fold f init values) - (case values - #Nil - init - - (#Cons x xs) - (fold f (f init x) xs))) +(def (print x) + (jvm;invokevirtual java.io.PrintStream "print" [Object] + (jvm;getstatic System out) [x])) -(def (reverse list) - (fold (lambda [tail head] (#Cons head tail)) +(def (println x) + (jvm;invokevirtual java.io.PrintStream "println" [Object] + (jvm;getstatic System out) [x])) + +(def (fold f init xs) + (do (print "fold ") (print init) (print " ") (println xs) + (case' xs #Nil - list)) + init + + (#Cons x xs') + (let' init' (f init x) + (do (print "init': ") (println init') + (fold f init' xs'))) + #((fold f (f init x) xs'))# + ))) + +(def (reverse list) + (do (print "reverse ") (println list) + (let' reversed (fold (lambda [tail head] + (do (print "reverse/0 ") (print "tail: ") (print tail) (print " head: ") (println head) + (#Cons head tail))) + #Nil + list) + (do (print "!reversed ") (println reversed) + reversed)))) (annotate list Macro) (def (list xs state) - (let' output (fold (lambda [tail head] - (#Form (#Cons (#Tag "Cons") - (#Cons head - (#Cons tail #Nil))))) - (#Tag "Nil") - (reverse xs)) - [(#Cons output #Nil) state])) + (let' xs' (reverse xs) + (let' output (fold (lambda [tail head] + (do (print "tail: ") (print tail) (print " head: ") (println head) + (#Form (#Cons (#Tag "Cons") + (#Cons head + (#Cons tail #Nil)))))) + (#Tag "Nil") + (do (print "REVERSED: ") (println xs') + xs')) + (do (print "output: ") (println output) + [(#Cons output #Nil) state])))) (annotate list+ Macro) (def (list+ xs state) - (case (reverse xs) + (case' (reverse xs) #Nil [#Nil state] (#Cons last init') (let' output (fold (lambda [tail head] - (#Form (#Cons (#Tag "Cons") - (#Cons head tail)))) + (#Form (#Cons (#Tag "Cons") + (#Cons head tail)))) last init') [(#Cons output #Nil) state]))) (def (->pairs xs) - (case xs + (case' xs (#Cons x (#Cons y xs')) (#Cons [x y] (->pairs xs')) _ #Nil)) -#((annotate let Macro) - (def (let tokens state) - (case tokens - (#Cons (#Tuple bindings) (#Cons body #Nil)) - (let' output (fold (lambda [body binding] - (case binding - [label value] - (#Form (list (#Ident "let'") label value body)))) - body - (reverse (->pairs bindings))) - [(list output) state]))))# - (annotate let Macro) (def (let tokens state) - (case tokens - (#Cons (#Tuple bindings) (#Cons body #Nil)) - (let' output (fold (lambda [body binding] - (case binding - [label value] - (#Form (#Cons (#Ident "let'") (#Cons label (#Cons value (#Cons body #Nil))))))) - body - (reverse (->pairs bindings))) - [(list output) state]))) - -(def (++ xs ys) - (case xs + (case' tokens + (#Cons (#Tuple bindings) (#Cons body #Nil)) + (let' output (fold (lambda [body binding] + (case binding + [label value] + (#Form (list (#Ident "let'") label value body)))) + body + (reverse (->pairs bindings))) + [(list output) state]))) + +(def (++-list xs ys) + (case' xs #Nil ys (#Cons x xs*) - (#Cons x (++ xs* ys)))) + (#Cons x (++-list xs* ys)))) -(def (map f xs) - (case xs +(def (map-list f xs) + (case' xs #Nil #Nil (#Cons x xs*) - (#Cons (f x) (map f xs*)))) + (#Cons (f x) (map-list f xs*)))) #( - (def (untemplate-list untemplate tokens) - (case tokens - #Nil - (#Tag "Nil") +(def (untemplate-list untemplate tokens) +(case tokens +#Nil +(#Tag "Nil") + +(#Cons token tokens') +(#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) + +(def (untemplate token) +(case token +(#Bool elem) +(#Form (list (#Tag "Bool") (#Bool elem))) + +(#Int elem) +(#Form (list (#Tag "Int") (#Int elem))) + +(#Real elem) +(#Form (list (#Tag "Real") (#Real elem))) + +(#Char elem) +(#Form (list (#Tag "Char") (#Char elem))) - (#Cons token tokens') - (#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) +(#Text elem) +(#Form (list (#Tag "Text") (#Text elem))) - (def (untemplate token) - (case token - (#Bool elem) - (#Form (list (#Tag "Bool") (#Bool elem))) +(#Tag elem) +(#Form (list (#Tag "Tag") (#Text elem))) - (#Int elem) - (#Form (list (#Tag "Int") (#Int elem))) +(#Ident elem) +(#Form (list (#Tag "Ident") (#Text elem))) - (#Real elem) - (#Form (list (#Tag "Real") (#Real elem))) +(#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) +unquoted + +(#Tuple elems) +(#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) + +(#Form elems) +(#Form (list (#Tag "Form") (untemplate-list untemplate elems))) +)) + + +## I/O +(def (print x) +(jvm;invokevirtual java.io.PrintStream "print" [Object] +(jvm;getstatic System out) [x])) + +(def (println x) +(jvm;invokevirtual java.io.PrintStream "println" [Object] +(jvm;getstatic System out) [x])) + +(annotate ' Macro) +(def (' form) +(case form +(#Cons token #Nil) +(untemplate token))) + +(def (+ x y) +(jvm;iadd x y)) + +(def inc (+ 1)) + +(def length (fold (lambda' l (lambda' x (inc l))) 0)) + +(def (rem dividend divisor) +(jvm;irem dividend divisor)) + +(def (= x y) +(jvm;invokevirtual Object "equals" [Object] +x [y])) + +(def (pairs list) +(case list +(#Cons x (#Cons y list*)) +(#Cons [x y] (pairs list*)) + +_ +#Nil)) + +(def (show x) +(jvm;invokevirtual Object "toString" [] +x [])) + +(def (concat t1 t2) +(jvm;invokevirtual String "concat" [String] +t1 [t2])) + +(def (range from to) +(if (= from to) +#Nil +(#Cons from (range (inc from) to)))) + +(def (text->list text) +(let' length (jvm;invokevirtual String "length" [] +text []) +(map (lambda' idx +(jvm;invokevirtual String "charAt" [int] +text [idx])) +(range 0 length)))) + +(def (enumerate list) +(case (fold (lambda' state +(lambda' x +(case state +[idx list'] +[(inc idx) (#Cons [idx x] list')]))) +[0 #Nil] +list) +[_ list'] +(reverse list'))) + +(def list-map #Nil) + +(def (put key val map) +(case map +#Nil +(#Cons [key val] map) + +(#Cons [?key ?val] map') +(if (= key ?key) +(#Cons [?key val] map') +(#Cons [?key ?val] (put key val map'))))) + +(def (get key map) +(case map +#Nil +#None + +(#Cons [?key ?val] map') +(if (= key ?key) +(#Some ?val) +(get key map')))) + +(def (show-kv kv) +(case kv +[?key ?val] +(fold concat "" (list "#" ?key " " (show ?val))))) + +(def (interpose elem list) +(case list +(#Cons x (#Cons y list')) +(list+ x elem y (interpose elem list')) + +_ +list)) + +(def (show-list xs) +(case xs +#Nil +"#Nil" + +(#Cons x xs') +(fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) + +(defsig (Equal x) +(: = (-> x x Bool))) + +(deftype Equal (All [x r] {#= (-> x x Bool) & r})) +(deftype Equal (All [x] {#= (-> x x Bool)})) +(deftype Equal (All [x] (Exists [r] {#= (-> x x Bool) & r}))) + +(defimpl (Equal Bool) +(def (= x y) +(case [x y] +[ true true] true +[false false] true +_ false))) + +(def Equal_Bool +(struct {#= [(-> Bool Bool Bool) +(lambda [x y] ...)]})) + +(: (~ g!Equal) (Equal Bool)) +(: (~ g!Equal) {#= (-> Bool Bool Bool)}) +(def (~ g!Equal) +{#= (lambda [x y] ...)}) + +(def Equal_List +(lambda [Equal_x] +(struct {#= }))) + +(: Equal_List +(All [x] (-> (Equal x) (Equal (List x))))) + +(defimpl (All [x] +(=> [(Equal x)] +(Equal (List x)))) +(def (= xs1 xs2) +(case [xs1 xs2] +[#Nil #Nil] +true + +[(#Cons x1 xs1') (#Cons x2 xs2')] +(and (Equal_x x1 x2) (= xs1' xs2'))))) + +(All [x] +(-> (Equal x) (Equal (List x)))) + +(EqualList EqualBool) => {#= ...} + +(: ops (List (Exists [a] [(-> Text a) (-> a [])]))) +(def ops (list [(lambda [_] 10) (lambda [_] [])] +[(lambda [_] "") (lambda [_] [])])) + +(case ops +#Nil +[] + +(#Cons [f1 f2] ops') +(f2 (f1 "E"))) + +(defsig (Add x) +(: + (-> x x x))) + +(defimpl AddInt (Add Int) +#defs +(def (+ x y) +(jvm;ladd x y))) + +(defimpl (Add Int) +(def (+ x y) +(jvm;ladd x y))) + +(: adder (All [x] (=> [(Add x)] +(-> x (-> x x))))) +(def (adder by) +(lambda [x] (+ by x))) + +(adder AddInt 1) -> (lambda [x] ((get@ #+ AddInt) 1 x)) +adder == (lambda [impl] +(case impl +{#+ +} +(lambda [x] (+ by x)))) + +(: calc (All [v] +(-> (-> v Int) +(| (#Add Int Int) (#Mul Int Int) & v) +Int))) +(def (calc backup expr) +(case expr +(#Add x y) (+ x y) +(#Mul x y) (* x y) +else (backup else))) + +(defsig Yolo +(: lol? (-> Text Bool)) +(: foo Int)) + +(defimpl Meme [Yolo] +(def (lol? _) true) +(def foo 10)) + +(defimpl Nyan [Yolo] +Meme +(def foo 20)) + +(list 1 2 3) == (#Cons 1 (#Cons 2 (#Cons 3 #Nil))) +(list+ 1 2 (list 3)) + +(defsig (Monoid a) +(: empty a) +(: ++ (BinaryOp a))) + +(: concat (All [a] +(=> [(Monoid a)] +(-> (List a) a)))) +(def (concat mon +xs) +(fold (:: mon #++) (:: mon #empty) xs)) + +(defstruct (Monoid Text) +(def empty "") +(def (++ x y) +...)) + +(defstruct (All [a] +(Monoid (List a))) +(def empty (list)) +(def (++ xs ys) +(case xs +#Nil +ys - (#Char elem) - (#Form (list (#Tag "Char") (#Char elem))) +(#Cons x xs') +(#Cons x (++ xs' ys))))) - (#Text elem) - (#Form (list (#Tag "Text") (#Text elem))) +(: map (All [a b] (-> (-> a b) (List a) (List b)))) - (#Tag elem) - (#Form (list (#Tag "Tag") (#Text elem))) - - (#Ident elem) - (#Form (list (#Tag "Ident") (#Text elem))) - - (#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) - unquoted - - (#Tuple elems) - (#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) - - (#Form elems) - (#Form (list (#Tag "Form") (untemplate-list untemplate elems))) - )) - - - ## I/O - (def (print x) - (jvm:invokevirtual java.io.PrintStream "print" [Object] - (jvm:getstatic System out) [x])) - - (def (println x) - (jvm:invokevirtual java.io.PrintStream "println" [Object] - (jvm:getstatic System out) [x])) - - (annotate ' Macro) - (def (' form) - (case form - (#Cons token #Nil) - (untemplate token))) - - (def (+ x y) - (jvm:iadd x y)) - - (def inc (+ 1)) - - (def length (fold (lambda' l (lambda' x (inc l))) 0)) - - (def (rem dividend divisor) - (jvm:irem dividend divisor)) - - (def (= x y) - (jvm:invokevirtual Object "equals" [Object] - x [y])) - - (def (pairs list) - (case list - (#Cons x (#Cons y list*)) - (#Cons [x y] (pairs list*)) - - _ - #Nil)) - - (def (show x) - (jvm:invokevirtual Object "toString" [] - x [])) - - (def (concat t1 t2) - (jvm:invokevirtual String "concat" [String] - t1 [t2])) - - (def (range from to) - (if (= from to) - #Nil - (#Cons from (range (inc from) to)))) - - (def (text->list text) - (let' length (jvm:invokevirtual String "length" [] - text []) - (map (lambda' idx - (jvm:invokevirtual String "charAt" [int] - text [idx])) - (range 0 length)))) - - (def (enumerate list) - (case (fold (lambda' state - (lambda' x - (case state - [idx list'] - [(inc idx) (#Cons [idx x] list')]))) - [0 #Nil] - list) - [_ list'] - (reverse list'))) - - (def list-map #Nil) - - (def (put key val map) - (case map - #Nil - (#Cons [key val] map) - - (#Cons [?key ?val] map') - (if (= key ?key) - (#Cons [?key val] map') - (#Cons [?key ?val] (put key val map'))))) - - (def (get key map) - (case map - #Nil - #None - - (#Cons [?key ?val] map') - (if (= key ?key) - (#Some ?val) - (get key map')))) - - (def (show-kv kv) - (case kv - [?key ?val] - (fold concat "" (list "#" ?key " " (show ?val))))) - - (def (interpose elem list) - (case list - (#Cons x (#Cons y list')) - (#Cons x (#Cons elem (#Cons y list'))) - - _ - list)) - - (def (show-list xs) - (case xs - #Nil - "#Nil" - (#Cons x xs') - (fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) - - )# +(defsig (Collection c) +(: add (All [x] (-> x (c x) (c x)))) +(: length (All [x] (-> (c x) Int)))) + +(defclass (Stack s) +(: push (All [x] (-> x (s x) (s x)))) +(: pop (All [x] (-> (s x) (s x)))) +(: peek (All [x] (-> (s x) (Maybe x))))) + +(deftype (BinaryOp t) +(-> t t t)) + +(defclass (Number n) +(: + (BinaryOp n)) +(: - (BinaryOp n)) +(: * (BinaryOp n)) +(: / (BinaryOp n))) + +(def (flip f) +(lambda [x y] +(f y x))) + +(def (concat' xss) +(case (reverse xss) +#Nil +#Nil + +(#Cons xs xss') +(fold (flip ++) xs xss'))) + +n + n*m + +(with [AddInt] +(+ 10 20)) + +(:: AddInt (+ 10 20)) == ((get@ AddInt #=) 10 20) + +(defimpl (Stack List) +(def (push x xs) +(#Cons x xs)) + +(def (pop xs) +(case xs +#Nil #Nil +(#Cons _ xs') xs')) + +(def (peek xs) +(case xs +#Nil #None +(#Cons x _) (#Some x)))) + +(defsig (Functor f) +(: map (All [a b] (-> (-> a b) (f a) (f b))))) + +(def (Functor f) +{#map (All [a b] (-> (-> a b) (f a) (f b)))}) + +(defimpl ListFunctor (Functor List) +(def (map func fa) +(case fa +#Nil +#Nil + +(list a fa') +(list (func a) (map func fa'))))) + +(implicit ListFunctor +(map inc (list 1 2 3))) + +(defsig (=> [(Functor m)] +(Monad m)) +(: return (All [x] (-> x (m x)))) +(: bind (All [a b] (-> (m a) (-> a (m b)) (m b))))) + + + +(#User {#name Text #age Int}) +(deftype User {#name Text #age Int}) +(deftype User (& (#name Text) +(#age Int))) +(deftype User (All [r] +(& (#name Text) +(#age Int) +++ r))) +(def User (#Record (list ["name" Text] ["age" Int]))) + +(let [thunk (... (+ 5 6))] +(! thunk)) + +(Thunk Int) + + +(deftype Int&Bool [Int Bool]) + +(deftype (List a) +(| #Nil +(#Cons a (List a)))) + +(defclass (Equal a) +(: = (-> a a Bool))) +== +(deftype (Equal a) +{#= (-> a a Bool)}) + +(def Equals +(All [a] {#= (-> a a Bool)})) + +(defimpl EqualBool [(Equal Bool)] +(def (= x y) +(if x +y +(not y)))) + +(def ... {#= (lambda [x y] (if x +y +(not y)))}) + +(def Class (All [I] +(Exists [S] (& (#state S) +(#methods (I S)))))) + +(definterface Vector +(: translate (BinaryOp Vector))) + +(def Vector (Some [Vector] +(& (#translate (BinaryOp v))))) + +(defclass Vector2D +{#x Real, #y Real} +(def (new-Vector2D x y) +{#x x, #y y}) +Vector +(def (translate self offset) +(-> self +(update@ #x + (get@ offset #x)) +(update@ #y + (get@ offset #y))))) + +(def Vector2D +{#translate (: (lambda [self offset] +(-> self +(update@ #x +real (get@ offset #x)) +(update@ #y +real (get@ offset #y)))) +(BinaryOp {#x Real, #y Real}))}) + +(: new-Vector2D (-> Real Real [{#x Real, #y Real} (@class Vector2D)])) +(def (new-Vector2D x y) +[{#x x, #y y} Vector2D]) + +(defsig (Vector v) +(: translate (BinaryOp v)) +(: scale (BinaryOp v))) + +(def Vector (All Vector [v] +(& (#translate (BinaryOp v)) +(#scale (BinaryOp v))))) + +(defstruct Vector2D (Vector [Real Real]) +(def (translate [x1 y1] [x2 y2]) +[(+ x1 x2) (+ y1 y2)]) +(def (scale [x1 y1] [x2 y2]) +[(* x1 x2) (* y1 y2)])) + +(def Vector2D (: {#translate (lambda [[x1 y1] [x2 y2]] +[(+real x1 x2) (+real y1 y2)]) +#scale (lambda [[x1 y1] [x2 y2]] +[(*real x1 x2) (*real y1 y2)])} +(Vector [Real Real]))) + +(deftype (Stream a) +(| (#Cons a (Thunk (Stream a))))) + +(: iterate (All [a] (-> (-> a a) a (Stream a)))) +(def (iterate f init) +(list init (... (iterate f (f init))))) + +(def (take n stream) +(if (<= n 0) +#Nil +(case stream +(#Cons x stream') +(#Cons x (take (dec n) stream'))))) + +(deftype (Stream a) +(All [b] (-> (-> a (Stream a b) b) b))) + +(: iterate (All [a] (-> (-> a a) a (Stream a)))) +(def (iterate f init) +(lambda [k] +(k init (iterate f (f init))))) + +(def (repeat x) +(lambda [k] (k x (repeat x)))) + +(def (take n stream) +(if (<= n 0) +#Nil +(stream (lambda [x stream'] +(#Cons x (take (dec n) stream')))))) + +(defsig (Comonad w) +(: extract (All [a] (-> (w a) a))) +(: extend (All [a b] (-> (w a) (-> (w a) b) (w b))))) + +(defstruct Stream (Comonad w) +(def (extract stream) +(stream (lambda [x _] x))) +(def (extend w f) +...)) + +(: fibonacci (Stream Int)) +(def fibonacci ((lambda fibonacci [a b] +(lambda [k] (k a (fibonacci b (+ a b))))) +0 1)) + +(gen fibonacci [a 0 b 1] +(yield a (fibonacci b (+ a b)))) + +(defgen fibonacci [a 0 b 1] +(yield a (fibonacci b (+ a b)))) + +(gen fibonacci [a 0 b 1] +(yield a [b (+ a b)])) + +## The dual of do-notation should be be-notation + +(deftype (Stream a) +(| (#Cons a (Thunk (Stream a))))) + +(defstruct (Functor Stream) +(def (map f s) +(lambda [k] +(stream (lambda [x stream'] +(f s)))))) + +(deftype (Tape a) +(| (#Index (Thunk (Stream a)) a (Thunk (Stream a))))) + +(deftype (Area a) +(| (#Cursor (Tape a) (Surreal a)))) + +(def (ints offset n) +(#Index (... (iterate (lambda [n'] (- n' offset)) n)) +n +(... (iterate (+ offset) n)))) + +(def (reals offset x) +(#Cursor (ints offset x) +(reals (/ offset 10) 0))) +)# + +#( +(deftype (Session i o s) + (All [s' r] + (-> (-> i s' r) + (-> o s [i s']) + r)) + + (All [s' s''] (-> (-> c s' [p s'']) + (-> [] s [c s']) (Session c p s) + [p s''])) + (All [] (-> (-> c s p) + (-> p []))) + (All [r] (-> c (Session r p s) p))) + +(Session Int [] (Session Int (Session [] Int ))) + +(bind (session' []) + (lambda [x session'] + (bind (session' []) + (lambda [y session''] + (session'' (+ x y)))))) + +(defstruct SessionMonad + (Monad Session) + (def (return v) + (lambda [k session] + (k v session))) + (def (bind step m-value) + (lambda [k session] + (let [[v session'] (m-value [] session)] + (k (step v) session'))))) + +## Not really "do"; but oh, well... + +(deftype + (| #Nil)) + +(deftype (HList h t) + (| (#Cons h t))) + +(deftype (Session c p s) + (All [r] (-> c (-> p s r) r))) + +(deftype (Session c p s) + (-> (-> p s c) c)) + +(deftype (? r s) + (Session r [] s)) + +(deftype (! w s) + (Session [] w s)) + +(deftype #rec + (Session [] [] )) + +(def << + (lambda [k session] + (k [] session))) + +(def (>> val) + (lambda [k session] + (session val k))) + +(<$> << (>> 5)) + +(def (<$> consumer producer) + (producer [] consumer)) + +(HList Int (HList Int )) + +(<.> (? Int) (? Int) (! Int) ) +(def fn-session + (do [x << + y <<] + (>> (+ x y)))) + +(<.> (! Int) (! Int) (? Int) ) +(def call-session + (do [_ (>> 5) + _ (>> 10)] + <<)) + +(<$> fn-session call-session) + +(def << + (lambda [chan] + (chan (lambda [])))) + +(def (>> value) + (lambda [chan] + (chan value))) +)# diff --git a/source/luxc/lexer.lux b/source/luxc/lexer.lux new file mode 100644 index 000000000..ed86be68f --- /dev/null +++ b/source/luxc/lexer.lux @@ -0,0 +1,119 @@ +(use ./util #as &util #refer [do return fail try-all]) + +## [Utils] +(def (lex-regex regex) + ...) + +(def (lex-regex2 regex) + ...) + +(def (lex-prefix prefix) + ...) + +(def (escape-char escaped) + (case escaped + "\\t" (return "\t") + "\\b" (return "\b") + "\\n" (return "\n") + "\\r" (return "\r") + "\\f" (return "\f") + "\\\"" (return "\"") + "\\\\" (return "\\") + _ (fail (fold concat "" (list "[Lexer Error] Unknown escape character: " escaped))))) + +(defrec lex-text-body + (try-all (list (do [[prefix escaped] (lex-regex2 "(?s)^([^\\\"\\\\]*)(\\\\.)") + unescaped (escape-char escaped) + postfix lex-text-body] + (return (str prefix unescaped postfix))) + (lex-regex "(?s)^([^\\\"\\\\]*)^")))) + +(def +ident-re+ ...) + +## [Lexers] +(def lex-white-space + (do [white-space (lex-regex #"^(\s+)")] + (return (#White-Space white-space)))) + +(def lex-single-line-comment + (do [_ (lex-prefix "##") + comment (lex-regex #"^([^\n]*)") + _ (lex-regex #"^(\n?)")] + (return (#Comment comment)))) + +(def lex-multi-line-comment + (do [_ (lex-prefix "#(") + comment (try-all (list (lex-regex #"(?is)^((?!#\().)*?(?=\)#)") + (do [pre (lex-regex #"(?is)^(.+?(?=#\())") + [_ inner] lex-multi-line-comment + post (lex-regex #"(?is)^(.+?(?=\)#))")] + (return (fold concat "" (list pre "#(" inner ")#" post)))))) + _ (lex-prefix ")#")] + (return (#Comment comment)))) + +(def lex-comment + (try-all (list lex-single-line-comment + lex-multi-line-comment))) + +(do-template [ ] + (def + (do [token (lex-regex )] + (return ( token)))) + + lex-bool #Bool #"^(true|false)" + lex-real #Real #"^(0|[1-9][0-9]*)\.[0-9]+" + lex-int #Int #"^(0|[1-9][0-9]*)" + lex-ident #Ident +ident-re+) + +(def lex-char + (do [_ (lex-prefix "#\"") + token (try-all (list (do [escaped (lex-regex #"^(\\.)")] + (escape-char escaped)) + (lex-regex #"^(.)"))) + _ (lex-prefix "\"")] + (return (#Char token)))) + +(def lex-text + (do [_ (lex-prefix "\"") + token lex-text-body + _ (lex-prefix "\"")] + (return (#Text token)))) + +(def lex-tag + (do [_ (lex-prefix "#") + token (lex-regex +ident-re+)] + (return (#Tag token)))) + +(do-template [ ] + (def + (do [_ (lex-prefix )] + (return ))) + + lex-open-paren "(" #Open-Paren + lex-close-paren ")" #Close-Paren + lex-open-bracket "[" #Open-Bracket + lex-close-bracket "]" #Close-Bracket + lex-open-brace "{" #Open-Brace + lex-close-brace "}" #Close-Brace + ) + +(def lex-delimiter + (try-all (list lex-open-paren + lex-close-paren + lex-open-bracket + lex-close-bracket + lex-open-brace + lex-close-brace))) + +;; [Interface] +(def #export 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))) diff --git a/source/luxc/parser.lux b/source/luxc/parser.lux new file mode 100644 index 000000000..35ec12b17 --- /dev/null +++ b/source/luxc/parser.lux @@ -0,0 +1,72 @@ +(use ./util #as &util #refer [do return fail try-all repeat]) +(use ./lexer #as &lexer) + +;; [Utils] +(do-template [ ] + (def ( parse) + (do [elems (repeat parse) + token &lexer:lex] + (case token + + (return (list ( (fold ++ (list) elems)))) + + _ + (fail (concat (list "[Parser Error] Unbalanced " ".")))))) + + parse-form #&lexer:Close-Paren "parantheses" #Form + parse-tuple #&lexer:Close-Bracket "brackets" #Tuple + ) + +(def (parse-record parse) + (do [elems* (repeat parse) + token &lexer:lex + #let [elems (fold ++ (list) elems*)]] + (case token + #&lexer:Close-Bracket + (if (odd? (size elems)) + (fail "[Parser Error] Records must have an even number of elements.") + (return (list (#Record elems)))) + + _ + (fail "[Parser Error] Unbalanced braces.")))) + +;; [Interface] +(def parse + (do [token &lexer/lex] + (match token + (#&lexer:White-Space _) + (return (list)) + + (#&lexer:Comment _) + (return (list)) + + (#&lexer:Bool ?value) + (return (list [#Bool (jvm:invokestatic Boolean "parseBoolean" [String] [?value])])) + + (#&lexer:Int ?value) + (return (list [#Int (jvm:invokestatic Integer "parseInt" [String] [?value])])) + + (#&lexer:Real ?value) + (return (list [#Real (jvm:invokestatic Float "parseFloat" [String] [?value])])) + + (#&lexer:Char ?value) + (return (list [#Char (jvm:invokevirtual String "charAt" [int] ?value [0])])) + + (#&lexer:Text ?value) + (return (list [#Text ?value])) + + (#&lexer:Ident ?value) + (return (list [#Ident ?value])) + + (#&lexer:Tag ?value) + (return (list [#Tag ?value])) + + #&lexer:Open-Paren + (parse-form parse) + + #&lexer:Open-Bracket + (parse-tuple parse) + + #&lexer:Open-Brace + (parse-record parse) + ))) diff --git a/source/luxc/util.lux b/source/luxc/util.lux new file mode 100644 index 000000000..88b035571 --- /dev/null +++ b/source/luxc/util.lux @@ -0,0 +1,169 @@ +(def (fail* message) + (#Failure message)) + +(def (return* state value) + (#Ok [state value])) + +(def (fail message) + (lambda [state] + (#Failure message))) + +(def (return value) + (lambda [state] + (#Ok [state value]))) + +(def (bind m-value step) + (lambda [state] + (let inputs (m-value state) + (case inputs + (#Ok [?state ?datum]) + (step ?datum ?state) + + _ + inputs)))) + +## Ideally, this is what I want... +## (exec [yolo lol +## #let [foo (bar 1 2 3)]] +## (meme yolo foo)) + +(defmacro (exec tokens) + (case tokens + (#Cons (#Tuple steps) (#Cons value #Nil)) + (fold (lambda [inner pair] + (case pair + [label computation] + (' (bind (~ computation) (lambda [(~ label)] (~ inner)))))) + value + (pairs steps)))) + +(def (try-m monad) + (lambda [state] + (case (monad state) + (#Ok [?state ?datum]) + (return* ?state (#Just ?datum)) + + (#Failure _) + (return* state #Nothing)))) + +(def (repeat-m monad) + (lambda [state] + (case (monad state) + (#Ok [?state ?head]) + (case ((repeat-m monad) ?state) + (#Ok [?state* ?tail]) + (return* ?state* (#Cons ?head ?tail))) + + (#Failure ?message) + (return* state #Nil)))) + +(def (try-all-m monads) + (lambda [state] + (case monads + #Nil + (fail* "No alternative worked!") + (#Cons monad monads') + (let output (monad state) + (case output + (#Ok _) + output + + (#Failure _) + (case monads' + #Nil + output + (#Cons _ _) + ((try-all-m monads') state)) + )) + ))) + +(def (map-m f inputs) + (case inputs + #Nil + (return #Nil) + (#Cons input inputs') + (exec [output (f input) + outputs (map-m f inputs')] + (return (#Cons output outputs))))) + +(def (fold-m f init inputs) + (case inputs + #Nil (return init) + (#Cons x inputs') (exec [init* (f init x)] + (fold-m f init* inputs')))) + +(def (apply-m monad call-state) + (lambda [state] + (let output (monad call-state) + (case output + (#Ok [?state ?datum]) + (#Ok [state ?datum]) + + _ + output)))) + +(def (assert test message) + (if test + (return []) + (fail message))) + +(def (pass %value) + (lambda [state] + %value)) + +(def get-state + (lambda [state] + (return* state state))) + +(def (normalize-char char) + (case char + #"*" "_ASTER_" + #"+" "_PLUS_" + #"-" "_DASH_" + #"/" "_SLASH_" + #"_" "_UNDERS_" + #"%" "_PERCENT_" + #"$" "_DOLLAR_" + #"'" "_QUOTE_" + #"`" "_BQUOTE_" + #"@" "_AT_" + #"^" "_CARET_" + #"&" "_AMPERS_" + #"=" "_EQ_" + #"!" "_BANG_" + #"?" "_QM_" + #":" "_COLON_" + #";" "_SCOLON_" + #"." "_PERIOD_" + #"," "_COMMA_" + #"<" "_LT_" + #">" "_GT_" + #"~" "_TILDE_" + ##;;#"\" "_BSLASH_" + _ (show char) + )) + +(def (normalize-ident ident) + (fold concat "" (map normalize-char (text->list ident)))) + +(def (within slot monad) + (lambda [state] + (let =return (monad (get slot state)) + (case =return + (#Ok ?state ?value) + (#Ok (put slot ?state state) ?value) + + _ + =return)))) + +(def (run-state monad state) + (monad state)) + +(def (fresh-class-loader path) + (let file (jvm/new java.io.File [String] [path]) + (let url (jvm/invokevirtual java.io.File "toURL" [] + file []) + (let urls (jvm/new-array java.net.URL 1) + (do (jvm/aastore urls 0 url) + (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))) + )) diff --git a/source/util.lux b/source/util.lux deleted file mode 100644 index 88b035571..000000000 --- a/source/util.lux +++ /dev/null @@ -1,169 +0,0 @@ -(def (fail* message) - (#Failure message)) - -(def (return* state value) - (#Ok [state value])) - -(def (fail message) - (lambda [state] - (#Failure message))) - -(def (return value) - (lambda [state] - (#Ok [state value]))) - -(def (bind m-value step) - (lambda [state] - (let inputs (m-value state) - (case inputs - (#Ok [?state ?datum]) - (step ?datum ?state) - - _ - inputs)))) - -## Ideally, this is what I want... -## (exec [yolo lol -## #let [foo (bar 1 2 3)]] -## (meme yolo foo)) - -(defmacro (exec tokens) - (case tokens - (#Cons (#Tuple steps) (#Cons value #Nil)) - (fold (lambda [inner pair] - (case pair - [label computation] - (' (bind (~ computation) (lambda [(~ label)] (~ inner)))))) - value - (pairs steps)))) - -(def (try-m monad) - (lambda [state] - (case (monad state) - (#Ok [?state ?datum]) - (return* ?state (#Just ?datum)) - - (#Failure _) - (return* state #Nothing)))) - -(def (repeat-m monad) - (lambda [state] - (case (monad state) - (#Ok [?state ?head]) - (case ((repeat-m monad) ?state) - (#Ok [?state* ?tail]) - (return* ?state* (#Cons ?head ?tail))) - - (#Failure ?message) - (return* state #Nil)))) - -(def (try-all-m monads) - (lambda [state] - (case monads - #Nil - (fail* "No alternative worked!") - (#Cons monad monads') - (let output (monad state) - (case output - (#Ok _) - output - - (#Failure _) - (case monads' - #Nil - output - (#Cons _ _) - ((try-all-m monads') state)) - )) - ))) - -(def (map-m f inputs) - (case inputs - #Nil - (return #Nil) - (#Cons input inputs') - (exec [output (f input) - outputs (map-m f inputs')] - (return (#Cons output outputs))))) - -(def (fold-m f init inputs) - (case inputs - #Nil (return init) - (#Cons x inputs') (exec [init* (f init x)] - (fold-m f init* inputs')))) - -(def (apply-m monad call-state) - (lambda [state] - (let output (monad call-state) - (case output - (#Ok [?state ?datum]) - (#Ok [state ?datum]) - - _ - output)))) - -(def (assert test message) - (if test - (return []) - (fail message))) - -(def (pass %value) - (lambda [state] - %value)) - -(def get-state - (lambda [state] - (return* state state))) - -(def (normalize-char char) - (case char - #"*" "_ASTER_" - #"+" "_PLUS_" - #"-" "_DASH_" - #"/" "_SLASH_" - #"_" "_UNDERS_" - #"%" "_PERCENT_" - #"$" "_DOLLAR_" - #"'" "_QUOTE_" - #"`" "_BQUOTE_" - #"@" "_AT_" - #"^" "_CARET_" - #"&" "_AMPERS_" - #"=" "_EQ_" - #"!" "_BANG_" - #"?" "_QM_" - #":" "_COLON_" - #";" "_SCOLON_" - #"." "_PERIOD_" - #"," "_COMMA_" - #"<" "_LT_" - #">" "_GT_" - #"~" "_TILDE_" - ##;;#"\" "_BSLASH_" - _ (show char) - )) - -(def (normalize-ident ident) - (fold concat "" (map normalize-char (text->list ident)))) - -(def (within slot monad) - (lambda [state] - (let =return (monad (get slot state)) - (case =return - (#Ok ?state ?value) - (#Ok (put slot ?state state) ?value) - - _ - =return)))) - -(def (run-state monad state) - (monad state)) - -(def (fresh-class-loader path) - (let file (jvm/new java.io.File [String] [path]) - (let url (jvm/invokevirtual java.io.File "toURL" [] - file []) - (let urls (jvm/new-array java.net.URL 1) - (do (jvm/aastore urls 0 url) - (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))) - )) diff --git a/src/lux.clj b/src/lux.clj index 6d2374edb..3e0b3e9c0 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -32,6 +32,92 @@ ])) + + (deftype (Session c p s) + (-> (-> p s c) c)) + + ;; (: bind (All [m a b] + ;; (-> (-> a (m b)) (m a) (m b)))) + + (do (defn >> [v] + (fn [session] + (session v))) + + (defn >> [v] + (client v (fn [_ client*] + (k _ client*)))) + + (def << + (server nil (fn [v server*] + (k v server*)))) + + (defn pipe []) + + (<< (fn [x server*] + (server* nil (fn [y server**] + (server** (+ x y) k))))) + + (def (select' k) + (lambda [msg session] + (session nil (k msg)))) + + (def (choose choice) + (lambda [msg session] + (session choice ...))) + + (def << + (lambda [next peer] + (peer [] (lambda [x peer'] + (next x peer'))))) + + (def (>> x) + (lambda [next peer] + (peer x (lambda [_ peer'] + (next [] peer'))))) + + (def server + (loop [_ []] + (select #Add + (do [x << + y << + _ (>> (+ x y))] + (recur [])) + + #Neg + (do [x << + _ (>> (neg x))] + (recur [])) + + #Quit + end))) + + (def client + (do [_ (choose #Add) + _ (>> 5) + _ (>> 10) + x+y <<] + (choose #Quit))) + + (def + (fn [session] + nil)) + + (bind << (fn [x] + (bind << (fn [y] + (>> (+ x y)))))) + + (do [x << + y <<] + (>> (+ x y))) + + (defn <$> [consumer producer init] + (let [[x producer*] (producer init) + [y consumer*] (consumer x)] + [consumer* producer* y])) + + ((<$> (<< ) ((>> 5) ))) + ) + ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 ;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd .. diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8fd6dfb47..cde2dd9bf 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -1,530 +1,355 @@ (ns lux.analyser - (:refer-clojure :exclude [resolve]) - (:require (clojure [string :as string] - [template :refer [do-template]]) + (:require (clojure [template :refer [do-template]]) [clojure.core.match :refer [match]] (lux [util :as &util :refer [exec return* return fail fail* - repeat-m try-all-m map-m reduce-m - within do-all-m* + repeat-m try-all-m map-m mapcat-m reduce-m + within normalize-ident]] - [lexer :as &lexer] [parser :as &parser] - [type :as &type]))) + [type :as &type] + [macros :as ¯os] + [host :as &host]))) ;; [Util] -(def +int-class+ "java.lang.Integer") +(def ^:private +dont-care-type+ [::&type/Any]) -(def +dont-care-type+ [::&type/object "java.lang.Object" []]) - -(defn ^:private annotated [form type] - {:form form - :type type}) - -(defn fresh-env [name] +(defn ^:private fresh-env [name] {:name name :inner-closures 0 - :counter 0 - :mappings {} - :mappings/closure {} - :closure/id 0}) + :locals &util/+init-env+ + :closure &util/+init-env+}) -(def module-name +(defn ^:private annotate [name access macro? type] (fn [state] - [::&util/ok [state (::current-module state)]])) + (let [full-name (str (::&util/current-module state) &util/+name-separator+ name) + bound [::Expression [::global (::&util/current-module state) name] type]] + [::&util/ok [(-> state + (assoc-in [::&util/modules (::&util/current-module state) name] {:args-n [:None] + :access access + :macro? macro? + :type type + :defined? false}) + (update-in [::&util/global-env] merge {full-name bound, name bound})) + nil]]))) + +(defn ^:private expr-type [syntax+] + (match syntax+ + [::Expression _ type] + (return type) -(def scope - (fn [state] - [::&util/ok [state (::scope state)]])) - -(defn ^:private annotate [name mode access macro? type] - (fn [state] - [::&util/ok [(assoc-in state [::modules (::current-module state) name] {:mode mode - :access access - :macro? macro? - :type type - :defined? false}) - nil]])) + _ + (fail "Can't retrieve the type of a statement."))) (defn ^:private define [name] (fn [state] - (if-let [{:keys [mode type]} (get-in state [::modules (::current-module state) name])] - (let [full-name (str (::current-module state) ":" name) - tag (if (= ::function mode) - ::global-fn - ::global) - bound (annotated [tag (::current-module state) name] type)] - [::&util/ok [(-> state - (assoc-in [::modules (::current-module state) name :defined?] true) - (update-in [::global-env] merge {full-name bound, name bound})) - nil]]) - (fail* (str "Can't define an unannotated element [" name "]"))))) + (if-let [{:keys [type]} (get-in state [::&util/modules (::&util/current-module state) name])] + [::&util/ok [(-> state + (assoc-in [::&util/modules (::&util/current-module state) name :defined?] true) + (update-in [::&util/global-env] merge {full-name bound, name bound})) + nil]] + (fail* (str "[Analyser Error] Can't define an unannotated element: " name))))) (defn ^:private defined? [name] (fn [state] - [::&util/ok [state (get-in state [::modules (::current-module state) name :defined?])]])) + [::&util/ok [state (get-in state [::&util/modules (::&util/current-module state) name :defined?])]])) (defn ^:private annotated? [name] (fn [state] - [::&util/ok [state (boolean (get-in state [::modules (::current-module state) name]))]])) + [::&util/ok [state (boolean (get-in state [::&util/modules (::&util/current-module state) name]))]])) (defn ^:private is-macro? [module name] (fn [state] - [::&util/ok [state (boolean (get-in state [::modules module name :macro?]))]])) + [::&util/ok [state (boolean (get-in state [::&util/modules module name :macro?]))]])) (def ^:private next-local-idx (fn [state] - [::&util/ok [state (-> state ::local-envs first :counter)]])) - -(def ^:private scope-id - (fn [state] - [::&util/ok [state (-> state ::local-envs first :name)]])) - -(defn with-global [top-level-name body] - (exec [$module module-name] - (fn [state] - (let [=return (body (-> state - (update-in [::local-envs] conj (fresh-env top-level-name)) - (assoc ::scope [$module top-level-name])))] - (match =return - [::&util/ok [?state ?value]] - [::&util/ok [(assoc ?state ::scope []) ?value]] - - _ - =return)) - ))) + [::&util/ok [state (-> state ::&util/local-envs first :locals :counter)]])) -(defn with-env [label body] +(defn ^:private with-env [label body] (fn [state] (let [=return (body (-> state - (update-in [::local-envs] conj (fresh-env label)) - (update-in [::scope] conj label)))] + (update-in [::&util/local-envs] conj (fresh-env label)) + (update-in [::&util/scope] conj label)))] (match =return [::&util/ok [?state ?value]] [::&util/ok [(-> ?state - (update-in [::local-envs] rest) - (update-in [::scope] rest)) + (update-in [::&util/local-envs] rest) + (update-in [::&util/scope] rest)) ?value]] _ =return)))) -(defn ^:private with-local [name value body] - (fn [state] - (let [=return (body (update-in state [::local-envs] - (fn [[env & other-envs]] - (cons (assoc-in env [:mappings name] value) - other-envs))))] - (match =return - [::&util/ok [?state ?value]] - [::&util/ok [(update-in ?state [::local-envs] #(cons (update-in (first %) [:mappings] dissoc name) - (rest %))) - ?value]] - - _ - =return) - ))) - -(defn ^:private with-let [name type body] +(defn ^:private with-let [name mode type body] (fn [state] - (let [[top & stack] (::local-envs state) - body* (with-local name (annotated [::local (:name top) (:counter top)] type) - body) - =return (body* (assoc state ::local-envs (cons (update-in top [:counter] inc) stack)))] + (let [old-mappings (-> state ::&util/local-envs first (get-in [:locals :mappings])) + =return (body (update-in state [::&util/local-envs] + (fn [[top & stack]] + (let [bound-unit (case mode + :self [::self (list)] + :local [::local (get-in top [:locals :counter])])] + (cons (-> top + (update-in [:locals :counter] inc) + (assoc-in [:locals :mappings name] [::Expression bound-unit type])) + stack)))))] (match =return [::&util/ok [?state ?value]] - [::&util/ok [(update-in ?state [::local-envs] (fn [[top* & stack*]] - (cons (update-in top* [:counter] dec) - stack*))) + [::&util/ok [(update-in ?state [::&util/local-envs] (fn [[top* & stack*]] + (cons (-> top* + (update-in [:locals :counter] dec) + (assoc-in [:locals :mappings] old-mappings)) + stack*))) ?value]] _ =return)))) -(do-template [ ] - (defn [locals monad] - (reduce (fn [inner [label elem]] - ( label elem inner)) - monad - (reverse locals))) +(defn ^:private with-lets [locals monad] + (reduce (fn [inner [label elem]] + (with-let label :local elem inner)) + monad + (reverse locals))) - ^:private with-locals with-local - ^:private with-lets with-let - ) +(def ^:private captured-vars + (fn [state] + [::&util/ok [state (-> state ::&util/local-envs first :closure :mappings)]])) + +(defn ^:private analyse-n [elems] + (let [num-inputs (count elems)] + (exec [output (mapcat-m analyse-ast elems) + _ (&util/assert! (= num-inputs (count output)) + (str "[Analyser Error] Can't expand to other than " num-inputs " elements."))] + (return output)))) -(def captured-vars +(defn ^:private with-lambda [self self-type arg arg-type body] (fn [state] - [::&util/ok [state (-> state ::local-envs first :mappings/closure)]])) - -(defn with-lambda [self self-type arg arg-type body] - (exec [$module module-name] - (fn [state] - (let [body* (with-env (-> state ::local-envs first :inner-closures str) - (exec [$scope scope] - (with-local self (annotated [::self $scope []] self-type) - (with-let arg arg-type - (exec [=return body - =next next-local-idx - =captured captured-vars] - (return [$scope =next =captured =return]))))))] - (body* (update-in state [::local-envs] #(cons (update-in (first %) [:inner-closures] inc) - (rest %)))) - )))) + (let [body* (with-env (-> state ::&util/local-envs first :inner-closures str) + (exec [$scope &util/get-scope] + (with-let self :self self-type + (with-let arg :local arg-type + (exec [=return body + =next next-local-idx + =captured captured-vars] + (return [$scope =next =captured =return]))))))] + (body* (update-in state [::&util/local-envs] #(cons (update-in (first %) [:inner-closures] inc) + (rest %)))) + ))) (defn ^:private close-over [scope ident register frame] - (let [register* (annotated [::captured scope (:closure/id frame) register] (:type register))] - [register* (-> frame - (update-in [:closure/id] inc) - (assoc-in [:mappings/closure ident] register*))])) + (match register + [::Expression _ register-type] + (let [register* [::Expression [::captured scope (get-in frame [:closure :counter]) register] register-type]] + [register* (-> frame + (update-in [:closure :counter] inc) + (assoc-in [:closure :mappings ident] register*))]))) + +(defn ^:private extract-ident [ident] + (match ident + [::&parser/ident ?ident] + (return ?ident) -(defn ^:private resolve [ident] + _ + (fail ""))) + +(defn ^:private analyse-tuple [analyse-ast ?elems] + (exec [=elems (mapcat-m analyse-ast ?elems) + =elems-types (map-m expr-type =elems) + ;; :let [_ (prn 'analyse-tuple =elems)] + ] + (return (list [::Expression [::tuple =elems] [::&type/Tuple =elems-types]])))) + +(defn ^:private analyse-ident [analyse-ast ident] (fn [state] - ;; (prn 'resolve ident) (let [[top & stack*] (::local-envs state)] - (if-let [=bound (or (get-in top [:mappings ident]) - (get-in top [:mappings/closure ident]))] + (if-let [=bound (or (get-in top [:locals :mappings ident]) + (get-in top [:closure :mappings ident]))] [::&util/ok [state (list =bound)]] - (let [no-binding? #(and (-> % :mappings (contains? ident) not) (-> % :mappings/closure (contains? ident) not)) + (let [no-binding? #(and (-> % :locals :mappings (contains? ident) not) + (-> % :closure :mappings (contains? ident) not)) [inner outer] (split-with no-binding? stack*)] (if (empty? outer) - (if-let [global|import (get-in state [::global-env ident])] + (if-let [global|import (get-in state [::&util/global-env ident])] [::&util/ok [state (list global|import)]] [::&util/failure (str "[Analyser Error] Unresolved identifier: " ident)]) (let [[=local inner*] (reduce (fn [[register new-inner] frame] (let [[register* frame*] (close-over (:name frame) ident register frame)] [register* (cons frame* new-inner)])) - [(or (get-in (first outer) [:mappings ident]) - (get-in (first outer) [:mappings/closure ident])) + [(or (get-in (first outer) [:locals :mappings ident]) + (get-in (first outer) [:closure :mappings ident])) '()] (reverse (cons top inner)))] - [::&util/ok [(assoc state ::local-envs (concat inner* outer)) (list =local)]]) + [::&util/ok [(assoc state ::&util/local-envs (concat inner* outer)) (list =local)]]) )) )) )) -(defn extract-ident [ident] - (match ident - [::&parser/ident ?ident] - (return ?ident) - - _ - (fail ""))) - -(defn full-class [class] - (case class - "boolean" (return Boolean/TYPE) - "byte" (return Byte/TYPE) - "short" (return Short/TYPE) - "int" (return Integer/TYPE) - "long" (return Long/TYPE) - "float" (return Float/TYPE) - "double" (return Double/TYPE) - "char" (return Character/TYPE) - ;; else - (if (.contains class ".") - (return (Class/forName class)) - (try-all-m [(exec [=class (resolve class)] - (match (:form =class) - [::class ?full-name] - (return (Class/forName ?full-name)) - _ - (fail "[Analyser Error] Unknown class."))) - (let [full-name* (str "java.lang." class)] - (if-let [full-name (try (Class/forName full-name*) - full-name* - (catch Exception e - nil))] - (return (Class/forName full-name)) - (fail "[Analyser Error] Unknown class.")))])))) - -(defn extract-jvm-param [token] - (match token - [::&parser/ident ?ident] - (full-class ?ident) - - [::&parser/form ([[::&parser/ident "Array"] [::&parser/ident ?inner]] :seq)] - (exec [=inner (full-class ?inner)] - (return (Class/forName (str "[L" (.getName =inner) ";")))) - - _ - (fail ""))) - -(defn extract-class [x] - (match x - [::class ?class] - (return ?class) - - _ - (fail ""))) - -(defn class-type [x] - (match x - [::&type/object ?class []] - (return ?class) +(defn ^:private analyse-call [analyse-ast ?fn ?args] + (exec [[=fn] (analyse-n (list ?fn)) + loader &util/loader] + (match =fn + [::Expression =fn-form =fn-type] + (match =fn-form + [::global ?module ?name] + (exec [macro? (is-macro? ?module ?name)] + (if macro? + (let [macro-class (str ?module "$" (normalize-ident ?name)) + output (-> (.loadClass loader macro-class) + .getDeclaredConstructors + first + (.newInstance (to-array [(int 0) nil])) + (.apply (¯os/->lux+ loader ?args)) + (.apply nil)) + ;; _ (prn 'output (str ?module ":" ?name) output (.-_1 output) (.-tag (.-_1 output))) + macro-expansion (¯os/->clojure+ (.-_1 output)) + state* (.-_2 output) + ;; _ (prn 'macro-expansion (str ?module ":" ?name) state* macro-expansion) + ] + (mapcat-m analyse-ast macro-expansion)) + (exec [=args (mapcat-m analyse-ast ?args) + :let [[needs-num =return-type] (match =fn-type + [::&type/function ?fargs ?freturn] + (let [needs-num (count ?fargs) + provides-num (count =args)] + (if (> needs-num provides-num) + [needs-num [::&type/function (drop provides-num ?fargs) ?freturn]] + [needs-num +dont-care-type+])))]] + (return (list [::Expression [::static-call needs-num =fn =args] =return-type]))))) - _ - (fail ""))) + _ + (exec [=args (mapcat-m analyse-ast ?args)] + (return (list [::Expression [::call =fn =args] +dont-care-type+])))) -(defn ^:private lookup-static-field [target field] - (if-let [type* (first (for [=field (.getFields target) - :when (and (= target (.getDeclaringClass =field)) - (= field (.getName =field)) - (java.lang.reflect.Modifier/isStatic (.getModifiers =field)))] - (.getType =field)))] - (exec [=type (&type/class->type type*)] - (return =type)) - (fail (str "[Analyser Error] Field does not exist: " target field)))) - -(defn ^:private lookup-virtual-method [target method-name args] - (if-let [method (first (for [=method (.getMethods target) - :when (and (= target (.getDeclaringClass =method)) - (= method-name (.getName =method)) - (not (java.lang.reflect.Modifier/isStatic (.getModifiers =method))))] - =method))] - (exec [=method (&type/method->type method)] - (&type/return-type =method)) - (fail (str "[Analyser Error] Virtual method does not exist: " target method-name)))) - -(defn ^:private full-class-name [class] - (if (.contains class ".") - (return class) - (try-all-m [(exec [=class (resolve class)] - (match (:form =class) - [::class ?full-name] - (return ?full-name) - _ - (fail "[Analyser Error] Unknown class."))) - (let [full-name* (str "java.lang." class)] - (if-let [full-name (try (Class/forName full-name*) - full-name* - (catch Exception e - nil))] - (return full-name) - (fail "[Analyser Error] Unknown class.")))]))) - -(defn ^:private ->lux+* [->lux loader xs] - (reduce (fn [tail x] - (doto (.newInstance (.loadClass loader "lux.Variant2")) - (-> .-tag (set! "Cons")) - (-> .-_1 (set! (->lux loader x))) - (-> .-_2 (set! tail)))) - (doto (.newInstance (.loadClass loader "lux.Variant0")) - (-> .-tag (set! "Nil"))) - (reverse xs))) - -(defn ^:private ->lux [loader x] - (match x - [::&parser/bool ?bool] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Bool")) - (-> .-_1 (set! ?bool))) - [::&parser/int ?int] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Int")) - (-> .-_1 (set! ?int))) - [::&parser/real ?real] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Real")) - (-> .-_1 (set! ?real))) - [::&parser/char ?elem] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Char")) - (-> .-_1 (set! ?elem))) - [::&parser/text ?text] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Text")) - (-> .-_1 (set! ?text))) - [::&parser/tag ?tag] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Tag")) - (-> .-_1 (set! ?tag))) - [::&parser/ident ?ident] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Ident")) - (-> .-_1 (set! ?ident))) - [::&parser/tuple ?elems] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Tuple")) - (-> .-_1 (set! (->lux+* ->lux loader ?elems)))) - [::&parser/form ?elems] - (doto (.newInstance (.loadClass loader "lux.Variant1")) - (-> .-tag (set! "Form")) - (-> .-_1 (set! (->lux+* ->lux loader ?elems)))) + :else + (fail "Can't call something without a type.")) )) -(def ^:private ->lux+ (partial ->lux+* ->lux)) +(defn ^:private analyse-do [analyse-ast ?exprs] + (exec [_ (assert! (count ?exprs) "\"do\" expressions can't have empty bodies.") + =exprs (mapcat-m analyse-ast ?exprs) + =exprs-types (map-m expr-type =exprs)] + (return (list [::Expression [::do =exprs] (last =exprs-types)])))) + +(do-template [ ] + (defn [tests ?token body-id] + (match (:struct tests) + [ ?patterns ?defaults] + {:struct [ (update-in ?patterns [?token] (fn [bodies] + (if bodies + (conj bodies body-id) + #{body-id}))) + ?defaults] + :branches (conj (:branches tests) body-id)} + + [::???Tests] + {:struct [ {?token #{body-id}} (list)] + :branches (conj (:branches tests) body-id)} + + :else + (assert false "Can't do match."))) + + ^:private bool-tests ::BoolTests + ^:private int-tests ::IntTests + ^:private real-tests ::RealTests + ^:private char-tests ::CharTests + ^:private text-tests ::TextTests + ) -(defn ->clojure+* [->clojure xs] - (prn '->clojure+* (.-tag xs)) - (case (.-tag xs) - "Nil" '() - "Cons" (cons (->clojure (.-_1 xs)) - (->clojure+* ->clojure (.-_2 xs))) - )) +(defn with-default [struct ?local $body] + (match (:struct tests) + [::BoolTests ?patterns ?defaults] + {:struct [::BoolTests ?patterns (conj ?defaults [::default ?local $body])] + :branches (conj (:branches tests) body-id)} -(defn ->clojure [x] - (pr '->clojure (.-tag x)) - (case (.-tag x) - "Bool" (do (println) [::&parser/bool (.-_1 x)]) - "Int" (do (println) [::&parser/int (.-_1 x)]) - "Real" (do (println) [::&parser/real (.-_1 x)]) - "Char" (do (println) [::&parser/char (.-_1 x)]) - "Text" (do (println) [::&parser/text (.-_1 x)]) - "Tag" (do (println " " (.-_1 x)) [::&parser/tag (.-_1 x)]) - "Ident" (do (println) [::&parser/ident (.-_1 x)]) - "Tuple" (do (println) [::&parser/tuple (->clojure+* ->clojure (.-_1 x))]) - "Form" (do (println) [::&parser/form (->clojure+* ->clojure (.-_1 x))]))) - -(def ^:private ->clojure+ (partial ->clojure+* ->clojure)) + [::IntTests ?patterns ?defaults] + {:struct [::IntTests ?patterns (conj ?defaults [::default ?local $body])] + :branches (conj (:branches tests) body-id)} -(defn ^:private analyse-tuple [analyse-ast ?elems] - (exec [=elems (do-all-m* (map analyse-ast ?elems)) - :let [_ (prn 'analyse-tuple =elems)]] - (return (list (annotated [::tuple =elems] [::&type/tuple (mapv :type =elems)]))))) + [::RealTests ?patterns ?defaults] + {:struct [::RealTests ?patterns (conj ?defaults [::default ?local $body])] + :branches (conj (:branches tests) body-id)} -(defn ^:private analyse-ident [analyse-ast ?ident] - (resolve ?ident)) + [::CharTests ?patterns ?defaults] + {:struct [::CharTests ?patterns (conj ?defaults [::default ?local $body])] + :branches (conj (:branches tests) body-id)} -(defn ^:private analyse-call [analyse-ast ?fn ?args] - (exec [[=fn] (analyse-ast ?fn) - loader &util/loader] - (match (:form =fn) - [::global-fn ?module ?name] - (exec [macro? (is-macro? ?module ?name)] - (if macro? - (let [macro-class (str ?module "$" (normalize-ident ?name)) - output (-> (.loadClass loader macro-class) - .getDeclaredConstructors - first - (.newInstance (to-array [(int 0) nil])) - (.apply (->lux+ loader ?args)) - (.apply nil)) - _ (prn 'output (str ?module ":" ?name) output (.-_1 output) (.-tag (.-_1 output))) - macro-expansion (->clojure+ (.-_1 output)) - state* (.-_2 output) - _ (prn 'macro-expansion (str ?module ":" ?name) state* macro-expansion) - ] - (do-all-m* (map analyse-ast macro-expansion))) - (exec [=args (do-all-m* (map analyse-ast ?args)) - :let [[needs-num =return-type] (match (:type =fn) - [::&type/function ?fargs ?freturn] - (let [needs-num (count ?fargs) - provides-num (count =args)] - (if (> needs-num provides-num) - [needs-num [::&type/function (drop provides-num ?fargs) ?freturn]] - [needs-num [::&type/object "java.lang.Object" []]])))]] - (return (list (annotated [::static-call needs-num =fn =args] =return-type)))))) - - _ - (exec [=args (do-all-m* (map analyse-ast ?args))] - (return (list (annotated [::call =fn =args] [::&type/object "java.lang.Object" []]))))) + [::TextTests ?patterns ?defaults] + {:struct [::TextTests ?patterns (conj ?defaults [::default ?local $body])] + :branches (conj (:branches tests) body-id)} )) -(defn ^:private analyse-if [analyse-ast ?test ?then ?else] - (exec [[=test] (analyse-ast ?test) - [=then] (analyse-ast ?then) - [=else] (analyse-ast ?else)] - (return (list (annotated [::if =test =then =else] +dont-care-type+))))) +(def ^:private product-match [ ?tag ?members body-id] + (condp = (:type struct) + (update-in struct [:patterns] + (fn [branches] + (if-let [{:keys [arity cases]} (get branches ?tag)] + (if (= arity (count ?members)) + (-> branches + (update-in [?tag :cases] conj {:case ?members + :body body-id}) + (update-in [?tag :branches] conj body-id)) + (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity))) + (assoc branches ?tag {:arity (count ?members) + :cases [{:case ?members + :body body-id}] + :branches #{body-id}})))) + nil (-> struct + (assoc :type ) + (assoc-in [:patterns ?tag] {:arity (count ?members) + :cases [{:case ?members + :body body-id}] + :branches #{body-id}})) + ;; else + (assert false "Can't do match.") + )) -(defn ^:private analyse-do [analyse-ast ?exprs] - (exec [=exprs (do-all-m* (map analyse-ast ?exprs))] - (return (list (annotated [::do =exprs] (-> =exprs last :type)))))) - -(let [fold-branch (fn [struct entry] - (let [struct* (clojure.core.match/match (nth entry 0) - [::pm-char ?token] - (clojure.core.match/match (:type struct) - ::char-tests (update-in struct [:patterns ?token] (fn [bodies] - (if bodies - (conj bodies (nth entry 1)) - #{(nth entry 1)}))) - nil (-> struct - (assoc :type ::char-tests) - (assoc-in [:patterns ?token] #{(nth entry 1)})) - _ (assert false "Can't do match.")) - - [::pm-text ?text] - (clojure.core.match/match (:type struct) - ::text-tests (update-in struct [:patterns ?text] (fn [bodies] - (if bodies - (conj bodies (nth entry 1)) - #{(nth entry 1)}))) - nil (-> struct - (assoc :type ::text-tests) - (assoc-in [:patterns ?text] #{(nth entry 1)})) - _ (assert false "Can't do match.")) - - [::pm-local ?local] - (update-in struct [:defaults] conj [::default ?local (nth entry 1)]) - - [::pm-tuple ?members] - (clojure.core.match/match (:type struct) - ::tuple (update-in struct [:patterns] - (fn [{:keys [arity cases] :as branch}] - (if (= arity (count ?members)) - (-> branch - (update-in [:cases] conj {:case ?members - :body (nth entry 1)}) - (update-in [:branches] conj (nth entry 1))) - (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity))))) - nil (-> struct - (assoc :type ::tuple) - (assoc :patterns {:arity (count ?members) - :cases [{:case ?members - :body (nth entry 1)}] - :branches #{(nth entry 1)}})) - _ (assert false "Can't do match.")) - - [::pm-variant ?tag ?members] - (clojure.core.match/match (:type struct) - ::adt (update-in struct [:patterns] - (fn [branches] - (if-let [{:keys [arity cases]} (get branches ?tag)] - (if (= arity (count ?members)) - (-> branches - (update-in [?tag :cases] conj {:case ?members - :body (nth entry 1)}) - (update-in [?tag :branches] conj (nth entry 1))) - (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity))) - (assoc branches ?tag {:arity (count ?members) - :cases [{:case ?members - :body (nth entry 1)}] - :branches #{(nth entry 1)}})))) - nil (-> struct - (assoc :type ::adt) - (assoc-in [:patterns ?tag] {:arity (count ?members) - :cases [{:case ?members - :body (nth entry 1)}] - :branches #{(nth entry 1)}})) - _ (assert false "Can't do match.")) - )] - (update-in struct* [:branches] conj (nth entry 1)))) - base-struct {:type nil - :patterns {} - :defaults [] - :branches #{}} +(def ^:private gen-product-branches [generate-branches branches] + (do (assert (<= (count (:defaults branches)) 1)) + {:type + :patterns (into {} (for [[?tag ?struct] (:patterns branches)] + [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)] + (map #(vector % body) case)))] + (map generate-branches grouped-parts)) + :branches (:branches ?struct)}])) + :default (-> branches :defaults first) + :branches (:branches branches)})) + +(let [fold-branch (fn [struct [pattern $body]] + (match pattern + [::BoolPM ?value] + (bool-tests struct $body) + + [::IntPM ?value] + (int-tests struct $body) + + [::RealPM ?value] + (real-tests struct $body) + + [::CharPM ?token] + (char-tests struct $body) + + [::TextPM ?text] + (text-tests struct $body) + + [::TuplePM ?members] + (product-match struct ::tuple-tests nil ?members $body) + + [::VariantPM ?tag ?members] + (product-match struct ::variant-tests ?tag ?members $body) + + [::LocalPM ?local] + (with-default struct ?local $body) + )) + base-struct [::???Tests] generate-branches (fn generate-branches [data] (let [branches* (reduce fold-branch base-struct data)] - (clojure.core.match/match (:type branches*) - ::char-tests branches* - ::text-tests branches* - ::tuple (do (assert (<= (count (:defaults branches*)) 1)) - {:type ::tuple* - :patterns (into {} (for [[?tag ?struct] {nil (:patterns branches*)}] - [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)] - (map #(vector % body) case)))] - (map generate-branches grouped-parts)) - :branches (:branches ?struct)}])) - :default (-> branches* :defaults first) - :branches (:branches branches*)}) - ::adt (do (assert (<= (count (:defaults branches*)) 1)) - {:type ::adt* - :patterns (into {} (for [[?tag ?struct] (:patterns branches*)] - [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)] - (map #(vector % body) case)))] - (map generate-branches grouped-parts)) - :branches (:branches ?struct)}])) - :default (-> branches* :defaults first) - :branches (:branches branches*)}) + (match branches* + [::BoolTests _] branches* + [::IntTests _] branches* + [::RealTests _] branches* + [::CharTests _] branches* + [::TextTests _] branches* + ::TupleTests (gen-product-branches generate-branches ::tuple-tests branches*) + ::VariantTests (gen-product-branches generate-branches ::variant-tests branches*) nil {:type ::defaults, :stores (reduce (fn [total [_ ?store ?body]] (update-in total [?store] (fn [mapping] @@ -535,258 +360,293 @@ (:defaults branches*)) :branches (:branches branches*)}))) get-vars (fn get-vars [pattern] - (clojure.core.match/match pattern - [::&parser/char ?token] - '() + (match pattern + [::&parser/Bool ?value] + (list) - [::&parser/text ?text] - '() + [::&parser/Int ?value] + (list) - [::&parser/tag _] - '() + [::&parser/Real ?value] + (list) + + [::&parser/Char ?token] + (list) - [::&parser/ident ?name] - (list ?name) + [::&parser/Text ?text] + (list) - [::&parser/tuple ?members] - (mapcat get-vars ?members) + [::&parser/Tag _] + (list) - [::&parser/variant ?tag ?members] + [::&parser/Ident ?name] + (list ?name) + + [::&parser/Tuple ?members] (mapcat get-vars ?members) - [::&parser/form ([[::&parser/tag _] & ?members] :seq)] + [::&parser/Form ([[::&parser/Tag _] & ?members] :seq)] (mapcat get-vars ?members) )) ->instructions (fn ->instructions [locals pattern] (clojure.core.match/match pattern - [::&parser/char ?token] - [::pm-char ?token] + [::&parser/Bool ?value] + [::BoolPM ?value] + + [::&parser/Int ?value] + [::IntPM ?value] - [::&parser/text ?text] - [::pm-text ?text] + [::&parser/Real ?value] + [::RealPM ?value] - [::&parser/tag ?tag] - [::pm-variant ?tag '()] + [::&parser/Char ?value] + [::CharPM ?value] - [::&parser/ident ?name] - [::pm-local (get locals ?name)] + [::&parser/Text ?value] + [::TextPM ?value] - [::&parser/tuple ?members] - [::pm-tuple (map (partial ->instructions locals) ?members)] + [::&parser/Tag ?tag] + [::VariantPM ?tag (list)] - [::&parser/variant ?tag ?members] - [::pm-variant ?tag (map (partial ->instructions locals) ?members)] + [::&parser/Ident ?name] + [::LocalPM (get locals ?name)] - [::&parser/form ([[::&parser/tag ?tag] & ?members] :seq)] - [::pm-variant ?tag (map (partial ->instructions locals) ?members)] + [::&parser/Tuple ?members] + [::TuplePM (map (partial ->instructions locals) ?members)] + + [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)] + [::VariantPM ?tag (map (partial ->instructions locals) ?members)] ))] - (defn ->decision-tree [$scope $base branches] - (let [;; Step 1: Get all vars - vars+body (for [branch branches] - (clojure.core.match/match branch - [::case-branch ?pattern ?body] - [(get-vars ?pattern) ?body])) - max-registers (reduce max 0 (map (comp count first) vars+body)) - ;; Step 2: Analyse bodies + (defn ^:private ->decision-tree [$base branches] + (let [vars (for [branch branches] + (clojure.core.match/match branch + [::case-branch ?pattern ?body] + (get-vars ?pattern))) [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch] (clojure.core.match/match branch [::case-branch ?pattern ?body] [(inc $link) (assoc links $link ?body) (conj branches* [::case-branch ?pattern $link])])) [0 {} []] branches) - ;; Step 4: Pattens -> Instructions - branches** (for [[branch branch-vars] (map vector branches* (map first vars+body)) + branches** (for [[branch branch-vars] (map vector branches* vars) :let [[_ locals] (reduce (fn [[$local =locals] $var] - [(inc $local) (assoc =locals $var [::local $scope $local])]) + [(inc $local) (assoc =locals $var [::local $local])]) [$base {}] branch-vars)]] (clojure.core.match/match branch [::case-branch ?pattern ?body] [(->instructions locals ?pattern) ?body])) - ;; Step 5: Re-structure branching - ] + max-registers (reduce max 0 (map count vars))] [max-registers branch-mappings (generate-branches branches**)]))) -(let [locals-getter (fn [$scope] - (fn member-fold [[$local locals] ?member] - (match ?member - [::&parser/ident ?name] - (return [(inc $local) (cons [?name (annotated [::local $scope $local] [::&type/object "java.lang.Object" []])] locals)]) - - [::&parser/tuple ?submembers] - (reduce-m member-fold [$local locals] ?submembers) - - [::&parser/form ([[::&parser/tag ?subtag] & ?submembers] :seq)] - (reduce-m member-fold [$local locals] ?submembers) - - _ - (return [$local locals]) - )))] +(defn ^:private analyse-case-branches [branches] + (map-m (fn [[?pattern ?body]] + (match ?pattern + [::&parser/Bool ?token] + (exec [[=body] (analyse-n (list ?body))] + (return [::case-branch ?pattern =body])) + + [::&parser/Int ?token] + (exec [[=body] (analyse-n (list ?body))] + (return [::case-branch ?pattern =body])) + + [::&parser/Real ?token] + (exec [[=body] (analyse-n (list ?body))] + (return [::case-branch ?pattern =body])) + + [::&parser/Char ?token] + (exec [[=body] (analyse-n (list ?body))] + (return [::case-branch ?pattern =body])) + + [::&parser/Text ?token] + (exec [[=body] (analyse-n (list ?body))] + (return [::case-branch ?pattern =body])) + + [::&parser/Ident ?name] + (exec [[=body] (with-let ?name :local +dont-care-type+ + (analyse-n (list ?body)))] + (return [::case-branch ?pattern =body])) + + [::&parser/Tag ?tag] + (exec [[=body] (analyse-n (list ?body))] + (return [::case-branch ?pattern =body])) + + [::&parser/Tuple ?members] + (exec [[=body] (with-lets (mapcat locals-getter ?members) + (analyse-n (list ?body)))] + (return [::case-branch ?pattern =body])) + + [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)] + (exec [[=body] (with-lets (mapcat locals-getter ?members) + (analyse-n (list ?body)))] + (return [::case-branch ?pattern =body])) + )) + branches)) + +(let [locals-getter (fn locals-getter [?member] + (match ?member + [::&parser/Ident ?name] + (list [?name +dont-care-type+]) + + [::&parser/Tuple ?submembers] + (mapcat locals-getter ?submembers) + + [::&parser/Form ([[::&parser/Tag ?subtag] & ?submembers] :seq)] + (mapcat locals-getter ?submembers) + + _ + (list) + ))] (defn ^:private analyse-case [analyse-ast ?variant ?branches] - (exec [[=variant] (analyse-ast ?variant) - $scope scope-id + (exec [[=variant] (analyse-n (list ?variant)) + _ (assert! (and (> (count ?branches) 0) (even? (count ?branches))) + "Imbalanced branches in \"case'\" expression.") $base next-local-idx - [registers mappings tree] (exec [=branches (map-m (fn [[?pattern ?body]] - (match ?pattern - [::&parser/char ?token] - (exec [[=body] (analyse-ast ?body)] - (return [::case-branch [::&parser/char ?token] =body])) - - [::&parser/text ?token] - (exec [[=body] (analyse-ast ?body)] - (return [::case-branch [::&parser/text ?token] =body])) - - [::&parser/ident ?name] - (exec [[=body] (with-local ?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []]) - (analyse-ast ?body))] - (return [::case-branch [::&parser/ident ?name] =body])) - - [::&parser/tag ?tag] - (exec [[=body] (analyse-ast ?body)] - (return [::case-branch [::&parser/variant ?tag '()] =body])) - - [::&parser/tuple ?members] - (exec [[_ locals+] (reduce-m (locals-getter $scope) [$base '()] ?members) - [=body] (with-locals (reverse locals+) - (analyse-ast ?body))] - (return [::case-branch [::&parser/tuple ?members] =body])) - - [::&parser/form ([[::&parser/tag ?tag] & ?members] :seq)] - (exec [[_ locals+] (reduce-m (locals-getter $scope) [$base '()] ?members) - [=body] (with-locals (reverse locals+) - (analyse-ast ?body))] - (return [::case-branch [::&parser/variant ?tag ?members] =body])) - )) - (partition 2 ?branches))] - (return (->decision-tree $scope $base =branches)))] - (return (list (annotated [::case (dec $base) =variant registers mappings tree] +dont-care-type+)))))) + [registers mappings tree] (exec [=branches (analyse-case-branches (partition 2 ?branches))] + (return (->decision-tree $base =branches)))] + (return (list [::Expression [::case $base =variant registers mappings tree] +dont-care-type+]))))) (defn ^:private analyse-let [analyse-ast ?label ?value ?body] - (exec [[=value] (analyse-ast ?value) + (exec [[=value] (analyse-n (list ?value)) + =value-type (expr-type =value) idx next-local-idx - [=body] (with-let ?label (:type =value) - (analyse-ast ?body)) - :let [_ (prn 'analyse-let =body)]] - (return (list (annotated [::let idx ?label =value =body] (:type =body)))))) - -(defn ^:private raise-tree-bindings [raise-expr outer-scope offset ?tree] - (let [partial-f (partial raise-expr outer-scope offset) - tree-partial-f (partial raise-tree-bindings raise-expr outer-scope offset)] + [=body] (with-let ?label :local =value-type + (analyse-n (list ?body))) + =body-type (expr-type =body)] + (return (list [::Expression [::let idx =value =body] =body-type])))) + +(defn ^:private raise-tree-bindings [raise-expr ?tree] + (let [tree-partial-f (partial raise-tree-bindings raise-expr)] (case (:type ?tree) - ::tuple* - (-> ?tree - (update-in [:patterns] - #(into {} (for [[?tag ?unapply] %] - [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))]))) - (update-in [:default] - (fn [[tag local $branch :as total]] - ;; (prn 'total total) - (if total - [tag (-> {:form local :type ::&type/nothing} partial-f :form) $branch])))) - - ::adt* + (::tuple ::variant) (-> ?tree (update-in [:patterns] #(into {} (for [[?tag ?unapply] %] [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))]))) (update-in [:default] (fn [[tag local $branch :as total]] - ;; (prn 'total total) (if total - [tag (-> {:form local :type ::&type/nothing} partial-f :form) $branch])))) + (match (raise-expr [::Expression local [::&type/Nothing]]) + [::Expression local* [::&type/Nothing]] + [tag local* $branch]))))) ::defaults (update-in ?tree [:stores] - #(into {} (for [[?store ?branches] % - :let [=store (partial-f {:form ?store :type ::&type/nothing})]] - [(:form =store) ?branches]))) + #(into {} (for [[?store ?branches] %] + (match (raise-expr [::Expression ?store [::&type/Nothing]]) + [::Expression =store [::&type/Nothing]] + [=store ?branches])))) ;; else (assert false (pr-str ?tree)) ))) -(defn ^:private raise-expr [outer-scope offset syntax] +(defn ^:private raise-expr [syntax] ;; (prn 'raise-bindings body) - (let [partial-f (partial raise-expr outer-scope offset) - tree-partial-f (partial raise-tree-bindings raise-expr outer-scope offset)] - (match (:form syntax) - [::literal ?value] - syntax - - [::tuple ?members] - {:form [::tuple (map partial-f ?members)] - :type (:type syntax)} + (let [tree-partial-f (partial raise-tree-bindings raise-expr)] + (match syntax + [::Expression ?form ?type] + (match ?form + [::bool ?value] + syntax - [::variant ?tag ?members] - {:form [::variant ?tag (map partial-f ?members)] - :type (:type syntax)} - - [::local ?scope ?idx] - {:form [::local outer-scope (inc ?idx)] - :type (:type syntax)} - - [::captured _ _ ?source] - ?source - - [::self ?self-name ?curried] - {:form [::self outer-scope (mapv partial-f ?curried)] - :type (:type syntax)} - - [::global _ _] - syntax - - [::jvm:iadd ?x ?y] - {:form [::jvm:iadd (partial-f ?x) (partial-f ?y)] - :type (:type syntax)} - - [::let ?idx ?name ?value ?body] - {:form [::let offset ?name (partial-f ?value) - (raise-expr outer-scope (inc offset) ?body)] - :type (:type syntax)} - - [::case ?base ?variant ?registers ?mappings ?tree] - (let [=variant (partial-f ?variant) - =mappings (into {} (for [[idx syntax] ?mappings] - [idx (raise-expr outer-scope (+ offset ?registers) syntax)])) - =tree (tree-partial-f ?tree)] - {:form [::case offset =variant ?registers =mappings =tree] - :type (:type syntax)}) - - [::lambda ?scope ?captured ?args ?value] - {:form [::lambda outer-scope - (into {} (for [[?name ?sub-syntax] ?captured] - [?name (partial-f ?sub-syntax)])) - ?args - ?value] - :type (:type syntax)} - - [::call ?func ?args] - {:form [::call (partial-f ?func) (map partial-f ?args)] - :type (:type syntax)} - - _ - (assert false (pr-str (:form syntax))) - ))) + [::int ?value] + syntax + + [::real ?value] + syntax + + [::char ?value] + syntax + + [::text ?value] + syntax + + [::tuple ?members] + [::Expression [::tuple (map raise-expr ?members)] ?type] + + [::variant ?tag ?members] + [::Expression [::variant ?tag (map raise-expr ?members)] ?type] + + [::local ?idx] + [::Expression [::local (inc ?idx)] ?type] + + [::captured _ _ ?source] + ?source + + [::self ?curried] + [::Expression [::self (map raise-expr ?curried)] ?type] + + [::global _ _] + syntax + + [::jvm-iadd ?x ?y] + [::Expression [::jvm-iadd (raise-expr ?x) (raise-expr ?y)] ?type] + + [::jvm-isub ?x ?y] + [::Expression [::jvm-isub (raise-expr ?x) (raise-expr ?y)] ?type] + + [::jvm-imul ?x ?y] + [::Expression [::jvm-imul (raise-expr ?x) (raise-expr ?y)] ?type] + + [::jvm-idiv ?x ?y] + [::Expression [::jvm-idiv (raise-expr ?x) (raise-expr ?y)] ?type] + + [::jvm-irem ?x ?y] + [::Expression [::jvm-irem (raise-expr ?x) (raise-expr ?y)] ?type] + + [::let ?idx ?value ?body] + [::Expression [::let (inc ?idx) (raise-expr ?value) + (raise-expr ?body)] + ?type] + + [::case ?base ?variant ?registers ?mappings ?tree] + (let [=variant (raise-expr ?variant) + =mappings (into {} (for [[idx syntax] ?mappings] + [idx (raise-expr syntax)])) + =tree (tree-partial-f ?tree)] + [::Expression [::case (inc ?base) =variant ?registers =mappings =tree] ?type]) + + [::lambda ?scope ?captured ?args ?value] + [::Expression [::lambda (pop ?scope) + (into {} (for [[?name ?sub-syntax] ?captured] + [?name (raise-expr ?sub-syntax)])) + ?args + ?value] + ?type] + + [::jvm-getstatic _ _] + syntax + + [::jvm-invokevirtual ?class ?method ?arg-classes ?obj ?args] + [::Expression [::jvm-invokevirtual ?class ?method ?arg-classes + (raise-expr ?obj) + (map raise-expr ?args)] + ?type] + + [::do ?asts] + [::Expression [::do (map raise-expr ?asts)] ?type] + + [::call ?func ?args] + [::Expression [::call (raise-expr ?func) (map raise-expr ?args)] ?type] + + _ + (assert false syntax) + )))) (defn ^:private analyse-lambda [analyse-ast ?self ?arg ?body] - (exec [[_ =arg =return :as =function] (within ::types &type/fresh-function) - [=scope =next-local =captured =body] (with-lambda ?self =function - ?arg =arg - (analyse-ast ?body)) - _ (&util/assert! (= 1 (count =body)) "Can't return more than 1 value.") - :let [[=body] =body] - ;; :let [_ (prn 'analyse-lambda/=body ?arg =captured =body)] - =function (within ::types (exec [_ (&type/solve =return (:type =body))] - (&type/clean =function))) - ;; :let [_ (prn 'LAMBDA/PRE (:form =body))] - :let [;; _ (prn '(:form =body) (:form =body)) - =lambda (match (:form =body) - [::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body] - [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope (-> ?sub-args count (+ 2)) ?sub-body)] + (exec [[_ =arg =return :as =function] (within ::&util/types &type/fresh-function) + [=scope =next-local =captured [=body]] (with-lambda ?self =function + ?arg =arg + (analyse-n (list ?body))) + =body-type (expr-type =body) + =function (within ::&util/types (exec [_ (&type/solve =return =body-type)] + (&type/clean =function))) + :let [=lambda (match =body + [::Expression [::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body] =body-type] + [::Expression [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr ?sub-body)] =body-type] _ - [::lambda =scope =captured (list ?arg) =body])] - ;; :let [_ (prn 'LAMBDA/POST =lambda)] - ] - (return (list (annotated =lambda =function))))) + [::Expression [::lambda =scope =captured (list ?arg) =body] =body-type])]] + (return (list [::Expression =lambda =function])))) (defn ^:private analyse-def [analyse-ast ?name ?value] ;; (prn 'analyse-def ?name ?value) @@ -794,28 +654,28 @@ (if def?? (fail (str "Can't redefine function/constant: " ?name)) (exec [ann?? (annotated? ?name) - $module module-name - [=value] (with-global ?name - (analyse-ast ?value)) - ;; :let [_ (prn 'DEF/PRE =value)] - :let [;; _ (prn 'analyse-def/=value =value) - new-scope [$module ?name] - =value (match (:form =value) - [::lambda ?old-scope ?env ?args ?body] - {:form [::lambda new-scope ?env ?args (raise-expr new-scope (-> ?args count inc) ?body)] - :type (:type =value)} - - _ - =value)] - ;; :let [_ (prn 'DEF/POST ?name =value)] + $module &util/get-module-name + [=value] (analyse-n (list ?value)) + =value (match =value + [::Expression =value-form =value-type] + (return (match =value-form + [::lambda ?old-scope ?env ?args ?body] + [::Expression [::lambda (list ?name $module) ?env ?args ?body] =value-type] + + _ + =value)) + + _ + (fail "")) + =value-type (expr-type =value) _ (if ann?? (return nil) - (annotate ?name ::constant ::public false (:type =value))) + (annotate ?name ::public false =value-type)) _ (define ?name)] - (return (list (annotated [::def ?name =value] ::&type/nothing))))))) + (return (list [::Statement [::def ?name =value]])))))) (defn ^:private analyse-annotate [?ident] - (exec [_ (annotate ?ident ::function ::public true ::&type/nothing)] + (exec [_ (annotate ?ident ::public true [::&type/Any])] (return (list)))) (defn ^:private analyse-require [analyse-ast ?path] @@ -824,48 +684,61 @@ (do-template [ ] (defn [analyse-ast ?x ?y] - (exec [[=x] (analyse-ast ?x) - [=y] (analyse-ast ?y)] - (return (list (annotated [ =x =y] [::&type/object +int-class+ []]))))) - - ^:private analyse-jvm-iadd "jvm:iadd" ::jvm:iadd - ^:private analyse-jvm-isub "jvm:isub" ::jvm:isub - ^:private analyse-jvm-imul "jvm:imul" ::jvm:imul - ^:private analyse-jvm-idiv "jvm:idiv" ::jvm:idiv - ^:private analyse-jvm-irem "jvm:irem" ::jvm:irem + (exec [[=x =y] (analyse-n (list ?x ?y))] + (return (list [::Expression [ =x =y] [::&type/Data "java.lang.Integer"]])))) + + ^:private analyse-jvm-iadd "jvm;iadd" ::jvm-iadd + ^:private analyse-jvm-isub "jvm;isub" ::jvm-isub + ^:private analyse-jvm-imul "jvm;imul" ::jvm-imul + ^:private analyse-jvm-idiv "jvm;idiv" ::jvm-idiv + ^:private analyse-jvm-irem "jvm;irem" ::jvm-irem ) (defn ^:private analyse-jvm-getstatic [analyse-ast ?class ?field] (exec [=class (full-class-name ?class) - =type (lookup-static-field (Class/forName =class) ?field)] - (return (list (annotated [::jvm:getstatic =class ?field] =type))))) + =type (lookup-static-field =class ?field)] + (return (list [::Expression [::jvm-getstatic =class ?field] =type])))) + +(defn ^:private analyse-jvm-getfield [analyse-ast ?class ?field ?object] + (exec [=class (full-class-name ?class) + =type (lookup-static-field =class ?field) + [=object] (analyse-n (list ?object))] + (return (list [::Expression [::jvm-getfield =class ?field =object] =type])))) + +(defn ^:private analyse-jvm-invokestatic [analyse-ast ?class ?method ?classes ?args] + (exec [=class (full-class-name ?class) + =classes (map-m extract-jvm-param ?classes) + =return (lookup-virtual-method =class ?method =classes) + =args (mapcat-m analyse-ast ?args)] + (return (list [::Expression [::jvm-invokestatic =class ?method =classes =args] =return])))) (defn ^:private analyse-jvm-invokevirtual [analyse-ast ?class ?method ?classes ?object ?args] (exec [=class (full-class-name ?class) =classes (map-m extract-jvm-param ?classes) - =return (lookup-virtual-method (Class/forName =class) ?method =classes) - [=object] (analyse-ast ?object) - =args (do-all-m* (map analyse-ast ?args))] - (return (list (annotated [::jvm:invokevirtual =class ?method (map #(.getName %) =classes) =object =args] =return))))) + =return (lookup-virtual-method =class ?method =classes) + [=object] (analyse-n (list ?object)) + =args (mapcat-m analyse-ast ?args)] + (return (list [::Expression [::jvm-invokevirtual =class ?method =classes =object =args] =return])))) (defn ^:private analyse-jvm-new [analyse-ast ?class ?classes ?args] (exec [=class (full-class-name ?class) =classes (map-m extract-jvm-param ?classes) - =args (do-all-m* (map analyse-ast ?args))] - (return (list (annotated [::jvm:new =class (map #(.getName %) =classes) =args] [::&type/object =class []]))))) + =args (mapcat-m analyse-ast ?args)] + (return (list [::Expression [::jvm-new =class =classes =args] [::&type/Data =class]])))) (defn ^:private analyse-jvm-new-array [analyse-ast ?class ?length] (exec [=class (full-class-name ?class)] - (return (list (annotated [::jvm:new-array =class ?length] [::&type/array [::&type/object =class []]]))))) + (return (list [::Expression [::jvm-new-array =class ?length] [::&type/Array [::&type/Data =class]]])))) (defn ^:private analyse-jvm-aastore [analyse-ast ?array ?idx ?elem] - (exec [[=array] (analyse-ast ?array) - [=elem] (analyse-ast ?elem)] - (return (list (annotated [::jvm:aastore =array ?idx =elem] (:type =array)))))) + (exec [[=array =elem] (analyse-n (list ?array ?elem)) + =array-type (expr-type =array)] + (return (list [::Expression [::jvm-aastore =array ?idx =elem] =array-type])))) (defn ^:private analyse-jvm-aaload [analyse-ast ?array ?idx] - (exec [[=array] (analyse-ast ?array)] - (return (list (annotated [::jvm:aaload =array ?idx] (-> =array :type (nth 1))))))) + (exec [[=array] (analyse-n (list ?array)) + =array-type (expr-type =array)] + (return (list [::Expression [::jvm-aaload =array ?idx] =array-type])))) (defn ^:private analyse-jvm-class [analyse-ast ?name ?super-class ?fields] (exec [?fields (map-m (fn [?field] @@ -876,11 +749,11 @@ _ (fail ""))) ?fields) - :let [=members {:fields (into {} (for [[class field] ?fields] - [field {:access ::public - :type class}]))}] - name module-name] - (return (list (annotated [::defclass [name ?name] ?super-class =members] ::&type/nothing))))) + :let [=fields (into {} (for [[class field] ?fields] + [field {:access :public + :type class}]))] + $module &util/get-module-name] + (return (list [::Statement [::jvm-class [$module ?name] ?super-class =fields {}]])))) (defn ^:private analyse-jvm-interface [analyse-ast ?name ?members] (exec [?members (map-m #(match % @@ -893,48 +766,43 @@ _ (fail "")) ?members) - :let [=members {:methods (into {} (for [[method [inputs output]] ?members] - [method {:access ::public - :type [inputs output]}]))} - =interface [::interface ?name =members]] - name module-name] - (return (list (annotated [::definterface [name ?name] =members] ::&type/nothing))))) + :let [=methods (into {} (for [[method [inputs output]] ?members] + [method {:access :public + :type [inputs output]}]))] + $module &util/get-module-name] + (return (list [::Statement [::jvm-interface [$module ?name] {} =methods]])))) (defn ^:private analyse-basic-ast [analyse-ast token] (match token ;; Standard special forms [::&parser/bool ?value] - (return (list (annotated [::literal ?value] [::&type/object "java.lang.Boolean" []]))) + (return (list [::Expression [::bool ?value] [::&type/Data "java.lang.Boolean"]])) [::&parser/int ?value] - (return (list (annotated [::literal ?value] [::&type/object +int-class+ []]))) + (return (list [::Expression [::int ?value] [::&type/Data "java.lang.Integer"]])) [::&parser/real ?value] - (return (list (annotated [::literal ?value] [::&type/object "java.lang.Float" []]))) + (return (list [::Expression [::real ?value] [::&type/Data "java.lang.Float"]])) [::&parser/char ?value] - (return (list (annotated [::literal ?value] [::&type/object "java.lang.Character" []]))) + (return (list [::Expression [::char ?value] [::&type/Data "java.lang.Character"]])) [::&parser/text ?value] - (return (list (annotated [::literal ?value] [::&type/object "java.lang.String" []]))) - - [::&parser/tag ?tag] - (do ;; (prn 'analyse-basic-ast/variant0 ?tag) - (return (list (annotated [::variant ?tag '()] [::&type/variant ?tag '()])))) + (return (list [::Expression [::text ?value] [::&type/Data "java.lang.String"]])) [::&parser/tuple ?elems] (analyse-tuple analyse-ast ?elems) + [::&parser/tag ?tag] + (return (list [::Expression [::variant ?tag (list)] [::&type/Variant {?tag [::&type/Tuple (list)]}]])) + [::&parser/ident ?ident] (analyse-ident analyse-ast ?ident) - [::&parser/form ([[::&parser/ident "if"] ?test ?then ?else] :seq)] - (analyse-if analyse-ast ?test ?then ?else) - [::&parser/form ([[::&parser/ident "let'"] [::&parser/ident ?label] ?value ?body] :seq)] (analyse-let analyse-ast ?label ?value ?body) - [::&parser/form ([[::&parser/ident "case"] ?variant & ?branches] :seq)] + [::&parser/form ([[::&parser/ident "case'"] ?variant & ?branches] :seq)] (analyse-case analyse-ast ?variant ?branches) [::&parser/form ([[::&parser/ident "lambda'"] [::&parser/ident ?self] [::&parser/ident ?arg] ?body] :seq)] @@ -951,45 +819,51 @@ ;; Host special forms [::&parser/form ([[::&parser/ident "do"] & ?exprs] :seq)] - (analyse-do ?exprs) + (analyse-do analyse-ast ?exprs) - [::&parser/form ([[::&parser/ident "jvm:iadd"] ?x ?y] :seq)] + [::&parser/form ([[::&parser/ident "jvm;iadd"] ?x ?y] :seq)] (analyse-jvm-iadd analyse-ast ?x ?y) - [::&parser/form ([[::&parser/ident "jvm:isub"] ?x ?y] :seq)] + [::&parser/form ([[::&parser/ident "jvm;isub"] ?x ?y] :seq)] (analyse-jvm-isub analyse-ast ?x ?y) - [::&parser/form ([[::&parser/ident "jvm:imul"] ?x ?y] :seq)] + [::&parser/form ([[::&parser/ident "jvm;imul"] ?x ?y] :seq)] (analyse-jvm-imul analyse-ast ?x ?y) - [::&parser/form ([[::&parser/ident "jvm:idiv"] ?x ?y] :seq)] + [::&parser/form ([[::&parser/ident "jvm;idiv"] ?x ?y] :seq)] (analyse-jvm-idiv analyse-ast ?x ?y) - [::&parser/form ([[::&parser/ident "jvm:irem"] ?x ?y] :seq)] + [::&parser/form ([[::&parser/ident "jvm;irem"] ?x ?y] :seq)] (analyse-jvm-irem analyse-ast ?x ?y) - [::&parser/form ([[::&parser/ident "jvm:getstatic"] [::&parser/ident ?class] [::&parser/ident ?field]] :seq)] + [::&parser/form ([[::&parser/ident "jvm;getstatic"] [::&parser/ident ?class] [::&parser/ident ?field]] :seq)] (analyse-jvm-getstatic analyse-ast ?class ?field) - [::&parser/form ([[::&parser/ident "jvm:invokevirtual"] [::&parser/ident ?class] [::&parser/text ?method] [::&parser/tuple ?classes] ?object [::&parser/tuple ?args]] :seq)] - (analyse-jvm-invokevirtual analyse-ast ?class ?method ?classes ?object ?args) + [::&parser/form ([[::&parser/ident "jvm;getfield"] [::&parser/ident ?class] [::&parser/ident ?field] ?object] :seq)] + (analyse-jvm-getfield analyse-ast ?class ?field ?object) - [::&parser/form ([[::&parser/ident "jvm:new"] [::&parser/ident ?class] [::&parser/tuple ?classes] [::&parser/tuple ?args]] :seq)] + [::&parser/form ([[::&parser/ident "jvm;invokestatic"] [::&parser/ident ?class] [::&parser/text ?method] [::&parser/tuple ?classes] [::&parser/tuple ?args]] :seq)] + (analyse-jvm-invokestatic analyse-ast ?class ?method ?classes ?args) + + [::&parser/form ([[::&parser/ident "jvm;invokevirtual"] [::&parser/ident ?class] [::&parser/text ?method] [::&parser/tuple ?classes] ?object [::&parser/tuple ?args]] :seq)] + (analyse-jvm-invokevirtual analyse-ast ?class ?method ?classes ?object ?args) + + [::&parser/form ([[::&parser/ident "jvm;new"] [::&parser/ident ?class] [::&parser/tuple ?classes] [::&parser/tuple ?args]] :seq)] (analyse-jvm-new analyse-ast ?class ?classes ?args) - [::&parser/form ([[::&parser/ident "jvm:new-array"] [::&parser/ident ?class] [::&parser/int ?length]] :seq)] + [::&parser/form ([[::&parser/ident "jvm;new-array"] [::&parser/ident ?class] [::&parser/int ?length]] :seq)] (analyse-jvm-new-array analyse-ast ?class ?length) - [::&parser/form ([[::&parser/ident "jvm:aastore"] ?array [::&parser/int ?idx] ?elem] :seq)] + [::&parser/form ([[::&parser/ident "jvm;aastore"] ?array [::&parser/int ?idx] ?elem] :seq)] (analyse-jvm-aastore analyse-ast ?array ?idx ?elem) - [::&parser/form ([[::&parser/ident "jvm:aaload"] ?array [::&parser/int ?idx]] :seq)] + [::&parser/form ([[::&parser/ident "jvm;aaload"] ?array [::&parser/int ?idx]] :seq)] (analyse-jvm-aaload analyse-ast ?array ?idx) - [::&parser/form ([[::&parser/ident "jvm:class"] [::&parser/ident ?name] [::&parser/ident ?super-class] [::&parser/tuple ?fields]] :seq)] + [::&parser/form ([[::&parser/ident "jvm;class"] [::&parser/ident ?name] [::&parser/ident ?super-class] [::&parser/tuple ?fields]] :seq)] (analyse-jvm-class analyse-ast ?name ?super-class ?fields) - [::&parser/form ([[::&parser/ident "jvm:interface"] [::&parser/ident ?name] & ?members] :seq)] + [::&parser/form ([[::&parser/ident "jvm;interface"] [::&parser/ident ?name] & ?members] :seq)] (analyse-jvm-interface analyse-ast ?name ?members) _ @@ -999,10 +873,10 @@ ;; (prn 'analyse-ast token) (match token [::&parser/form ([[::&parser/tag ?tag] & ?data] :seq)] - (exec [=data (do-all-m* (map analyse-ast ?data)) + (exec [=data (mapcat-m analyse-ast ?data) ;; :let [_ (prn 'analyse-ast/variant+ ?tag '=data =data)] - ] - (return (list (annotated [::variant ?tag =data] [::&type/variant ?tag (map :type =data)])))) + =data-types (map-m expr-type =data)] + (return (list [::Expression [::variant ?tag =data] [::&type/Variant {?tag [::&type/Tuple =data-types]}]]))) [::&parser/form ([?fn & ?args] :seq)] (try-all-m [(analyse-call analyse-ast ?fn ?args) @@ -1012,7 +886,5 @@ (analyse-basic-ast analyse-ast token))) (def analyse - (exec [asts &parser/parse - ;; :let [_ (prn 'asts asts)] - ] - (do-all-m* (map analyse-ast asts)))) + (exec [asts &parser/parse] + (mapcat-m analyse-ast asts))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 76f480a14..a62f66c35 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -6,7 +6,6 @@ [clojure.core.match :refer [match]] (lux [util :as &util :refer [exec return* return fail fail* repeat-m exhaust-m try-m try-all-m map-m reduce-m - do-all-m apply-m within normalize-ident]] [type :as &type] @@ -39,46 +38,38 @@ (return nil))) (def ^:private +variant-class+ (str +prefix+ ".Variant")) -(def ^:private +tuple-class+ (str +prefix+ ".Tuple")) +(def ^:private +tuple-class+ (str +prefix+ ".Tuple")) (defn ^:private unwrap-ident [ident] (match ident [::&parser/ident ?label] ?label)) -(def ^:private get-writer - (fn [state] - ;; (prn 'get-writer (::writer state)) - (return* state (::writer state)))) - (defn ^:private with-writer [writer body] (fn [state] ;; (prn 'with-writer/_0 body) - (let [result (body (assoc state ::writer writer))] + (let [result (body (assoc state ::&util/writer writer))] ;; (prn 'with-writer/_1 result) (match result [::&util/ok [?state ?value]] - [::&util/ok [(assoc ?state ::writer (::writer state)) ?value]] + [::&util/ok [(assoc ?state ::&util/writer (::&util/writer state)) ?value]] _ result)))) -(defn ^:private ->class [class] - (string/replace class #"\." "/")) - (def ^:private ->package ->class) (defn ^:private ->type-signature [class] (case class - "Void" "V" + "void" "V" "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" ;; else (let [class* (->class class)] (if (.startsWith class* "[") @@ -88,81 +79,54 @@ (defn ^:private ->java-sig [type] (match type - ::&type/nothing - "V" + ::&type/Any + (->type-signature "java.lang.Object") - ::&type/any - (->java-sig [::&type/object "java.lang.Object" []]) - - [::&type/primitive "boolean"] - "Z" - - [::&type/primitive "int"] - "I" - - [::&type/primitive "char"] - "C" - - [::&type/object ?name []] + [::&type/Data ?name] (->type-signature ?name) - [::&type/array [::&type/object ?name _]] - (str "[" (->type-signature ?name)) + [::&type/Array ?elem] + (str "[" (->java-sig ?elem)) [::&type/variant ?tag ?value] (->type-signature +variant-class+) - [::&type/function ?args ?return] - (->java-sig [::&type/object (str +prefix+ "/Function") []]))) - -(defn ^:private method->sig [method] - (match method - [::&type/function ?args ?return] - (str "(" (apply str (map ->java-sig ?args)) ")" - (if (= ::&type/nothing ?return) - "V" - (->java-sig ?return))))) + [::&type/Lambda _ _] + (->type-signature (str +prefix+ "/Function")))) ;; [Utils/Compilers] -(defn ^:private compile-literal [compile *type* ?literal] - (exec [*writer* get-writer - :let [_ (cond (instance? java.lang.Integer ?literal) - (doto *writer* - (.visitTypeInsn Opcodes/NEW (->class "java.lang.Integer")) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?literal) - (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Integer") "" "(I)V")) - - (instance? java.lang.Float ?literal) - (doto *writer* - (.visitTypeInsn Opcodes/NEW (->class "java.lang.Float")) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?literal) - (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Float") "" "(F)V")) - - (instance? java.lang.Character ?literal) - (doto *writer* - (.visitTypeInsn Opcodes/NEW (->class "java.lang.Character")) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?literal) - (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Character") "" "(C)V")) +(let [+class+ (->class "java.lang.Boolean") + +sig+ (->type-signature "java.lang.Boolean")] + (defn ^:private compile-bool [compile *type* ?value] + (exec [*writer* &util/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (->type-signature "java.lang.Boolean"))]] + (return nil)))) - (instance? java.lang.Boolean ?literal) - (if ?literal - (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") "TRUE" (->type-signature "java.lang.Boolean")) - (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") "FALSE" (->type-signature "java.lang.Boolean"))) +(do-template [ ] + (let [+class+ (->class )] + (defn [compile *type* ?value] + (exec [*writer* &util/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW ) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?literal) + (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] + (return nil)))) - (string? ?literal) - (.visitLdcInsn *writer* ?literal) + ^:private compile-int "java.lang.Integer" "(I)V" + ^:private compile-real "java.lang.Float" "(F)V" + ^:private compile-char "java.lang.Character" "(C)V" + ) - :else - (assert false (str "[Unknown literal type] " ?literal " : " (class ?literal))))]] +(defn ^:private compile-text [compile *type* ?value] + (exec [*writer* &util/get-writer + :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) (defn ^:private compile-tuple [compile *type* ?elems] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [num-elems (count ?elems) - tuple-class (str (str +prefix+ "/Tuple") num-elems) + tuple-class (str +prefix+ "/Tuple" num-elems) _ (doto *writer* (.visitTypeInsn Opcodes/NEW tuple-class) (.visitInsn Opcodes/DUP) @@ -175,13 +139,13 @@ (range num-elems))] (return nil))) -(defn ^:private compile-local [compile *type* ?env ?idx] - (exec [*writer* get-writer - :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] +(defn ^:private compile-local [compile *type* ?idx] + (exec [*writer* &util/get-writer + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int (inc ?idx)))]] (return nil))) (defn ^:private compile-captured [compile *type* ?scope ?captured-id ?source] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD @@ -191,20 +155,14 @@ (return nil))) (defn ^:private compile-global [compile *type* ?owner-class ?name] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;")]] (return nil))) -(defn ^:private compile-global-fn [compile *type* ?owner-class ?name] - (exec [*writer* get-writer - :let [_ (let [fn-class (str ?owner-class "$" (normalize-ident ?name))] - (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class fn-class) "_datum" (->type-signature fn-class)))]] - (return nil))) - (def +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;") (defn ^:private compile-call [compile *type* ?fn ?args] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer _ (compile ?fn) _ (map-m (fn [arg] (exec [ret (compile arg) @@ -215,9 +173,9 @@ (defn ^:private compile-static-call [compile *type* ?needs-num ?fn ?args] (assert false (pr-str 'compile-static-call)) - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [_ (match (:form ?fn) - [::&analyser/global-fn ?owner-class ?fn-name] + [::&analyser/global ?owner-class ?fn-name] (let [arg-sig (->type-signature "java.lang.Object") call-class (str (->class ?owner-class) "$" (normalize-ident ?fn-name)) provides-num (count ?args)] @@ -245,70 +203,68 @@ )]] (return nil))) -(defn ^:private compile-jvm-getstatic [compile *type* ?owner ?field] - (exec [*writer* get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?owner) ?field (->java-sig *type*))]] +(defn ^:private compile-jvm-getstatic [compile *type* ?class ?field] + (exec [*writer* &util/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?class) ?field (->java-sig *type*))]] (return nil))) -(defn prepare-arg! [*writer* class-name] - (condp = class-name - "boolean" (let [wrapper-class (->class "java.lang.Boolean")] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST wrapper-class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL wrapper-class "booleanValue" "()Z"))) - "byte" (let [wrapper-class (->class "java.lang.Byte")] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST wrapper-class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL wrapper-class "byteValue" "()B"))) - "short" (let [wrapper-class (->class "java.lang.Short")] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST wrapper-class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL wrapper-class "shortValue" "()S"))) - "int" (let [wrapper-class (->class "java.lang.Integer")] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST wrapper-class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL wrapper-class "intValue" "()I"))) - "long" (let [wrapper-class (->class "java.lang.Long")] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST wrapper-class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL wrapper-class "longValue" "()J"))) - "float" (let [wrapper-class (->class "java.lang.Float")] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST wrapper-class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL wrapper-class "floatValue" "()F"))) - "double" (let [wrapper-class (->class "java.lang.Double")] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST wrapper-class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL wrapper-class "doubleValue" "()D"))) - "char" (let [wrapper-class (->class "java.lang.Character")] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST wrapper-class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL wrapper-class "charValue" "()C"))) - ;; else - (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name)))) - -(let [boolean-class "java.lang.Boolean" - integer-class "java.lang.Integer" - char-class "java.lang.Character"] - (defn prepare-return! [*writer* *type*] - (match *type* - ::&type/nothing - (.visitInsn *writer* Opcodes/ACONST_NULL) - - [::&type/primitive "char"] - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class))) - - [::&type/primitive "int"] - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class))) +(defn ^:private compile-jvm-getfield [compile *type* ?class ?field ?object] + (exec [*writer* &util/get-writer + _ (compile ?object) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))] + :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (->class ?class) ?field (->java-sig *type*))]] + (return nil))) - [::&type/primitive "boolean"] - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class))) - - [::&type/object ?oclass _] - nil))) +(let [class+metthod+sig {"boolean" [(->class "java.lang.Boolean") "booleanValue" "()Z"] + "byte" [(->class "java.lang.Byte") "byteValue" "()B"] + "short" [(->class "java.lang.Short") "shortValue" "()S"] + "int" [(->class "java.lang.Integer") "intValue" "()I"] + "long" [(->class "java.lang.Long") "longValue" "()J"] + "float" [(->class "java.lang.Float") "floatValue" "()F"] + "double" [(->class "java.lang.Double") "doubleValue" "()D"] + "char" [(->class "java.lang.Character") "charValue" "()C"]}] + (defn ^:private prepare-arg! [*writer* class-name] + (if-let [[class method sig] (get class+metthod+sig class-name)] + (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name))))) + +;; (let [boolean-class "java.lang.Boolean" +;; integer-class "java.lang.Integer" +;; char-class "java.lang.Character"] +;; (defn prepare-return! [*writer* *type*] +;; (match *type* +;; ::&type/nothing +;; (.visitInsn *writer* Opcodes/ACONST_NULL) + +;; [::&type/primitive "char"] +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class))) + +;; [::&type/primitive "int"] +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class))) + +;; [::&type/primitive "boolean"] +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class))) + +;; [::&type/Data ?oclass] +;; nil))) + +(defn ^:private compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] + (exec [*writer* &util/get-writer + :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))] + _ (map-m (fn [[class-name arg]] + (exec [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (map vector ?classes ?args)) + :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class ?class) ?method method-sig) + ;; (prepare-return! *writer* *type*) + )]] + (return nil))) (defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))] _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))] @@ -318,11 +274,12 @@ (return ret))) (map vector ?classes ?args)) :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig) - (prepare-return! *writer* *type*))]] + ;; (prepare-return! *writer* *type*) + )]] (return nil))) (defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V") class* (->class ?class) _ (doto *writer* @@ -338,14 +295,14 @@ (return nil))) (defn ^:private compile-jvm-new-array [compile *type* ?class ?length] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [_ (doto *writer* (.visitLdcInsn (int ?length)) (.visitTypeInsn Opcodes/ANEWARRAY (->class ?class)))]] (return nil))) (defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer _ (compile ?array) :let [_ (doto *writer* (.visitInsn Opcodes/DUP) @@ -355,33 +312,15 @@ (return nil))) (defn ^:private compile-jvm-aaload [compile *type* ?array ?idx] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer _ (compile ?array) :let [_ (doto *writer* (.visitLdcInsn (int ?idx)) (.visitInsn Opcodes/AALOAD))]] (return nil))) -(let [+bool-class+ (->class "java.lang.Boolean")] - (defn ^:private compile-if [compile *type* ?test ?then ?else] - (exec [*writer* get-writer - :let [else-label (new Label) - end-label (new Label)] - _ (compile ?test) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +bool-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +bool-class+ "booleanValue" "()Z") - (.visitJumpInsn Opcodes/IFEQ else-label))] - _ (compile ?then) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO end-label) - (.visitLabel else-label))] - _ (compile ?else) - :let [_ (.visitLabel *writer* end-label)]] - (return nil)))) - (defn ^:private compile-do [compile *type* ?exprs] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer _ (map-m (fn [expr] (exec [ret (compile expr) :let [_ (.visitInsn *writer* Opcodes/POP)]] @@ -390,57 +329,56 @@ _ (compile (last ?exprs))] (return nil))) +(let [oclass (->class "java.lang.Object") + equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] + (defn ^:private compile-compare-primitive [writer mappings default-label ?pairs wrapper-class signature] + (let [wrapper-class (->class wrapper-class)] + (doseq [[?token $body] ?pairs + :let [$else (new Label)]] + (doto writer + ;; object + (.visitInsn Opcodes/DUP) ;; object, object + (-> (doto (.visitTypeInsn Opcodes/NEW wrapper-class) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?token) + (.visitMethodInsn Opcodes/INVOKESPECIAL wrapper-class "" signature)) + (->> (if (nil? wrapper-class) + (.visitLdcInsn writer ?token)))) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B + (.visitJumpInsn Opcodes/IFEQ $else) ;; object + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel $else))) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO default-label))))) + (let [+tag-sig+ (->type-signature "java.lang.String") variant-class* (->class +variant-class+) tuple-class* (->class +tuple-class+) - oclass (->class "java.lang.Object") +variant-field-sig+ (->type-signature "java.lang.Object") + oclass (->class "java.lang.Object") equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] - (defn compile-decision-tree [writer mappings default-label decision-tree] + (defn ^:private compile-decision-tree [writer mappings default-label decision-tree] (match decision-tree + [::test-bool ?pairs] + (compile-compare-primitive writer mappings default-label ?pairs "java.lang.Boolean" "(Z)V") + + [::test-int ?pairs] + (compile-compare-primitive writer mappings default-label ?pairs "java.lang.Integer" "(I)V") + + [::test-real ?pairs] + (compile-compare-primitive writer mappings default-label ?pairs "java.lang.Float" "(F)V") + [::test-char ?pairs] - (do (doseq [[?token $body] ?pairs - :let [$else (new Label)]] - (doto writer - ;; object - (.visitInsn Opcodes/DUP) ;; object, object - (.visitTypeInsn Opcodes/NEW (->class "java.lang.Character")) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?token) ;; object, object, text - (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Character") "" "(C)V") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B - (.visitJumpInsn Opcodes/IFEQ $else) ;; object - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel $else))) - (doto writer - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO default-label))) + (compile-compare-primitive writer mappings default-label ?pairs "java.lang.Character" "(C)V") [::test-text ?pairs] - (do (doseq [[?text $body] ?pairs - :let [$else (new Label)]] - (doto writer - ;; object - (.visitInsn Opcodes/DUP) ;; object, object - (.visitLdcInsn ?text) ;; object, object, text - (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B - (.visitJumpInsn Opcodes/IFEQ $else) ;; object - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel $else))) - (doto writer - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO default-label))) + (compile-compare-primitive writer mappings default-label ?pairs nil nil) - [::default [::&analyser/local _ ?idx] $body] - (doto writer - (.visitVarInsn Opcodes/ASTORE ?idx) - (.visitJumpInsn Opcodes/GOTO (get mappings $body))) - - [::store [::&analyser/local _ ?idx] $body] + [::store [::&analyser/local ?idx] $body] (doto writer - (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitVarInsn Opcodes/ASTORE (inc ?idx)) (.visitJumpInsn Opcodes/GOTO (get mappings $body))) [::test-tuple ?branches ?cases] @@ -469,7 +407,7 @@ (.visitInsn Opcodes/POP) ;; -> (.visitJumpInsn Opcodes/GOTO default-label))) - [::test-adt ?branches ?cases] + [::test-variant ?branches ?cases] (doto writer ;; object (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant @@ -512,9 +450,38 @@ (.visitJumpInsn Opcodes/GOTO default-label))) )) -(defn sequence-parts [branches parts] +(defn ^:private sequence-val [ struct branches] + (concat (list [[ (for [[?token ?supports] (:patterns struct) + ?body (set/intersection branches ?supports)] + [?token ?body])] + branches]) + (for [[_ ?local ?body] (:defaults struct) + :when (contains? branches ?body)] + [[::store ?local ?body] #{?body}]))) + +(defn ^:private sequence-product [ struct branches] + (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns struct) + :let [?parts (:parts ?struct) + num-parts (count ?parts) + ?supports (:branches ?struct) + subcases (for [?body (set/intersection branches ?supports) + subseq (sequence-parts #{?body} ?parts) + :when (= num-parts (count subseq))] + [::subcase ?body subseq])] + :when (not (empty? subcases))] + [?tag subcases]))] + (if (empty? patterns) + '() + (list [[ branches patterns] + branches]))) + (if-let [[_ ?local ?body] (:default struct)] + (for [?body (set/intersection branches #{?body})] + [[::store ?local ?body] #{?body}]) + '()))) + +(defn ^:private sequence-parts [branches parts] (if (empty? parts) - '(()) + (list (list)) (let [[head & tail] parts expanded (case (:type head) ::&analyser/defaults @@ -522,75 +489,36 @@ ?body (set/intersection branches ?supports)] [[::store ?local ?body] #{?body}]) + ::&analyser/bool-tests + (sequence-val ::test-bool head branches) + + ::&analyser/int-tests + (sequence-val ::test-int head branches) + + ::&analyser/real-tests + (sequence-val ::test-real head branches) + ::&analyser/char-tests - (concat (list [[::test-char (for [[?token ?supports] (:patterns head) - ?body (set/intersection branches ?supports)] - [?token ?body])] - branches]) - (for [[_ ?local ?body] (:defaults head) - :when (contains? branches ?body)] - [[::store ?local ?body] #{?body}])) + (sequence-val ::test-char head branches) ::&analyser/text-tests - (concat (list [[::test-text (for [[?token ?supports] (:patterns head) - ?body (set/intersection branches ?supports)] - [?token ?body])] - branches]) - (for [[_ ?local ?body] (:defaults head) - :when (contains? branches ?body)] - [[::store ?local ?body] #{?body}])) - - ::&analyser/tuple* - (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) - :let [?parts (:parts ?struct) - num-parts (count ?parts) - ?supports (:branches ?struct) - subcases (for [?body (set/intersection branches ?supports) - subseq (sequence-parts #{?body} ?parts) - :when (= num-parts (count subseq))] - [::subcase ?body subseq])] - :when (not (empty? subcases))] - [?tag subcases]))] - (if (empty? patterns) - '() - (list [[::test-tuple branches patterns] - branches]))) - (if-let [[_ ?local ?body] (:default head)] - (for [?body (set/intersection branches #{?body})] - [[::default ?local ?body] #{?body}]) - '())) - - ::&analyser/adt* - (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) - :let [?parts (:parts ?struct) - num-parts (count ?parts) - ?supports (:branches ?struct) - subcases (for [?body (set/intersection branches ?supports) - subseq (sequence-parts #{?body} ?parts) - :when (= num-parts (count subseq))] - [::subcase ?body subseq])] - :when (not (empty? subcases))] - [?tag subcases]))] - (if (empty? patterns) - '() - (list [[::test-adt branches patterns] - branches]))) - (if-let [[_ ?local ?body] (:default head)] - (for [?body (set/intersection branches #{?body})] - [[::default ?local ?body] #{?body}]) - '())) + (sequence-val ::test-text head branches) + + ::&analyser/tuple + (sequence-product ::test-tuple head branches) + + ::&analyser/variant + (sequence-product ::test-variant head branches) )] (for [[step branches*] expanded tail* (sequence-parts branches* tail)] (cons step tail*))))) -(def !case-vars (atom -1)) - (let [oclass (->class "java.lang.Object") equals-sig (str "(" (->type-signature "java.lang.Object") ")Z") ex-class (->class "java.lang.IllegalStateException")] (defn ^:private compile-case [compile *type* ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [start-label (new Label) end-label (new Label) entries (for [[?branch ?body] ?branch-mappings @@ -598,8 +526,9 @@ [[?branch label] [label ?body]]) mappings* (into {} (map first entries)) - _ (dotimes [idx ?max-registers] - (.visitLocalVariable *writer* (str "__" (swap! !case-vars inc) "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx))))] + _ (dotimes [offset ?max-registers] + (let [idx (+ ?base-idx offset)] + (.visitLocalVariable *writer* (str "v" idx) (->java-sig [::&type/Any]) nil start-label end-label idx)))] _ (compile ?variant) :let [_ (doto *writer* (.visitInsn Opcodes/DUP) @@ -613,11 +542,11 @@ pieces))] (compile-decision-tree *writer* mappings* default-label decision-tree)) (.visitLabel *writer* default-label) - (if-let [[_ [_ _ ?idx] ?body] (or (:default ?decision-tree) - (first (:defaults ?decision-tree)))] + (if-let [[_ [_ ?idx] ?body] (or (:default ?decision-tree) + (first (:defaults ?decision-tree)))] (doto *writer* (.visitInsn Opcodes/DUP) - (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitVarInsn Opcodes/ASTORE (inc ?idx)) (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) (doto *writer* (.visitInsn Opcodes/POP) @@ -635,22 +564,21 @@ :let [_ (.visitLabel *writer* end-label)]] (return nil)))) -(defn ^:private compile-let [compile *type* ?idx ?label ?value ?body] - (exec [*writer* get-writer +(defn ^:private compile-let [compile *type* ?idx ?value ?body] + (exec [*writer* &util/get-writer + _ (compile ?value) :let [start-label (new Label) end-label (new Label) - ?idx (int ?idx) - _ (.visitLocalVariable *writer* (normalize-ident ?label) (->java-sig (:type ?value)) nil start-label end-label ?idx)] - _ (compile ?value) - :let [_ (doto *writer* - (.visitVarInsn Opcodes/ASTORE ?idx) - (.visitLabel start-label))] + _ (doto *writer* + (.visitLocalVariable (str "v" ?idx) (->java-sig (:type ?value)) nil start-label end-label ?idx) + (.visitLabel start-label) + (.visitVarInsn Opcodes/ASTORE (inc ?idx)))] _ (compile ?body) :let [_ (.visitLabel *writer* end-label)]] (return nil))) -(defn compile-field [compile ?name body] - (exec [*writer* get-writer +(defn ^:private compile-field [compile ?name body] + (exec [*writer* &util/get-writer class-name &analyser/module-name :let [outer-class (->class class-name) datum-sig (->type-signature "java.lang.Object") @@ -662,7 +590,7 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) (doto (.visitEnd))))] _ (with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [_ (.visitCode *writer*)] _ (compile body) :let [_ (doto *writer* @@ -675,22 +603,15 @@ _ (save-class! current-class (.toByteArray =class))] (return nil))) -(defn ^:private captured? [form] - (match form - [::&analyser/captured ?closure-id ?captured-id ?source] - true - _ - false)) - (let [clo-field-sig (->type-signature "java.lang.Object") lambda-return-sig (->type-signature "java.lang.Object") -return "V" counter-sig "I" +datum-sig+ (->type-signature "java.lang.Object")] - (defn lambda-impl-signature [args] + (defn ^:private lambda-impl-signature [args] (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig)) - (defn lambda--signature [closed-over args] + (defn ^:private lambda--signature [closed-over args] (let [num-args (count args)] (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig)) (if (> num-args 1) @@ -698,7 +619,7 @@ ")" -return))) - (defn add-lambda- [class class-name closed-over args init-signature] + (defn ^:private add-lambda- [class class-name closed-over args init-signature] (let [num-args (count args) num-mappings (count closed-over)] (doto (.visitMethod class Opcodes/ACC_PUBLIC "" init-signature nil nil) @@ -711,8 +632,7 @@ (->> (let [captured-name (str "__" ?captured-id)]) (match (:form ?captured) [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] closed-over - :when (captured? (:form ?captured))]))) + (doseq [[?name ?captured] closed-over]))) (-> (doto (.visitVarInsn Opcodes/ALOAD 0) (.visitVarInsn Opcodes/ILOAD (inc num-mappings)) (.visitFieldInsn Opcodes/PUTFIELD class-name "_counter" counter-sig) @@ -729,23 +649,22 @@ (.visitMaxs 0 0) (.visitEnd)))) - (defn add-closed-over-vars [writer class-name closed-over] - (dotimes [capt_idx (count closed-over)] - (doto writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name (str "__" capt_idx) clo-field-sig)))) + (do-template [ ] + (defn [writer class-name vars] + (dotimes [idx (count vars)] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name (str idx) clo-field-sig)))) - (defn add-partial-vars [writer class-name args] - (dotimes [clo_idx (count args)] - (doto writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig)))) + ^:private add-closed-over-vars "__" + ^:private add-partial-vars "_" + ) - (defn add-nulls [writer amount] + (defn ^:private add-nulls [writer amount] (dotimes [_ amount] (.visitInsn writer Opcodes/ACONST_NULL))) - (defn add-lambda-apply [class class-name closed-over args impl-signature init-signature] + (defn ^:private add-lambda-apply [class class-name closed-over args impl-signature init-signature] (let [num-args (count args) num-captured (dec num-args) default-label (new Label) @@ -777,11 +696,11 @@ (.visitMaxs 0 0) (.visitEnd)))) - (defn add-lambda-impl [class compile impl-signature impl-body] + (defn ^:private add-lambda-impl [class compile impl-signature impl-body] (with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) (.visitCode)) (exec [;; :let [_ (prn 'add-lambda-impl/_0)] - *writer* get-writer + *writer* &util/get-writer ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)] ret (compile impl-body) ;; :let [_ (prn 'add-lambda-impl/_2 ret)] @@ -793,21 +712,20 @@ ] (return ret)))) - (defn instance-closure [compile lambda-class closed-over args init-signature] - (exec [*writer* get-writer + (defn ^:private instance-closure [compile lambda-class closed-over args init-signature] + (exec [*writer* &util/get-writer :let [;; _ (prn 'instance-closure/*writer* *writer*) num-args (count args) _ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] - _ (map-m (fn [[?name ?captured]] - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source] - (compile ?source))) - (->> closed-over - (filter (comp captured? :form second)) - (sort #(< (-> %1 second :form (nth 2)) - (-> %2 second :form (nth 2)))))) + _ (->> closed-over + (sort #(< (-> %1 second :form (nth 2)) + (-> %2 second :form (nth 2)))) + (map-m (fn [[?name ?captured]] + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source] + (compile ?source))))) :let [_ (do (when (> num-args 1) (.visitInsn *writer* Opcodes/ICONST_0) (dotimes [_ (dec num-args)] @@ -815,30 +733,6 @@ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature))]] (return nil))) - (defn ^:private compile-lambda [compile *type* ?scope ?closure ?args ?body] - (exec [:let [current-class (reduce str "" (interpose "$" (map normalize-ident ?scope))) - impl-signature (lambda-impl-signature ?args) - init-signature (lambda--signature ?closure ?args) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str "__" ?captured-id)]) - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] ?closure - :when (captured? (:form ?captured))]))) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) - (.visitEnd)) - (->> (when (> (count ?args) 1)))) - (add-lambda- current-class ?closure ?args init-signature) - (add-lambda-apply current-class ?closure ?args impl-signature init-signature))] - _ (add-lambda-impl =class compile impl-signature ?body) - :let [_ (.visitEnd =class)] - _ (save-class! current-class (.toByteArray =class))] - (instance-closure compile current-class ?closure ?args init-signature))) - (defn ^:private add-lambda- [class class-name args -sig] (let [num-args (count args)] (doto (.visitMethod class Opcodes/ACC_PUBLIC "" "()V" nil nil) @@ -854,51 +748,56 @@ (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd)))) - - (defn ^:private compile-method [compile ?name ?value] - (match (:form ?value) - [::&analyser/lambda ?scope ?env ?args ?body] - (exec [*writer* get-writer - outer-class &analyser/module-name - :let [class-name (str outer-class "$" (normalize-ident ?name)) - _ (.visitInnerClass *writer* class-name outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) - impl-signature (lambda-impl-signature ?args) - -sig (lambda--signature ?env ?args) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) - (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) - (.visitEnd)) - (->> (when (> (count ?args) 1)))) - (add-lambda-apply class-name ?env ?args impl-signature -sig) - (add-lambda- class-name ?env ?args -sig) - (add-lambda- class-name ?args -sig))] - _ (add-lambda-impl =class compile impl-signature ?body) - :let [_ (.visitEnd =class)] - _ (save-class! class-name (.toByteArray =class))] + + (defn ^:private compile-lambda [compile *type* ?scope ?closure ?args ?body with-datum? instance?] + (exec [:let [lambda-class (reduce str "" (interpose "$" (map normalize-ident ?scope))) + impl-signature (lambda-impl-signature ?args) + -sig (lambda--signature ?closure ?args) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + lambda-class nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str "__" ?captured-id)]) + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] ?closure]))) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) + (.visitEnd)) + (->> (when (> (count ?args) 1)))) + (-> (doto (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil) + (add-lambda- lambda-class ?args -sig)) + (when with-datum?)) + (add-lambda-apply lambda-class ?closure ?args impl-signature -sig) + (add-lambda- lambda-class ?closure ?args -sig) + )] + _ (add-lambda-impl =class compile impl-signature ?body) + :let [_ (.visitEnd =class)] + _ (save-class! lambda-class (.toByteArray =class))] + (if instance? + (instance-closure compile lambda-class ?closure ?args -sig) (return nil)))) ) (defn ^:private compile-def [compile *type* ?name ?value] - (exec [;; :let [_ (prn 'compile-def ?name ?value)] - _ (match (:form ?value) + (exec [_ (match (:form ?value) [::&analyser/lambda ?scope ?captured ?args ?body] - (compile-method compile ?name ?value) + (compile-lambda compile *type* ?scope ?closure ?args ?body true false) _ (compile-field compile ?name ?value))] (return nil))) -(defn ^:private compile-defclass [compile *type* ?package ?name ?super-class ?members] - (exec [*writer* get-writer +(defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods] + (exec [*writer* &util/get-writer loader &util/loader :let [parent-dir (->package ?package) + full-name (str parent-dir "/" ?name) super-class* (->class ?super-class) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str parent-dir "/" ?name) nil super-class* nil)) - _ (do (doseq [[field props] (:fields ?members)] + full-name nil super-class* nil)) + _ (do (doseq [[field props] ?fields] (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil) (.visitEnd))) (doto (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) @@ -910,28 +809,28 @@ (.visitEnd)) (.visitEnd =class) (.mkdirs (java.io.File. (str "output/" parent-dir))))] - _ (save-class! (str parent-dir "/" ?name) (.toByteArray =class))] + _ (save-class! full-name (.toByteArray =class))] (return nil))) -(defn ^:private compile-definterface [compile *type* ?package ?name ?members] - (exec [*writer* get-writer +(defn ^:private compile-jvm-interface [compile *type* ?package ?name ?fields ?methods] + (exec [*writer* &util/get-writer loader &util/loader :let [parent-dir (->package ?package) + full-name (str parent-dir "/" ?name) =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE ;; Opcodes/ACC_ABSTRACT - ) - (str parent-dir "/" ?name) nil "java/lang/Object" nil)) - _ (do (doseq [[?method ?props] (:methods ?members) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) + full-name nil "java/lang/Object" nil)) + _ (do (doseq [[?method ?props] ?methods :let [[?args ?return] (:type ?props) signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]] (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) (.visitEnd =interface) (.mkdirs (java.io.File. (str "output/" parent-dir))))] - _ (save-class! (str parent-dir "/" ?name) (.toByteArray =interface))] + _ (save-class! full-name (.toByteArray =interface))] (return nil))) (defn ^:private compile-variant [compile *type* ?tag ?members] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer :let [variant-class* (str (->class +variant-class+) (count ?members)) _ (doto *writer* (.visitTypeInsn Opcodes/NEW variant-class*) @@ -951,7 +850,7 @@ (let [+int-class+ (->class "java.lang.Integer")] (do-template [ ] (defn [compile *type* ?x ?y] - (exec [*writer* get-writer + (exec [*writer* &util/get-writer _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +int-class+) @@ -972,12 +871,9 @@ ^:private compile-jvm-irem Opcodes/IREM )) -(defn compile-self-call [compile ?scope ?assumed-args] - (exec [*writer* get-writer - :let [lambda-class (->class (reduce str "" (interpose "$" (map normalize-ident ?scope)))) - _ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC lambda-class "_datum" (->type-signature "java.lang.Object")) - (.visitTypeInsn Opcodes/CHECKCAST lambda-class))] +(defn compile-self-call [compile ?assumed-args] + (exec [*writer* &util/get-writer + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD 0)] _ (map-m (fn [arg] (exec [ret (compile arg) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" +apply-signature+)]] @@ -987,14 +883,26 @@ (defn ^:private compile [syntax] (match (:form syntax) - [::&analyser/literal ?literal] - (compile-literal compile (:type syntax) ?literal) + [::&analyser/bool ?value] + (compile-bool compile (:type syntax) ?value) + + [::&analyser/int ?value] + (compile-int compile (:type syntax) ?value) + + [::&analyser/real ?value] + (compile-real compile (:type syntax) ?value) + + [::&analyser/char ?value] + (compile-char compile (:type syntax) ?value) + + [::&analyser/text ?value] + (compile-text compile (:type syntax) ?value) [::&analyser/tuple ?elems] (compile-tuple compile (:type syntax) ?elems) - [::&analyser/local ?env ?idx] - (compile-local compile (:type syntax) ?env ?idx) + [::&analyser/local ?idx] + (compile-local compile (:type syntax) ?idx) [::&analyser/captured ?scope ?captured-id ?source] (compile-captured compile (:type syntax) ?scope ?captured-id ?source) @@ -1002,49 +910,40 @@ [::&analyser/global ?owner-class ?name] (compile-global compile (:type syntax) ?owner-class ?name) - [::&analyser/global-fn ?owner-class ?name] - (compile-global-fn compile (:type syntax) ?owner-class ?name) - [::&analyser/call ?fn ?args] (compile-call compile (:type syntax) ?fn ?args) [::&analyser/static-call ?needs-num ?fn ?args] (compile-static-call compile (:type syntax) ?needs-num ?fn ?args) - [::&analyser/jvm-getstatic ?owner ?field] - (compile-jvm-getstatic compile (:type syntax) ?owner ?field) - [::&analyser/variant ?tag ?members] (compile-variant compile (:type syntax) ?tag ?members) - [::&analyser/let ?idx ?label ?value ?body] - (compile-let compile (:type syntax) ?idx ?label ?value ?body) + [::&analyser/let ?idx ?value ?body] + (compile-let compile (:type syntax) ?idx ?value ?body) [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree] (compile-case compile (:type syntax) ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree) - [::&analyser/if ?test ?then ?else] - (compile-if compile (:type syntax) ?test ?then ?else) - [::&analyser/lambda ?scope ?frame ?args ?body] - (compile-lambda compile (:type syntax) ?scope ?frame ?args ?body) + (compile-lambda compile (:type syntax) ?scope ?frame ?args ?body false true) [::&analyser/def ?form ?body] (compile-def compile (:type syntax) ?form ?body) - [::&analyser/jvm:iadd ?x ?y] + [::&analyser/jvm-iadd ?x ?y] (compile-jvm-iadd compile (:type syntax) ?x ?y) - [::&analyser/jvm:isub ?x ?y] + [::&analyser/jvm-isub ?x ?y] (compile-jvm-isub compile (:type syntax) ?x ?y) - [::&analyser/jvm:imul ?x ?y] + [::&analyser/jvm-imul ?x ?y] (compile-jvm-imul compile (:type syntax) ?x ?y) - [::&analyser/jvm:idiv ?x ?y] + [::&analyser/jvm-idiv ?x ?y] (compile-jvm-idiv compile (:type syntax) ?x ?y) - [::&analyser/jvm:irem ?x ?y] + [::&analyser/jvm-irem ?x ?y] (compile-jvm-irem compile (:type syntax) ?x ?y) [::&analyser/do ?exprs] @@ -1053,6 +952,15 @@ [::&analyser/jvm-new ?class ?classes ?args] (compile-jvm-new compile (:type syntax) ?class ?classes ?args) + [::&analyser/jvm-getstatic ?class ?field] + (compile-jvm-getstatic compile (:type syntax) ?class ?field) + + [::&analyser/jvm-getfield ?class ?field ?object] + (compile-jvm-getfield compile (:type syntax) ?class ?field ?object) + + [::&analyser/jvm-invokestatic ?class ?method ?classes ?args] + (compile-jvm-invokestatic compile (:type syntax) ?class ?method ?classes ?args) + [::&analyser/jvm-invokevirtual ?class ?method ?classes ?object ?args] (compile-jvm-invokevirtual compile (:type syntax) ?class ?method ?classes ?object ?args) @@ -1065,53 +973,43 @@ [::&analyser/jvm-aaload ?array ?idx] (compile-jvm-aaload compile (:type syntax) ?array ?idx) - [::&analyser/definterface [?package ?name] ?members] - (compile-definterface compile (:type syntax) ?package ?name ?members) + [::&analyser/jvm-interface [?package ?name] ?members] + (compile-jvm-interface compile (:type syntax) ?package ?name ?members) - [::&analyser/defclass [?package ?name] ?super-class ?members] - (compile-defclass compile (:type syntax) ?package ?name ?super-class ?members) + [::&analyser/jvm-class [?package ?name] ?super-class ?members] + (compile-jvm-class compile (:type syntax) ?package ?name ?super-class ?members) - [::&analyser/self ?scope ?assumed-args] - (compile-self-call compile ?scope ?assumed-args) + [::&analyser/self ?assumed-args] + (compile-self-call compile ?assumed-args) )) ;; [Interface] -(let [compiler-step (exec [analysis+ &analyser/analyse - ;; :let [_ (prn 'analysis+ analysis+)] - ] +(let [compiler-step (exec [analysis+ &analyser/analyse] (map-m compile analysis+))] (defn compile-module [name] (exec [loader &util/loader] (fn [state] - (if (-> state :modules (contains? name)) + (if (-> state ::&util/modules (contains? name)) (fail "[Compiler Error] Can't redefine a module!") (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (->class name) nil "java/lang/Object" nil))] (match ((repeat-m compiler-step) (assoc state - ::&lexer/source (slurp (str "source/" name ".lux")) - ::&analyser/current-module name - ::writer =class)) + ::&util/source (slurp (str "source/" name ".lux")) + ::&util/current-module name + ::&util/writer =class)) [::&util/ok [?state ?forms]] - (if (empty? (::&lexer/source ?state)) + (if (empty? (::&util/source ?state)) (do (.visitEnd =class) ((save-class! name (.toByteArray =class)) ?state)) - (assert false (str "[Compiler Error] Can't compile: " (::&lexer/source ?state)))) + (assert false (str "[Compiler Error] Can't compile: " (::&util/source ?state)))) [::&util/failure ?message] (fail* ?message)))))))) (defn compile-all [modules] (.mkdir (java.io.File. "output")) - (let [state {::&lexer/source nil - ::&analyser/current-module nil - ::&analyser/scope [] - ::&analyser/modules {} - ::&analyser/global-env {} - ::&analyser/local-envs (list) - ::&analyser/types &type/+init+ - ::writer nil - ::&util/loader (&util/class-loader!)}] + (let [state (&util/init-state)] (match ((map-m compile-module modules) state) [::&util/ok [?state ?forms]] (println (str "Compilation complete! " (pr-str modules))) diff --git a/src/lux/host.clj b/src/lux/host.clj new file mode 100644 index 000000000..1dbe0e989 --- /dev/null +++ b/src/lux/host.clj @@ -0,0 +1,98 @@ +(ns lux.host + (:require (clojure [string :as string] + [template :refer [do-template]]) + [clojure.core.match :refer [match]] + (lux [util :as &util :refer [exec return* return fail fail* + repeat-m try-all-m map-m mapcat-m reduce-m + within + normalize-ident]] + [parser :as &parser] + [type :as &type]))) + +;; [Utils] +(defn ^:private class->type [class] + (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" + (str (if-let [pkg (.getPackage class)] + (str (.getName pkg) ".") + "") + (.getSimpleName class)))] + (if (= "void" base) + (return [::&type/Nothing]) + (let [base* [::&type/Data base]] + (if arr-level + (return (reduce (fn [inner _] + [::&type/Array inner]) + base* + (range (/ (count arr-level) 2.0)))) + (return base*))) + ))) + +(defn ^:private method->type [method] + (exec [=args (map-m class->type (seq (.getParameterTypes method))) + =return (class->type (.getReturnType method))] + (return [=args =return]))) + +;; [Resources] +(defn full-class [class-name] + (case class + "boolean" (return Boolean/TYPE) + "byte" (return Byte/TYPE) + "short" (return Short/TYPE) + "int" (return Integer/TYPE) + "long" (return Long/TYPE) + "float" (return Float/TYPE) + "double" (return Double/TYPE) + "char" (return Character/TYPE) + ;; else + (try (return (Class/forName class-name)) + (catch Exception e + (fail "[Analyser Error] Unknown class."))))) + +(defn full-class-name [class-name] + (exec [=class (full-class class-name)] + (.getName class-name))) + +(defn ->class [class] + (string/replace class #"\." "/")) + +(defn extract-jvm-param [token] + (match token + [::&parser/ident ?ident] + (full-class-name ?ident) + + [::&parser/form ([[::&parser/ident "Array"] [::&parser/ident ?inner]] :seq)] + (exec [=inner (full-class-name ?inner)] + (return (str "[L" (->class =inner) ";"))) + + _ + (fail ""))) + +(do-template [ ] + (defn [target field] + (if-let [type* (first (for [=field (.getFields target) + :when (and (= target (.getDeclaringClass =field)) + (= field (.getName =field)) + (= (java.lang.reflect.Modifier/isStatic (.getModifiers =field))))] + (.getType =field)))] + (exec [=type (&type/class->type type*)] + (return =type)) + (fail (str "[Analyser Error] Field does not exist: " target field)))) + + lookup-static-field true + lookup-field false + ) + +(do-template [ ] + (defn [target method-name args] + (if-let [method (first (for [=method (.getMethods target) + :when (and (= target (.getDeclaringClass =method)) + (= method-name (.getName =method)) + (= (java.lang.reflect.Modifier/isStatic (.getModifiers =method))))] + =method))] + (exec [=method (&type/method->type method)] + (return =method)) + (fail (str "[Analyser Error] Method does not exist: " target method-name)))) + + lookup-static-method true + lookup-virtual-method false + ) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 132f3402e..74291ec71 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -41,7 +41,7 @@ (return (str prefix unescaped postfix))) (lex-regex #"(?s)^([^\"\\]*)")])) -(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~\?]*)") +(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~\?]*)(;[0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~\?]+)?") ;; [Lexers] (def ^:private lex-white-space diff --git a/src/lux/macros.clj b/src/lux/macros.clj new file mode 100644 index 000000000..4d255a13c --- /dev/null +++ b/src/lux/macros.clj @@ -0,0 +1,69 @@ +(ns lux.macros + (:require [lux.parser :as &parser])) + +;; [Utils] +(defn ^:private ->lux+* [->lux loader xs] + (reduce (fn [tail x] + (doto (.newInstance (.loadClass loader "lux.Variant2")) + (-> .-tag (set! "Cons")) + (-> .-_1 (set! (->lux loader x))) + (-> .-_2 (set! tail)))) + (doto (.newInstance (.loadClass loader "lux.Variant0")) + (-> .-tag (set! "Nil"))) + (reverse xs))) + +(defn ^:private ->lux-one [loader tag value] + (doto (.newInstance (.loadClass loader "lux.Variant1")) + (-> .-tag (set! tag)) + (-> .-_1 (set! value)))) + +(defn ^:private ->lux-one [->lux loader tag values] + (doto (.newInstance (.loadClass loader "lux.Variant1")) + (-> .-tag (set! tag)) + (-> .-_1 (set! (->lux+* ->lux loader values))))) + +(defn ^:private ->lux [loader x] + (match x + [::&parser/Bool ?bool] + (->lux-one loader "Bool" ?bool) + [::&parser/Int ?int] + (->lux-one loader "Int" ?bool) + [::&parser/Real ?real] + (->lux-one loader "Real" ?bool) + [::&parser/Char ?elem] + (->lux-one loader "Char" ?bool) + [::&parser/Text ?text] + (->lux-one loader "Text" ?bool) + [::&parser/Tag ?tag] + (->lux-one loader "Tag" ?bool) + [::&parser/Ident ?ident] + (->lux-one loader "Ident" ?bool) + [::&parser/Tuple ?elems] + (->lux-many ->lux loader "Tuple" ?elems) + [::&parser/Form ?elems] + (->lux-many ->lux loader "Form" ?elems) + )) + +(defn ^:private ->clojure+* [->clojure xs] + (case (.-tag xs) + "Nil" (list) + "Cons" (cons (->clojure (.-_1 xs)) + (->clojure+* ->clojure (.-_2 xs))) + )) + +(defn ^:private ->clojure [x] + (case (.-tag x) + "Bool" [::&parser/Bool (.-_1 x)] + "Int" [::&parser/Int (.-_1 x)] + "Real" [::&parser/Real (.-_1 x)] + "Char" [::&parser/Char (.-_1 x)] + "Text" [::&parser/Text (.-_1 x)] + "Tag" [::&parser/Tag (.-_1 x)] + "Ident" [::&parser/Ident (.-_1 x)] + "Tuple" [::&parser/Tuple (->clojure+* ->clojure (.-_1 x))] + "Form" [::&parser/Form (->clojure+* ->clojure (.-_1 x))])) + +;; [Resources] +(def ->lux+ (partial ->lux+* ->lux)) + +(def ->clojure+ (partial ->clojure+* ->clojure)) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 92d6d43b9..3430e3675 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -35,31 +35,31 @@ (exec [token &lexer/lex] (match token [::&lexer/white-space _] - (return '()) + (return (list)) [::&lexer/comment _] - (return '()) + (return (list)) [::&lexer/bool ?value] - (return (list [::bool (Boolean/parseBoolean ?value)])) + (return (list [::Bool (Boolean/parseBoolean ?value)])) [::&lexer/int ?value] - (return (list [::int (Integer/parseInt ?value)])) + (return (list [::Int (Integer/parseInt ?value)])) [::&lexer/real ?value] - (return (list [::real (Float/parseFloat ?value)])) + (return (list [::Real (Float/parseFloat ?value)])) [::&lexer/char ?value] - (return (list [::char (.charAt ?value 0)])) + (return (list [::Char (.charAt ?value 0)])) [::&lexer/text ?value] - (return (list [::text ?value])) + (return (list [::Text ?value])) [::&lexer/ident ?value] - (return (list [::ident ?value])) + (return (list [::Ident ?value])) [::&lexer/tag ?value] - (return (list [::tag ?value])) + (return (list [::Tag ?value])) [::&lexer/open-paren] (parse-form parse) diff --git a/src/lux/type.clj b/src/lux/type.clj index ae0b882e5..a7bc8b522 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -1,8 +1,9 @@ (ns lux.type - (:refer-clojure :exclude [resolve]) + (:refer-clojure :exclude [resolve apply]) (:require [clojure.core.match :refer [match]] [lux.util :as &util :refer [exec return* return fail fail* repeat-m try-m try-all-m map-m + sequence-m apply-m assert!]])) ;; [Util] @@ -21,9 +22,6 @@ [::&util/failure (str "Unknown type-var: " id)]))) ;; [Interface] -(def +init+ {::counter 0 - ::mappings {}}) - (def fresh-var (fn [state] (let [id (::counter state)] @@ -37,66 +35,66 @@ =return fresh-var] (return [::function =arg =return]))) -(defn solve [expected actual] - ;; (prn 'solve expected actual) - (match [expected actual] - [::any _] - success +;; (defn solve [expected actual] +;; ;; (prn 'solve expected actual) +;; (match [expected actual] +;; [::any _] +;; success - [_ ::nothing] - success +;; [_ ::nothing] +;; success - [_ [::var ?id]] - (exec [[=top =bottom] (resolve ?id)] - (try-all-m [(exec [_ (solve expected =top)] - success) - (exec [_ (solve =top expected) - _ (solve expected =bottom) - _ (update ?id expected =bottom)] - success)])) - - [[::var ?id] _] - (exec [[=top =bottom] (resolve ?id)] - (try-all-m [(exec [_ (solve =bottom actual)] - success) - (exec [_ (solve actual =bottom) - _ (solve =top actual) - _ (update ?id =top actual)] - success)])) - - ;; [[::primitive ?prim] _] - ;; (let [as-obj (case ?prim - ;; "boolean" [:lang.type/object "java.lang.Boolean" []] - ;; "int" [:lang.type/object "java.lang.Integer" []] - ;; "long" [:lang.type/object "java.lang.Long" []] - ;; "char" [:lang.type/object "java.lang.Character" []] - ;; "float" [:lang.type/object "java.lang.Float" []] - ;; "double" [:lang.type/object "java.lang.Double" []])] - ;; (solve as-obj actual)) - - [[::primitive ?e-prim] [::primitive ?a-prim]] - (if (= ?e-prim ?a-prim) - success - (fail (str "Can't solve types: " (pr-str expected actual)))) - - [[::object ?eclass []] [::object ?aclass []]] - (if (.isAssignableFrom (Class/forName ?eclass) (Class/forName ?aclass)) - success - (fail (str "Can't solve types: " (pr-str expected actual)))) - - [_ _] - (fail (str "Can't solve types: " (pr-str expected actual))) - )) +;; [_ [::var ?id]] +;; (exec [[=top =bottom] (resolve ?id)] +;; (try-all-m [(exec [_ (solve expected =top)] +;; success) +;; (exec [_ (solve =top expected) +;; _ (solve expected =bottom) +;; _ (update ?id expected =bottom)] +;; success)])) + +;; [[::var ?id] _] +;; (exec [[=top =bottom] (resolve ?id)] +;; (try-all-m [(exec [_ (solve =bottom actual)] +;; success) +;; (exec [_ (solve actual =bottom) +;; _ (solve =top actual) +;; _ (update ?id =top actual)] +;; success)])) + +;; ;; [[::primitive ?prim] _] +;; ;; (let [as-obj (case ?prim +;; ;; "boolean" [:lang.type/object "java.lang.Boolean" []] +;; ;; "int" [:lang.type/object "java.lang.Integer" []] +;; ;; "long" [:lang.type/object "java.lang.Long" []] +;; ;; "char" [:lang.type/object "java.lang.Character" []] +;; ;; "float" [:lang.type/object "java.lang.Float" []] +;; ;; "double" [:lang.type/object "java.lang.Double" []])] +;; ;; (solve as-obj actual)) + +;; [[::primitive ?e-prim] [::primitive ?a-prim]] +;; (if (= ?e-prim ?a-prim) +;; success +;; (fail (str "Can't solve types: " (pr-str expected actual)))) + +;; [[::object ?eclass []] [::object ?aclass []]] +;; (if (.isAssignableFrom (Class/forName ?eclass) (Class/forName ?aclass)) +;; success +;; (fail (str "Can't solve types: " (pr-str expected actual)))) + +;; [_ _] +;; (fail (str "Can't solve types: " (pr-str expected actual))) +;; )) -(defn pick-matches [methods args] - (if (empty? methods) - (fail "No matches.") - (try-all-m [(match (-> methods first second) - [::function ?args ?return] - (exec [_ (assert! (= (count ?args) (count args)) "Args-size doesn't match.") - _ (map-m (fn [[e a]] (solve e a)) (map vector ?args args))] - (return (first methods)))) - (pick-matches (rest methods) args)]))) +;; (defn pick-matches [methods args] +;; (if (empty? methods) +;; (fail "No matches.") +;; (try-all-m [(match (-> methods first second) +;; [::function ?args ?return] +;; (exec [_ (assert! (= (count ?args) (count args)) "Args-size doesn't match.") +;; _ (map-m (fn [[e a]] (solve e a)) (map vector ?args args))] +;; (return (first methods)))) +;; (pick-matches (rest methods) args)]))) (defn clean [type] (match type @@ -116,37 +114,181 @@ (return type))) ;; Java Reflection -(defn class->type [class] - (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class)))] - (if (= "void" base) - (return ::nothing) - (let [base* (case base - ("boolean" "byte" "short" "int" "long" "float" "double" "char") - [::primitive base] - ;; else - [::object base []])] - (if arr-level - (return (reduce (fn [inner _] - [::array inner]) - base* - (range (/ (count arr-level) 2.0)))) - (return base*))) - - ))) - -(defn method->type [method] - (exec [=args (map-m class->type (seq (.getParameterTypes method))) - =return (class->type (.getReturnType method))] - (return [::function (vec =args) =return]))) - -(defn return-type [func] - (match func - [::function _ ?return] - (return ?return) +(def success (return nil)) - _ - (fail (str "Type is not a function: " (pr-str func))))) +(defn solve [needed given] + (match [needed given] + [[::Any] _] + success + + [_ [::Nothing]] + success + + [[::Data n!name] [::Data g!name]] + (cond (or (= n!name g!name) + (.isAssignableFrom (Class/forName n!name) (Class/forName g!name))) + success + + :else + (fail (str "Can't solve types: " (pr-str expected actual)))) + + [[::Tuple n!elems] [::Tuple g!elems]] + (exec [_ (assert! (= (count n!elems) (count g!elems)) + "Tuples must have matching element sizes.") + _ (map-m (fn [n g] (solve n g)) + (map vector n!elems g!elems))] + success) + + [[::Variant n!cases] [::Variant g!cases]] + (exec [_ (assert! (every? (partial contains? n!cases) (keys g!cases)) + "The given variant contains unhandled cases.") + _ (map-m (fn [label] + (solve (get n!cases label) (get g!cases label))) + (keys g!cases))] + success) + + [[::Record n!fields] [::Record g!fields]] + (exec [_ (assert! (every? (partial contains? g!fields) (keys n!fields)) + "The given record lacks necessary fields.") + _ (map-m (fn [label] + (solve (get n!fields label) (get g!fields label))) + (keys n!fields))] + success) + + [[::Lambda n!input n!output] [::Lambda g!input g!output]] + (exec [_ (solve g!input n!input)] + (solve n!output g!output)) + )) + +(comment + ;; Types + [::Any] + [::Nothing] + [::Tuple (list)] + [::Lambda input output] + [::Variant {}] + [::Record {}] + [::Data name] + [::All self {} arg body] + [::Exists evar body] + [::Bound name] + + ;; ??? + [::Alias name args type] + [::Var id] + + + ;; (deftype #rec Type + ;; (| #Any + ;; #Nothing + ;; (#Tuple (List Type)) + ;; (#Lambda Type Type) + ;; (#Variant (List [Text Type])) + ;; (#Record (List [Text Type])) + ;; (#Data Text))) + + + + ;; (deftype #rec Kind + ;; (| (#Type Type) + ;; (#All Text (List [Text Kind]) Text Kind))) + + ;; (deftype (Higher lower) + ;; (| (#Lower lower) + ;; (#Apply (Higher lower) (Higher lower)) + ;; (#All Text (List [Text lower]) Text (Higher lower)) + ;; (#Exists (List [Text lower]) Text (Higher lower)))) + + ;; (deftype Kind (Higher Type)) + ;; (deftype Sort (Higher Kind)) + + + + ;; (deftype HList (| (#Cons (Exists x x) HList) + ;; #Nil)) + + ;; (def success (return nil)) + + ;; (defn apply [type-lambda input] + ;; (match type-lambda + ;; [::All ?self ?env ?arg ?body] + ;; (let [env* (-> ?env + ;; (assoc ?arg input) + ;; (assoc ?self type-lambda))] + ;; (match ?body + ;; [::All ?sub-self _ ?sub-arg ?sub-body] + ;; [::All ?sub-self env* ?sub-arg ?sub-body] + + ;; _ + ;; (beta-reduce env* ?body))))) + + ;; (defn solve [needed given] + ;; (match [needed given] + ;; [[::Any] _] + ;; success + + ;; [_ [::Nothing]] + ;; success + + ;; [[::Tuple n!elems] [::Tuple g!elems]] + ;; (exec [_ (assert! (= (count n!elems) (count g!elems)) + ;; "Tuples must have matching element sizes.") + ;; _ (map-m (fn [[n g]] (solve n g)) + ;; (map vector n!elems g!elems))] + ;; success) + + ;; [[::Variant n!cases] [::Variant g!cases]] + ;; (exec [_ (assert! (every? (partial contains? n!cases) (keys g!cases)) + ;; "The given variant contains unhandled cases.") + ;; _ (map-m (fn [label] + ;; (solve (get n!cases label) (get g!cases label))) + ;; (keys g!cases))] + ;; success) + + ;; [[::Record n!fields] [::Record g!fields]] + ;; (exec [_ (assert! (every? (partial contains? g!fields) (keys n!fields)) + ;; "The given record lacks necessary fields.") + ;; _ (map-m (fn [label] + ;; (solve (get n!fields label) (get g!fields label))) + ;; (keys n!fields))] + ;; success) + + ;; [[::Lambda n!input n!output] [::Lambda g!input g!output]] + ;; (exec [_ (solve g!input n!input) + ;; _ (solve n!output g!output)] + ;; success) + ;; )) + + ;; (deftype (List x) + ;; (| (#Cons x (List x)) + ;; #Nil)) + + ;; (deftype List + ;; (All List [x] + ;; (| (#Cons x (List x)) + ;; #Nil))) + + ;; (def List + ;; [::All "List" {} x + ;; [::Variant {"Cons" [::Tuple (list [::Local x] [::Apply {} [::Local "List"] [::Local x]])] + ;; "Nil" [::Tuple (list)]}]]) + + ;; (deftype User + ;; {#name Text + ;; #email Text + ;; #password Text + ;; #joined Time + ;; #last-login Time}) + + ;; (deftype (Pair x y) + ;; [x y]) + + ;; (deftype (State s a) + ;; (-> s [a s])) + + ;; (: + (-> Int Int Int)) + ;; (def (+ x y) + ;; (jvm:ladd x y)) + + + ) diff --git a/src/lux/util.clj b/src/lux/util.clj index a3bbed358..9bd8ed42c 100644 --- a/src/lux/util.clj +++ b/src/lux/util.clj @@ -1,17 +1,19 @@ (ns lux.util - (:require (clojure [string :as string] - [template :refer [do-template]]) + (:require (clojure [template :refer [do-template]]) [clojure.core.match :refer [match]])) -;; [Interface] -;; [Interface/Utils] +;; [Resources] +;; [Resources/Contants] +(def +name-separator+ ";") + +;; [Resources/Utils] (defn fail* [message] [::failure message]) (defn return* [state value] [::ok [state value]]) -;; [Interface/Monads] +;; [Resources/Monads] (defn fail [message] (fn [_] [::failure message])) @@ -22,7 +24,6 @@ (defn bind [m-value step] #(let [inputs (m-value %)] - ;; (prn 'bind/inputs inputs) (match inputs [::ok [?state ?datum]] ((step ?datum) ?state) @@ -41,7 +42,7 @@ return (reverse (partition 2 steps)))) -;; [Interface/Combinators] +;; [Resources/Combinators] (defn try-m [monad] (fn [state] (match (monad state) @@ -97,12 +98,16 @@ output) ))))) -(defn map-m [f inputs] - (if (empty? inputs) - (return '()) - (exec [output (f (first inputs)) - outputs (map-m f (rest inputs))] - (return (conj outputs output))))) +(do-template [ ] + (defn [f inputs] + (if (empty? inputs) + (return '()) + (exec [output (f (first inputs)) + outputs (map-m f (rest inputs))] + (return ( output outputs))))) + + map-m cons + mapcat-m concat) (defn reduce-m [f init inputs] (if (empty? inputs) @@ -139,17 +144,11 @@ (fn [state] (return* state state))) -(do-template [ ] - (defn [monads] - (if (empty? monads) - (return '()) - (exec [head (first monads) - tail ( (rest monads))] - (return ( head tail))))) - - do-all-m cons - do-all-m* concat - ) +(defn sequence-m [m-values] + (if (empty? m-values) + (return nil) + (exec [head (first m-values)] + (sequence-m (rest monads))))) (defn within [slot monad] (fn [state] @@ -197,3 +196,28 @@ (def loader (fn [state] (return* state (::loader state)))) + +(def +init-env+ + {:counter 0 + :mappings {}}) + +(defn init-state [] + {::source nil + ::current-module nil + ::scope (list) + ::modules {} + ::global-env {} + ::local-envs (list) + ::types +init-env+ + ::writer nil + ::loader (class-loader!)}) + +(do-template [] + (def + (fn [state] + [::ok [state (::current-module state)]])) + + get-module-name ::current-module + get-scope ::scope + get-writer ::writer + ) -- cgit v1.2.3