aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2015-02-10 02:04:46 -0400
committerEduardo Julian2015-02-10 02:04:46 -0400
commit38fe9e91f451d9682ff7edf65fc395b85ddde961 (patch)
tree7d4c8b1f1c01d6edc5976b0c116e999a78b0c54a
parent93ff63219c7528074aae2d7f3e4f913b510a61bd (diff)
Super refactoring that breaks the system: Part 1
Diffstat
-rw-r--r--source/lux.lux1008
-rw-r--r--source/luxc/lexer.lux119
-rw-r--r--source/luxc/parser.lux72
-rw-r--r--source/luxc/util.lux (renamed from source/util.lux)0
-rw-r--r--src/lux.clj86
-rw-r--r--src/lux/analyser.clj1322
-rw-r--r--src/lux/compiler.clj784
-rw-r--r--src/lux/host.clj98
-rw-r--r--src/lux/lexer.clj2
-rw-r--r--src/lux/macros.clj69
-rw-r--r--src/lux/parser.clj18
-rw-r--r--src/lux/type.clj330
-rw-r--r--src/lux/util.clj72
13 files changed, 2423 insertions, 1557 deletions
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 <END>)))
+
+(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>
+ (| #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 <END>
+ (Session [] [] <END>))
+
+(def <<
+ (lambda [k session]
+ (k [] session)))
+
+(def (>> val)
+ (lambda [k session]
+ (session val k)))
+
+(<$> << (>> 5))
+
+(def (<$> consumer producer)
+ (producer [] consumer))
+
+(HList Int (HList Int <NIL>))
+
+(<.> (? Int) (? Int) (! Int) <END>)
+(def fn-session
+ (do [x <<
+ y <<]
+ (>> (+ x y))))
+
+(<.> (! Int) (! Int) (? Int) <END>)
+(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 [<name> <tag> <regex>]
+ (def <name>
+ (do [token (lex-regex <regex>)]
+ (return (<tag> 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 [<name> <delim> <tag>]
+ (def <name>
+ (do [_ (lex-prefix <delim>)]
+ (return <tag>)))
+
+ 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 [<name> <close-token> <description> <tag>]
+ (def (<name> parse)
+ (do [elems (repeat parse)
+ token &lexer:lex]
+ (case token
+ <close-token>
+ (return (list (<tag> (fold ++ (list) elems))))
+
+ _
+ (fail (concat (list "[Parser Error] Unbalanced " <description> "."))))))
+
+ 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/util.lux b/source/luxc/util.lux
index 88b035571..88b035571 100644
--- a/source/util.lux
+++ b/source/luxc/util.lux
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 <END>
+ (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]))
+
+ ((<$> (<< <END>) ((>> 5) <END>)))
+ )
+
;; 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 &macros]
+ [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 [<name> <unit-fn>]
- (defn <name> [locals monad]
- (reduce (fn [inner [label elem]]
- (<unit-fn> 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 (&macros/->lux+ loader ?args))
+ (.apply nil))
+ ;; _ (prn 'output (str ?module ":" ?name) output (.-_1 output) (.-tag (.-_1 output)))
+ macro-expansion (&macros/->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 [<name> <tag>]
+ (defn <name> [tests ?token body-id]
+ (match (:struct tests)
+ [<tag> ?patterns ?defaults]
+ {:struct [<tag> (update-in ?patterns [?token] (fn [bodies]
+ (if bodies
+ (conj bodies body-id)
+ #{body-id})))
+ ?defaults]
+ :branches (conj (:branches tests) body-id)}
+
+ [::???Tests]
+ {:struct [<tag> {?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 [<type> ?tag ?members body-id]
+ (condp = (:type struct)
+ <type> (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 <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 <type> branches]
+ (do (assert (<= (count (:defaults branches)) 1))
+ {:type <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 [<name> <ident> <output-tag>]
(defn <name> [analyse-ast ?x ?y]
- (exec [[=x] (analyse-ast ?x)
- [=y] (analyse-ast ?y)]
- (return (list (annotated [<output-tag> =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 [<output-tag> =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") "<init>" "(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") "<init>" "(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") "<init>" "(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 [<name> <class> <sig>]
+ (let [+class+ (->class <class>)]
+ (defn <name> [compile *type* ?value]
+ (exec [*writer* &util/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW <class>)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn ?literal)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]]
+ (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 "<init>" 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") "<init>" "(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 [<test-tag> struct branches]
+ (concat (list [[<test-tag> (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 [<test-tag> 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 [[<test-tag> 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 "<clinit>" "()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")
<init>-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-<init>-signature [closed-over args]
+ (defn ^:private lambda-<init>-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 @@
")"
<init>-return)))
- (defn add-lambda-<init> [class class-name closed-over args init-signature]
+ (defn ^:private add-lambda-<init> [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>" 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 [<name> <prefix>]
+ (defn <name> [writer class-name vars]
+ (dotimes [idx (count vars)]
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name (str <prefix> 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>" 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-<init>-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-<init> 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-<clinit> [class class-name args <init>-sig]
(let [num-args (count args)]
(doto (.visitMethod class Opcodes/ACC_PUBLIC "<clinit>" "()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)
- <init>-sig (lambda-<init>-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 <init>-sig)
- (add-lambda-<init> class-name ?env ?args <init>-sig)
- (add-lambda-<clinit> class-name ?args <init>-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)
+ <init>-sig (lambda-<init>-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-<clinit> lambda-class ?args <init>-sig))
+ (when with-datum?))
+ (add-lambda-apply lambda-class ?closure ?args impl-signature <init>-sig)
+ (add-lambda-<init> lambda-class ?closure ?args <init>-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 <init>-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 "<init>" "()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 [<name> <opcode>]
(defn <name> [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 [<name> <static?>]
+ (defn <name> [target field]
+ (if-let [type* (first (for [=field (.getFields target)
+ :when (and (= target (.getDeclaringClass =field))
+ (= field (.getName =field))
+ (= <static?> (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 [<name> <static?>]
+ (defn <name> [target method-name args]
+ (if-let [method (first (for [=method (.getMethods target)
+ :when (and (= target (.getDeclaringClass =method))
+ (= method-name (.getName =method))
+ (= <static?> (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 [<name> <joiner>]
+ (defn <name> [f inputs]
+ (if (empty? inputs)
+ (return '())
+ (exec [output (f (first inputs))
+ outputs (map-m f (rest inputs))]
+ (return (<joiner> 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 [<name> <joiner>]
- (defn <name> [monads]
- (if (empty? monads)
- (return '())
- (exec [head (first monads)
- tail (<name> (rest monads))]
- (return (<joiner> 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 [<name>]
+ (def <name>
+ (fn [state]
+ [::ok [state (::current-module state)]]))
+
+ get-module-name ::current-module
+ get-scope ::scope
+ get-writer ::writer
+ )
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 17:47:27 +0000