diff options
Diffstat (limited to '')
| -rw-r--r-- | source/lux.lux | 1634 | ||||
| -rw-r--r-- | src/lux.clj | 9 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 204 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 2 | ||||
| -rw-r--r-- | src/lux/analyser/def.clj | 15 | ||||
| -rw-r--r-- | src/lux/analyser/env.clj | 22 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 75 | ||||
| -rw-r--r-- | src/lux/analyser/lambda.clj | 10 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 111 | ||||
| -rw-r--r-- | src/lux/base.clj | 225 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 533 | ||||
| -rw-r--r-- | src/lux/compiler/base.clj | 177 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 101 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 5 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 37 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 61 | ||||
| -rw-r--r-- | src/lux/host.clj | 4 | ||||
| -rw-r--r-- | src/lux/lexer.clj | 2 | ||||
| -rw-r--r-- | src/lux/parser.clj | 17 | ||||
| -rw-r--r-- | src/lux/type.clj | 128 |
20 files changed, 1781 insertions, 1591 deletions
diff --git a/source/lux.lux b/source/lux.lux index 69b9515e3..9e5885e97 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -9,7 +9,7 @@ (case' tokens (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) (#Right [state - (#Cons [(#Form (#Cons [(#Ident "case'") (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + (#Cons [(#Form (#Cons [(#Symbol "case'") (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) #Nil])])) ))) (declare-macro let') @@ -19,29 +19,29 @@ (lambda' _ state (let' output (case' tokens (#Cons [(#Tuple (#Cons [arg args'])) (#Cons [body #Nil])]) - (#Form (#Cons [(#Ident "lambda'") - (#Cons [(#Ident "") + (#Form (#Cons [(#Symbol "lambda'") + (#Cons [(#Symbol "") (#Cons [arg (#Cons [(case' args' #Nil body _ - (#Form (#Cons [(#Ident "lux;lambda") + (#Form (#Cons [(#Symbol "lux;lambda") (#Cons [(#Tuple args') (#Cons [body #Nil])])]))) #Nil])])])])) - (#Cons [(#Ident self) (#Cons [(#Tuple (#Cons [arg args'])) (#Cons [body #Nil])])]) - (#Form (#Cons [(#Ident "lambda'") - (#Cons [(#Ident self) + (#Cons [(#Symbol self) (#Cons [(#Tuple (#Cons [arg args'])) (#Cons [body #Nil])])]) + (#Form (#Cons [(#Symbol "lambda'") + (#Cons [(#Symbol self) (#Cons [arg (#Cons [(case' args' #Nil body _ - (#Form (#Cons [(#Ident "lux;lambda") + (#Form (#Cons [(#Symbol "lux;lambda") (#Cons [(#Tuple args') (#Cons [body #Nil])])]))) #Nil])])])]))) @@ -52,15 +52,15 @@ (def' def (lambda [tokens state] (let' output (case' tokens - (#Cons [(#Ident name) (#Cons [body #Nil])]) - (#Form (#Cons [(#Ident "def'") tokens])) + (#Cons [(#Symbol name) (#Cons [body #Nil])]) + (#Form (#Cons [(#Symbol "def'") tokens])) - (#Cons [(#Form (#Cons [(#Ident name) args])) + (#Cons [(#Form (#Cons [(#Symbol name) args])) (#Cons [body #Nil])]) - (#Form (#Cons [(#Ident "def'") - (#Cons [(#Ident name) - (#Cons [(#Form (#Cons [(#Ident "lux;lambda") - (#Cons [(#Ident name) + (#Form (#Cons [(#Symbol "def'") + (#Cons [(#Symbol name) + (#Cons [(#Form (#Cons [(#Symbol "lux;lambda") + (#Cons [(#Symbol name) (#Cons [(#Tuple args) (#Cons [body #Nil])])])])) #Nil])])]))) @@ -69,842 +69,842 @@ (def (defmacro tokens state) (let' [fn-name fn-def] (case' tokens - (#Cons [(#Form (#Cons [(#Ident name) args])) + (#Cons [(#Form (#Cons [(#Symbol name) args])) (#Cons [body #Nil])]) [name - (#Form (#Cons [(#Ident "lux;def") - (#Cons [(#Form (#Cons [(#Ident name) args])) + (#Form (#Cons [(#Symbol "lux;def") + (#Cons [(#Form (#Cons [(#Symbol name) args])) (#Cons [body #Nil])])]))]) - (let' declaration (#Form (#Cons [(#Ident "declare-macro") (#Cons [(#Ident fn-name) #Nil])])) + (let' declaration (#Form (#Cons [(#Symbol "declare-macro") (#Cons [(#Symbol fn-name) #Nil])])) (#Right [state (#Cons [fn-def (#Cons [declaration #Nil])])])))) (declare-macro defmacro) -(defmacro (comment tokens state) - (#Right [state #Nil])) +## (defmacro (comment tokens state) +## (#Right [state #Nil])) -(def (int+ x y) - (jvm-ladd x y)) +## (def (int+ x y) +## (jvm-ladd x y)) -(def (id x) - x) +## (def (id x) +## x) -(def (print x) - (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] - (jvm-getstatic java.lang.System "out") [x])) +## (def (print x) +## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] +## (jvm-getstatic java.lang.System "out") [x])) -(def (println x) - (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] - (jvm-getstatic java.lang.System "out") [x])) +## (def (println x) +## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] +## (jvm-getstatic java.lang.System "out") [x])) -(def (fold f init xs) - (case' xs - #Nil - init +## (def (fold f init xs) +## (case' xs +## #Nil +## init - (#Cons [x xs']) - (fold f (f init x) xs'))) - -(def (reverse list) - (fold (lambda [tail head] - (#Cons [head tail])) - #Nil - list)) - -(defmacro (list xs state) - (let' xs' (reverse xs) - (let' output (fold (lambda [tail head] - (#Form (#Cons [(#Tag "Cons") - (#Cons [(#Tuple (#Cons [head (#Cons [tail #Nil])])) - #Nil])]))) - (#Tag "Nil") - xs') - (#Right [state (#Cons [output #Nil])])))) - -(defmacro (list+ xs state) - (case' (reverse xs) - #Nil - [#Nil state] - - (#Cons [last init']) - (let' output (fold (lambda [tail head] - (#Form (list (#Tag "Cons") (#Tuple (list head tail))))) - last - init') - (#Right [state (#Cons [output #Nil])])))) - -(def (as-pairs xs) - (case' xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) - - _ - #Nil)) - -(defmacro (let tokens state) - (case' tokens - (#Cons [(#Tuple bindings) (#Cons [body #Nil])]) - (let' output (fold (lambda [body binding] - (case' binding - [label value] - (#Form (list (#Ident "lux;let'") label value body)))) - body - (reverse (as-pairs bindings))) - (#Right [state (list output)])))) - -(def (. f g) - (lambda [x] (f (g x)))) - -(def (++ xs ys) - (case' xs - #Nil - ys - - (#Cons [x xs*]) - (#Cons [x (++ xs* ys)]))) - -(def concat - (fold ++ #Nil)) - -(def (map f xs) - (case' xs - #Nil - #Nil - - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) - -(def flat-map (. concat map)) - -(def (untemplate-list tokens) - (case' tokens - #Nil - (#Tag "Nil") - - (#Cons [token tokens']) - (#Form (#Cons [(#Tag "Cons") - (#Cons [(#Tuple (#Cons [token (#Cons [(untemplate-list tokens') #Nil])])) - #Nil])])))) - -(def (untemplate token) - (case' token - (#Bool value) - (#Form (list (#Tag "Bool") (#Bool value))) - - (#Int value) - (#Form (list (#Tag "Int") (#Int value))) - - (#Real value) - (#Form (list (#Tag "Real") (#Real value))) - - (#Char value) - (#Form (list (#Tag "Char") (#Char value))) - - (#Text value) - (#Form (list (#Tag "Text") (#Text value))) - - (#Tag value) - (#Form (list (#Tag "Tag") (#Text value))) - - (#Ident value) - (#Form (list (#Tag "Ident") (#Text value))) - - (#Tuple elems) - (#Form (list (#Tag "Tuple") (untemplate-list (map untemplate elems)))) - - (#Form (#Cons [(#Ident "~") (#Cons [unquoted #Nil])])) - unquoted - - (#Form elems) - (#Form (list (#Tag "Form") (untemplate-list (map untemplate elems)))) - )) - -(defmacro (` tokens state) - (case' tokens - (#Cons [template #Nil]) - (#Right [state (list (untemplate template))]))) - -(defmacro (if tokens state) - (case' tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (#Right [state - (list (` (case' (~ test) - true (~ then) - false (~ else))))]))) - -(def (filter p xs) - (case' xs - #Nil - #Nil - - (#Cons [x xs*]) - (if (p x) - (filter p xs*) - (#Cons [x (filter p xs*)])))) - -(def (return val) - (lambda [state] - (#Right [state val]))) - -(def (fail msg) - (lambda [_] - (#Left msg))) +## (#Cons [x xs']) +## (fold f (f init x) xs'))) + +## (def (reverse list) +## (fold (lambda [tail head] +## (#Cons [head tail])) +## #Nil +## list)) + +## (defmacro (list xs state) +## (let' xs' (reverse xs) +## (let' output (fold (lambda [tail head] +## (#Form (#Cons [(#Tag "Cons") +## (#Cons [(#Tuple (#Cons [head (#Cons [tail #Nil])])) +## #Nil])]))) +## (#Tag "Nil") +## xs') +## (#Right [state (#Cons [output #Nil])])))) + +## (defmacro (list+ xs state) +## (case' (reverse xs) +## #Nil +## [#Nil state] + +## (#Cons [last init']) +## (let' output (fold (lambda [tail head] +## (#Form (list (#Tag "Cons") (#Tuple (list head tail))))) +## last +## init') +## (#Right [state (#Cons [output #Nil])])))) + +## (def (as-pairs xs) +## (case' xs +## (#Cons [x (#Cons [y xs'])]) +## (#Cons [[x y] (as-pairs xs')]) + +## _ +## #Nil)) + +## (defmacro (let tokens state) +## (case' tokens +## (#Cons [(#Tuple bindings) (#Cons [body #Nil])]) +## (let' output (fold (lambda [body binding] +## (case' binding +## [label value] +## (#Form (list (#Symbol "lux;let'") label value body)))) +## body +## (reverse (as-pairs bindings))) +## (#Right [state (list output)])))) + +## (def (. f g) +## (lambda [x] (f (g x)))) + +## (def (++ xs ys) +## (case' xs +## #Nil +## ys + +## (#Cons [x xs*]) +## (#Cons [x (++ xs* ys)]))) + +## (def concat +## (fold ++ #Nil)) + +## (def (map f xs) +## (case' xs +## #Nil +## #Nil + +## (#Cons [x xs']) +## (#Cons [(f x) (map f xs')]))) + +## (def flat-map (. concat map)) + +## (def (untemplate-list tokens) +## (case' tokens +## #Nil +## (#Tag "Nil") + +## (#Cons [token tokens']) +## (#Form (#Cons [(#Tag "Cons") +## (#Cons [(#Tuple (#Cons [token (#Cons [(untemplate-list tokens') #Nil])])) +## #Nil])])))) + +## (def (untemplate token) +## (case' token +## (#Bool value) +## (#Form (list (#Tag "Bool") (#Bool value))) + +## (#Int value) +## (#Form (list (#Tag "Int") (#Int value))) + +## (#Real value) +## (#Form (list (#Tag "Real") (#Real value))) + +## (#Char value) +## (#Form (list (#Tag "Char") (#Char value))) + +## (#Text value) +## (#Form (list (#Tag "Text") (#Text value))) + +## (#Tag value) +## (#Form (list (#Tag "Tag") (#Text value))) + +## (#Symbol value) +## (#Form (list (#Tag "Symbol") (#Text value))) + +## (#Tuple elems) +## (#Form (list (#Tag "Tuple") (untemplate-list (map untemplate elems)))) + +## (#Form (#Cons [(#Symbol "~") (#Cons [unquoted #Nil])])) +## unquoted + +## (#Form elems) +## (#Form (list (#Tag "Form") (untemplate-list (map untemplate elems)))) +## )) + +## (defmacro (` tokens state) +## (case' tokens +## (#Cons [template #Nil]) +## (#Right [state (list (untemplate template))]))) + +## (defmacro (if tokens state) +## (case' tokens +## (#Cons [test (#Cons [then (#Cons [else #Nil])])]) +## (#Right [state +## (list (` (case' (~ test) +## true (~ then) +## false (~ else))))]))) + +## (def (filter p xs) +## (case' xs +## #Nil +## #Nil + +## (#Cons [x xs*]) +## (if (p x) +## (filter p xs*) +## (#Cons [x (filter p xs*)])))) + +## (def (return val) +## (lambda [state] +## (#Right [state val]))) + +## (def (fail msg) +## (lambda [_] +## (#Left msg))) -(def (bind f v) - (lambda [state] - (case' (v state) - (#Right [state' x]) - (f x state') +## (def (bind f v) +## (lambda [state] +## (case' (v state) +## (#Right [state' x]) +## (f x state') - (#Left msg) - (#Left msg)))) - -(def (first pair) - (case' pair - [f s] - f)) - -(def (second pair) - (case' pair - [f s] - s)) - -(defmacro (loop tokens) - (case' tokens - (#Cons [bindings (#Cons [body #Nil])]) - (let [pairs (as-pairs bindings)] - (return (list (#Form (#Cons [(` (lambda (~ (#Ident "recur")) (~ (#Tuple (map first pairs))) - (~ body))) - (map second pairs)]))))))) - -(defmacro (export tokens) - (return (map (lambda [t] (` (export' (~ t)))) - tokens))) - -(defmacro (and tokens) - (let [as-if (case' tokens - #Nil - (` true) - - (#Cons [init tests]) - (fold (lambda [prev next] - (` (if (~ prev) (~ next) false))) - init - tokens) - )] - (return (list as-if)))) - -(defmacro (or tokens) - (let [as-if (case' tokens - #Nil - (` false) - - (#Cons [init tests]) - (fold (lambda [prev next] - (` (if (~ prev) true (~ next)))) - init - tokens) - )] - (return (list as-if)))) - -(def (not x) - (case' x - true false - false true)) - -(defmacro (|> tokens) - (case' tokens - (#Cons [init apps]) - (return (list (fold (lambda [acc app] - (case' app - (#Form parts) - (#Form (++ parts (list acc))) - - _ - (` ((~ app) (~ acc))))) - init - apps))))) - -(defmacro ($ tokens) - (case' tokens - (#Cons [op (#Cons [init args])]) - (return (list (fold (lambda [acc elem] - (` ((~ op) (~ acc) (~ elem)))) - init - args))))) - -(def (const x) - (lambda [_] x)) - -(def (int> x y) - (jvm-lgt x y)) - -(def (int< x y) - (jvm-llt x y)) - -(def inc (int+ 1)) -(def dec (int+ -1)) - -(def (repeat n x) - (if (int> n 0) - (#Cons [x (repeat (dec n) x)]) - #Nil)) - -(def size - (fold (lambda [acc _] (inc acc)) 0)) - -(def (last xs) - (case' xs - #Nil #None - (#Cons [x #Nil]) (#Some x) - (#Cons [_ xs']) (last xs'))) - -(def (init xs) - (case' xs - #Nil #None - (#Cons [_ #Nil]) (#Some #Nil) - (#Cons [x xs']) (case' (init xs') - (#Some xs'') - (#Some (#Cons [x xs''])) - - _ - (#Some (#Cons [x #Nil]))))) - -(defmacro (cond tokens) - (case' (reverse tokens) - (#Cons [else branches']) - (return (list (fold (lambda [else branch] - (case' branch - [test then] - (` (if (~ test) (~ then) (~ else))))) - else - (|> branches' reverse as-pairs)))))) - -(def (interleave xs ys) - (case' [xs ys] - [(#Cons [x xs']) (#Cons [y ys'])] - (list+ x y (interleave xs' ys')) - - _ - #Nil)) - -(def (interpose sep xs) - (case' xs - #Nil - xs +## (#Left msg) +## (#Left msg)))) + +## (def (first pair) +## (case' pair +## [f s] +## f)) + +## (def (second pair) +## (case' pair +## [f s] +## s)) + +## (defmacro (loop tokens) +## (case' tokens +## (#Cons [bindings (#Cons [body #Nil])]) +## (let [pairs (as-pairs bindings)] +## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol "recur")) (~ (#Tuple (map first pairs))) +## (~ body))) +## (map second pairs)]))))))) + +## (defmacro (export tokens) +## (return (map (lambda [t] (` (export' (~ t)))) +## tokens))) + +## (defmacro (and tokens) +## (let [as-if (case' tokens +## #Nil +## (` true) + +## (#Cons [init tests]) +## (fold (lambda [prev next] +## (` (if (~ prev) (~ next) false))) +## init +## tokens) +## )] +## (return (list as-if)))) + +## (defmacro (or tokens) +## (let [as-if (case' tokens +## #Nil +## (` false) + +## (#Cons [init tests]) +## (fold (lambda [prev next] +## (` (if (~ prev) true (~ next)))) +## init +## tokens) +## )] +## (return (list as-if)))) + +## (def (not x) +## (case' x +## true false +## false true)) + +## (defmacro (|> tokens) +## (case' tokens +## (#Cons [init apps]) +## (return (list (fold (lambda [acc app] +## (case' app +## (#Form parts) +## (#Form (++ parts (list acc))) + +## _ +## (` ((~ app) (~ acc))))) +## init +## apps))))) + +## (defmacro ($ tokens) +## (case' tokens +## (#Cons [op (#Cons [init args])]) +## (return (list (fold (lambda [acc elem] +## (` ((~ op) (~ acc) (~ elem)))) +## init +## args))))) + +## (def (const x) +## (lambda [_] x)) + +## (def (int> x y) +## (jvm-lgt x y)) + +## (def (int< x y) +## (jvm-llt x y)) + +## (def inc (int+ 1)) +## (def dec (int+ -1)) + +## (def (repeat n x) +## (if (int> n 0) +## (#Cons [x (repeat (dec n) x)]) +## #Nil)) + +## (def size +## (fold (lambda [acc _] (inc acc)) 0)) + +## (def (last xs) +## (case' xs +## #Nil #None +## (#Cons [x #Nil]) (#Some x) +## (#Cons [_ xs']) (last xs'))) + +## (def (init xs) +## (case' xs +## #Nil #None +## (#Cons [_ #Nil]) (#Some #Nil) +## (#Cons [x xs']) (case' (init xs') +## (#Some xs'') +## (#Some (#Cons [x xs''])) + +## _ +## (#Some (#Cons [x #Nil]))))) + +## (defmacro (cond tokens) +## (case' (reverse tokens) +## (#Cons [else branches']) +## (return (list (fold (lambda [else branch] +## (case' branch +## [test then] +## (` (if (~ test) (~ then) (~ else))))) +## else +## (|> branches' reverse as-pairs)))))) + +## (def (interleave xs ys) +## (case' [xs ys] +## [(#Cons [x xs']) (#Cons [y ys'])] +## (list+ x y (interleave xs' ys')) + +## _ +## #Nil)) + +## (def (interpose sep xs) +## (case' xs +## #Nil +## xs - (#Cons [x #Nil]) - xs - - (#Cons [x xs']) - (list+ x sep (interpose sep xs')))) - -(def (empty? xs) - (case' xs - #Nil true - _ false)) - -## (do-template [<name> <op>] -## (def (<name> p xs) -## (case xs -## #Nil true -## (#Cons [x xs']) (<op> (p x) (<name> p xs')))) - -## [every? and] -## [any? or]) - -(def (range from to) - (if (int< from to) - (#Cons [from (range (inc from) to)]) - #Nil)) - -(def (tuple->list tuple) - (case' tuple - (#Tuple list) - list)) - -(def (zip2 xs ys) - (case' [xs ys] - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (zip2 xs' ys')]) - - _ - #Nil)) - -(def (get key map) - (case' map - #Nil - #None - - (#Cons [[k v] map']) - (if (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] - k [key]) - (#Some v) - (get key map')))) - -(def (get-ident x) - (case' x - (#Ident ident) - ident)) - -(def (text-++ x y) - (jvm-invokevirtual java.lang.String "concat" [java.lang.String] - x [y])) - -(def (show-env env) - (|> env (map first) (interpose ", ") (fold text-++ ""))) - -(def (apply-template env template) - (case' template - (#Ident ident) - (case' (get ident env) - (#Some subst) - subst - - _ - template) +## (#Cons [x #Nil]) +## xs + +## (#Cons [x xs']) +## (list+ x sep (interpose sep xs')))) + +## (def (empty? xs) +## (case' xs +## #Nil true +## _ false)) + +## ## (do-template [<name> <op>] +## ## (def (<name> p xs) +## ## (case xs +## ## #Nil true +## ## (#Cons [x xs']) (<op> (p x) (<name> p xs')))) + +## ## [every? and] +## ## [any? or]) + +## (def (range from to) +## (if (int< from to) +## (#Cons [from (range (inc from) to)]) +## #Nil)) + +## (def (tuple->list tuple) +## (case' tuple +## (#Tuple list) +## list)) + +## (def (zip2 xs ys) +## (case' [xs ys] +## [(#Cons [x xs']) (#Cons [y ys'])] +## (#Cons [[x y] (zip2 xs' ys')]) + +## _ +## #Nil)) + +## (def (get key map) +## (case' map +## #Nil +## #None + +## (#Cons [[k v] map']) +## (if (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] +## k [key]) +## (#Some v) +## (get key map')))) + +## (def (get-ident x) +## (case' x +## (#Symbol ident) +## ident)) + +## (def (text-++ x y) +## (jvm-invokevirtual java.lang.String "concat" [java.lang.String] +## x [y])) + +## (def (show-env env) +## (|> env (map first) (interpose ", ") (fold text-++ ""))) + +## (def (apply-template env template) +## (case' template +## (#Symbol ident) +## (case' (get ident env) +## (#Some subst) +## subst + +## _ +## template) - (#Tuple elems) - (#Tuple (map (apply-template env) elems)) - - (#Form elems) - (#Form (map (apply-template env) elems)) - - (#Record members) - (#Record (map (lambda [kv] - (case' kv - [slot value] - [(apply-template env slot) (apply-template env value)])) - members)) - - _ - template)) - -(defmacro (do-template tokens) - (case' tokens - (#Cons [bindings (#Cons [template data])]) - (let [bindings-list (map get-ident (tuple->list bindings)) - data-lists (map tuple->list data) - apply (lambda [env] (apply-template env template))] - (|> data-lists - (map (. apply (zip2 bindings-list))) - return)))) - -## (do-template [<name> <offset>] -## (def <name> (int+ <offset>)) - -## [inc 1] -## [dec -1]) - -(def (int= x y) - (jvm-leq x y)) - -(def (int% x y) - (jvm-lrem x y)) - -(def (int>= x y) - (or (int= x y) - (int> x y))) - -(do-template [<name> <cmp>] - (def (<name> x y) - (if (<cmp> x y) - x - y)) - - [max int>] - [min int<]) - -(do-template [<name> <cmp>] - (def (<name> n) (<cmp> n 0)) - - [neg? int<] - [pos? int>=]) - -(def (even? n) - (int= 0 (int% n 0))) - -(def (odd? n) - (not (even? n))) - -(do-template [<name> <done> <step>] - (def (<name> n xs) - (if (int> n 0) - (case' xs - #Nil #Nil - (#Cons [x xs']) <step>) - <done>)) - - [take #Nil (list+ x (take (dec n) xs'))] - [drop xs (drop (dec n) xs')]) - -(do-template [<name> <done> <step>] - (def (<name> f xs) - (case' xs - #Nil #Nil - (#Cons [x xs']) (if (f x) <step> #Nil))) - - [take-while #Nil (list+ x (take-while f xs'))] - [drop-while xs (drop-while f xs')]) - -(defmacro (get@ tokens) - (let [output (case' tokens - (#Cons [tag (#Cons [record #Nil])]) - (` (get@' (~ tag) (~ record))) - - (#Cons [tag #Nil]) - (` (lambda [record] (get@' (~ tag) record))))] - (return (list output)))) - -(defmacro (set@ tokens) - (let [output (case' tokens - (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) - (` (set@' (~ tag) (~ value) (~ record))) - - (#Cons [tag (#Cons [value #Nil])]) - (` (lambda [record] (set@' (~ tag) (~ value) record))) - - (#Cons [tag #Nil]) - (` (lambda [value record] (set@' (~ tag) value record))))] - (return (list output)))) - -(defmacro (update@ tokens) - (let [output (case' tokens - (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) - (` (let [_record_ (~ record)] - (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) - - (#Cons [tag (#Cons [func #Nil])]) - (` (lambda [record] - (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) - - (#Cons [tag #Nil]) - (` (lambda [func record] - (set@' (~ tag) (func (get@' (~ tag) record)) record))))] - (return (list output)))) - -(def (show-int int) - (jvm-invokevirtual java.lang.Object "toString" [] - int [])) - -(def gen-ident - (lambda [state] - [(update@ #gen-seed inc state) - (#Ident ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))])) - -## (do-template [<name> <member>] -## (def (<name> pair) -## (case' pair -## [f s] -## <member>)) - -## [first f] -## [second s]) - -(def (show-syntax syntax) - (case' syntax - (#Bool value) - (jvm-invokevirtual java.lang.Object "toString" [] - value []) +## (#Tuple elems) +## (#Tuple (map (apply-template env) elems)) + +## (#Form elems) +## (#Form (map (apply-template env) elems)) + +## (#Record members) +## (#Record (map (lambda [kv] +## (case' kv +## [slot value] +## [(apply-template env slot) (apply-template env value)])) +## members)) + +## _ +## template)) + +## (defmacro (do-template tokens) +## (case' tokens +## (#Cons [bindings (#Cons [template data])]) +## (let [bindings-list (map get-ident (tuple->list bindings)) +## data-lists (map tuple->list data) +## apply (lambda [env] (apply-template env template))] +## (|> data-lists +## (map (. apply (zip2 bindings-list))) +## return)))) + +## ## (do-template [<name> <offset>] +## ## (def <name> (int+ <offset>)) + +## ## [inc 1] +## ## [dec -1]) + +## (def (int= x y) +## (jvm-leq x y)) + +## (def (int% x y) +## (jvm-lrem x y)) + +## (def (int>= x y) +## (or (int= x y) +## (int> x y))) + +## (do-template [<name> <cmp>] +## (def (<name> x y) +## (if (<cmp> x y) +## x +## y)) + +## [max int>] +## [min int<]) + +## (do-template [<name> <cmp>] +## (def (<name> n) (<cmp> n 0)) + +## [neg? int<] +## [pos? int>=]) + +## (def (even? n) +## (int= 0 (int% n 0))) + +## (def (odd? n) +## (not (even? n))) + +## (do-template [<name> <done> <step>] +## (def (<name> n xs) +## (if (int> n 0) +## (case' xs +## #Nil #Nil +## (#Cons [x xs']) <step>) +## <done>)) + +## [take #Nil (list+ x (take (dec n) xs'))] +## [drop xs (drop (dec n) xs')]) + +## (do-template [<name> <done> <step>] +## (def (<name> f xs) +## (case' xs +## #Nil #Nil +## (#Cons [x xs']) (if (f x) <step> #Nil))) + +## [take-while #Nil (list+ x (take-while f xs'))] +## [drop-while xs (drop-while f xs')]) + +## (defmacro (get@ tokens) +## (let [output (case' tokens +## (#Cons [tag (#Cons [record #Nil])]) +## (` (get@' (~ tag) (~ record))) + +## (#Cons [tag #Nil]) +## (` (lambda [record] (get@' (~ tag) record))))] +## (return (list output)))) + +## (defmacro (set@ tokens) +## (let [output (case' tokens +## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) +## (` (set@' (~ tag) (~ value) (~ record))) + +## (#Cons [tag (#Cons [value #Nil])]) +## (` (lambda [record] (set@' (~ tag) (~ value) record))) + +## (#Cons [tag #Nil]) +## (` (lambda [value record] (set@' (~ tag) value record))))] +## (return (list output)))) + +## (defmacro (update@ tokens) +## (let [output (case' tokens +## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) +## (` (let [_record_ (~ record)] +## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) + +## (#Cons [tag (#Cons [func #Nil])]) +## (` (lambda [record] +## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) + +## (#Cons [tag #Nil]) +## (` (lambda [func record] +## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] +## (return (list output)))) + +## (def (show-int int) +## (jvm-invokevirtual java.lang.Object "toString" [] +## int [])) + +## (def gen-ident +## (lambda [state] +## [(update@ #gen-seed inc state) +## (#Symbol ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))])) + +## ## (do-template [<name> <member>] +## ## (def (<name> pair) +## ## (case' pair +## ## [f s] +## ## <member>)) + +## ## [first f] +## ## [second s]) + +## (def (show-syntax syntax) +## (case' syntax +## (#Bool value) +## (jvm-invokevirtual java.lang.Object "toString" [] +## value []) - (#Int value) - (jvm-invokevirtual java.lang.Object "toString" [] - value []) +## (#Int value) +## (jvm-invokevirtual java.lang.Object "toString" [] +## value []) - (#Real value) - (jvm-invokevirtual java.lang.Object "toString" [] - value []) +## (#Real value) +## (jvm-invokevirtual java.lang.Object "toString" [] +## value []) - (#Char value) - (jvm-invokevirtual java.lang.Object "toString" [] - value []) +## (#Char value) +## (jvm-invokevirtual java.lang.Object "toString" [] +## value []) - (#Text value) - (jvm-invokevirtual java.lang.Object "toString" [] - value []) +## (#Text value) +## (jvm-invokevirtual java.lang.Object "toString" [] +## value []) - (#Ident ident) - ident +## (#Symbol ident) +## ident - (#Tag tag) - (text-++ "#" tag) +## (#Tag tag) +## (text-++ "#" tag) - (#Tuple members) - ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]") +## (#Tuple members) +## ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]") - (#Form members) - ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")") - )) - -(defmacro (do tokens) - (case' tokens - (#Cons [(#Tuple bindings) (#Cons [body #Nil])]) - (let [output (fold (lambda [body binding] - (case' binding - [lhs rhs] - (` (bind (lambda [(~ lhs)] (~ body)) - (~ rhs))))) - body - (reverse (as-pairs bindings)))] - (return (list output))))) - -(def (map% f xs) - (case' xs - #Nil - (return xs) - - (#Cons [x xs']) - (do [y (f x) - ys (map% f xs')] - (return (#Cons [y ys]))))) - -(defmacro ($keys tokens) - (case' tokens - (#Cons [(#Tuple fields) #Nil]) - (return (list (#Record (map (lambda [slot] - (case' slot - (#Tag name) - [(#Tag name) (#Ident name)])) - fields)))))) - -(defmacro ($or tokens) - (case' tokens - (#Cons [(#Tuple patterns) (#Cons [body #Nil])]) - (return (flat-map (lambda [pattern] (list pattern body)) - patterns)))) - -(def null jvm-null) - -(defmacro (^ tokens) - (case' tokens - (#Cons [(#Ident class-name) #Nil]) - (return (list (` (#Data (~ (#Text class-name)))))))) - -(defmacro (, members) - (return (list (#Form (list+ (#Tag "Tuple") (untemplate-list members)))))) - -(defmacro (| members) - (let [members' (map (lambda [m] - (case' m - (#Tag tag) - [tag (` (#Tuple (list)))] +## (#Form members) +## ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")") +## )) + +## (defmacro (do tokens) +## (case' tokens +## (#Cons [(#Tuple bindings) (#Cons [body #Nil])]) +## (let [output (fold (lambda [body binding] +## (case' binding +## [lhs rhs] +## (` (bind (lambda [(~ lhs)] (~ body)) +## (~ rhs))))) +## body +## (reverse (as-pairs bindings)))] +## (return (list output))))) + +## (def (map% f xs) +## (case' xs +## #Nil +## (return xs) + +## (#Cons [x xs']) +## (do [y (f x) +## ys (map% f xs')] +## (return (#Cons [y ys]))))) + +## (defmacro ($keys tokens) +## (case' tokens +## (#Cons [(#Tuple fields) #Nil]) +## (return (list (#Record (map (lambda [slot] +## (case' slot +## (#Tag name) +## [(#Tag name) (#Symbol name)])) +## fields)))))) + +## (defmacro ($or tokens) +## (case' tokens +## (#Cons [(#Tuple patterns) (#Cons [body #Nil])]) +## (return (flat-map (lambda [pattern] (list pattern body)) +## patterns)))) + +## (def null jvm-null) + +## (defmacro (^ tokens) +## (case' tokens +## (#Cons [(#Symbol class-name) #Nil]) +## (return (list (` (#Data (~ (#Text class-name)))))))) + +## (defmacro (, members) +## (return (list (#Form (list+ (#Tag "Tuple") (untemplate-list members)))))) + +## (defmacro (| members) +## (let [members' (map (lambda [m] +## (case' m +## (#Tag tag) +## [tag (` (#Tuple (list)))] - (#Form (#Cons [tag (#Cons [value #Nil])])) - [tag (` (#Tuple (~ value)))])) - members)] - (return (list (#Form (list+ (#Tag "Variant") (untemplate-list members))))))) - -(defmacro (& members) - (let [members' (map (lambda [m] - (case' m - (#Form (#Cons [tag (#Cons [value #Nil])])) - [tag (` (#Tuple (~ value)))])) - members)] - (return (list (#Form (list+ (#Tag "Record") (untemplate-list members))))))) - -(defmacro (-> tokens) - (case' (reverse tokens) - (#Cons [f-return f-args]) - (fold (lambda [f-return f-arg] - (#Lambda [f-arg f-return])) - f-return f-args))) - -(def (replace-ident ident value syntax) - (case' syntax - (#Ident test) - (if (= test ident) - value - syntax) - - (#Form members) - (#Form (map (replace-ident ident value) members)) - - (#Tuple members) - (#Tuple (map (replace-ident ident value) members)) - - (#Record members) - (#Record (map (lambda [kv] - (case kv - [k v] - [k (replace-ident ident value v)])) - members)) - - _ - syntax)) - -(defmacro (All tokens) - (let [[name args body] (case' tokens - (#Cons [(#Ident name) (#Cons [(#Tuple args) (#Cons [body #Nil])])]) - [name args body] +## (#Form (#Cons [tag (#Cons [value #Nil])])) +## [tag (` (#Tuple (~ value)))])) +## members)] +## (return (list (#Form (list+ (#Tag "Variant") (untemplate-list members))))))) + +## (defmacro (& members) +## (let [members' (map (lambda [m] +## (case' m +## (#Form (#Cons [tag (#Cons [value #Nil])])) +## [tag (` (#Tuple (~ value)))])) +## members)] +## (return (list (#Form (list+ (#Tag "Record") (untemplate-list members))))))) + +## (defmacro (-> tokens) +## (case' (reverse tokens) +## (#Cons [f-return f-args]) +## (fold (lambda [f-return f-arg] +## (#Lambda [f-arg f-return])) +## f-return f-args))) + +## (def (replace-ident ident value syntax) +## (case' syntax +## (#Symbol test) +## (if (= test ident) +## value +## syntax) + +## (#Form members) +## (#Form (map (replace-ident ident value) members)) + +## (#Tuple members) +## (#Tuple (map (replace-ident ident value) members)) + +## (#Record members) +## (#Record (map (lambda [kv] +## (case kv +## [k v] +## [k (replace-ident ident value v)])) +## members)) + +## _ +## syntax)) + +## (defmacro (All tokens) +## (let [[name args body] (case' tokens +## (#Cons [(#Symbol name) (#Cons [(#Tuple args) (#Cons [body #Nil])])]) +## [name args body] - (#Cons [(#Tuple args) (#Cons [body #Nil])]) - ["" args body]) - rolled (fold (lambda [body arg] - (case' arg - (#Ident arg-name) - (` (#All (list) (~ (#Text "")) (~ arg) (~ (replace-ident arg-name (` (#Bound (~ (#Text arg-name)))) - body)))))) - body args)] - (case' rolled - (#Form (#Cons [(#Tag "All") (#Cons [env (#Cons [(#Test "") (#Cons [arg (#Cons [body #Nil])])])])])) - (return (list (` (#All (~ env) (~ (#Text name)) (~ arg) - (~ (replace-ident arg-name (` (#Bound (~ (#Text name)))) - body))))))))) - -(defmacro (Exists tokens) - (case' tokens - (#Cons [args (#Cons [body #Nil])]) - (return (list (` (All (~ args) (~ body))))))) - -(def Any (| #Any)) -(def Nothing (| #Nothing)) -(def Text (^ java.lang.String)) -(def Int (^ java.lang.Long)) - -(deftype (List a) - (| #Nil - (#Cons (, a (List a))))) - -(deftype #rec Type - (| #Any - #Nothing - (#Data Text) - (#Tuple (List Type)) - (#Variant (List (, Text Type))) - (#Record (List (, Text Type))) - (#Lambda (, Type Type)) - (#Bound Text) - (#Var Int) - (#All (, (List (, Text Type)) Text Text Type)) - (#App (, Type Type)))) - -(deftype (Either l r) - (| (#Left l) - (#Right r))) - -(deftype #rec Syntax - (| (#Bool Bool) - (#Int Int) - (#Real Real) - (#Char Char) - (#Text Text) - (#Form (List Syntax)) - (#Tuple (List Syntax)) - (#Record (List (, Text Syntax))))) - -(deftype Macro - (-> (List Syntax) CompilerState - (Either Text (, CompilerState (List Syntax))))) - -(def (macro-expand syntax) - (case' syntax - (#Form (#Cons [(#Ident macro-name) args])) - (do [macro (get-macro macro-name)] - ((coerce macro Macro) args)))) - -(defmacro (case tokens) - (case' tokens - (#Cons value branches) - (loop [kind #Pattern - pieces branches - new-pieces (list)] - (case' pieces - #Nil - (return (list (' (case' (~ value) (~@ new-pieces))))) - - (#Cons piece pieces') - (let [[kind' expanded more-pieces] (case' kind - #Body - [#Pattern (list piece) #Nil] - - #Pattern - (do [expansion (macro-expand piece)] - (case' expansion - #Nil - [#Pattern #Nil #Nil] - - (#Cons exp #Nil) - [#Body (list exp) #Nil] - - (#Cons exp exps) - [#Body (list exp) exps])) - )] - (recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) - ))) - -(def (defsyntax tokens) - ...) - -(deftype (State s a) - (-> s (, s a))) - -(deftype (Parser a) - (State (List Syntax) a)) - -(def (parse-ctor tokens) - (Parser (, Syntax (List Syntax))) - (case tokens - (list+ (#Ident name) tokens') - [tokens' [(#Ident name) (list)]] +## (#Cons [(#Tuple args) (#Cons [body #Nil])]) +## ["" args body]) +## rolled (fold (lambda [body arg] +## (case' arg +## (#Symbol arg-name) +## (` (#All (list) (~ (#Text "")) (~ arg) (~ (replace-ident arg-name (` (#Bound (~ (#Text arg-name)))) +## body)))))) +## body args)] +## (case' rolled +## (#Form (#Cons [(#Tag "All") (#Cons [env (#Cons [(#Test "") (#Cons [arg (#Cons [body #Nil])])])])])) +## (return (list (` (#All (~ env) (~ (#Text name)) (~ arg) +## (~ (replace-ident arg-name (` (#Bound (~ (#Text name)))) +## body))))))))) + +## (defmacro (Exists tokens) +## (case' tokens +## (#Cons [args (#Cons [body #Nil])]) +## (return (list (` (All (~ args) (~ body))))))) + +## (def Any (| #Any)) +## (def Nothing (| #Nothing)) +## (def Text (^ java.lang.String)) +## (def Int (^ java.lang.Long)) + +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) + +## (deftype #rec Type +## (| #Any +## #Nothing +## (#Data Text) +## (#Tuple (List Type)) +## (#Variant (List (, Text Type))) +## (#Record (List (, Text Type))) +## (#Lambda (, Type Type)) +## (#Bound Text) +## (#Var Int) +## (#All (, (List (, Text Type)) Text Text Type)) +## (#App (, Type Type)))) + +## (deftype (Either l r) +## (| (#Left l) +## (#Right r))) + +## (deftype #rec Syntax +## (| (#Bool Bool) +## (#Int Int) +## (#Real Real) +## (#Char Char) +## (#Text Text) +## (#Form (List Syntax)) +## (#Tuple (List Syntax)) +## (#Record (List (, Text Syntax))))) + +## (deftype Macro +## (-> (List Syntax) CompilerState +## (Either Text (, CompilerState (List Syntax))))) + +## (def (macro-expand syntax) +## (case' syntax +## (#Form (#Cons [(#Symbol macro-name) args])) +## (do [macro (get-macro macro-name)] +## ((coerce macro Macro) args)))) + +## (defmacro (case tokens) +## (case' tokens +## (#Cons value branches) +## (loop [kind #Pattern +## pieces branches +## new-pieces (list)] +## (case' pieces +## #Nil +## (return (list (' (case' (~ value) (~@ new-pieces))))) + +## (#Cons piece pieces') +## (let [[kind' expanded more-pieces] (case' kind +## #Body +## [#Pattern (list piece) #Nil] + +## #Pattern +## (do [expansion (macro-expand piece)] +## (case' expansion +## #Nil +## [#Pattern #Nil #Nil] + +## (#Cons exp #Nil) +## [#Body (list exp) #Nil] + +## (#Cons exp exps) +## [#Body (list exp) exps])) +## )] +## (recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) +## ))) + +## (def (defsyntax tokens) +## ...) + +## (deftype (State s a) +## (-> s (, s a))) + +## (deftype (Parser a) +## (State (List Syntax) a)) + +## (def (parse-ctor tokens) +## (Parser (, Syntax (List Syntax))) +## (case tokens +## (list+ (#Symbol name) tokens') +## [tokens' [(#Symbol name) (list)]] - (list+ (#Form (list+ (#Ident name) args)) tokens') - [tokens' [(#Ident name) args]])) - -(defsyntax (defsig - [[name args] parse-ctor] - [anns ($+ $1)]) - (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) - (` (#Record (~ (untemplate-list ...)))) - args)] - (return (list (` (def (~ name) (~ def-body))))))) - -(defsyntax (defstruct - [[name args] parse-ctor] - signature - [defs ($+ $1)]) - (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) - (` (#Record (~ (untemplate-list ...)))) - args)] - (return (list (` (def (~ name) - (: (~ def-body) (~ signature)))))))) - -(defsig (Monad m) - (: return (All [a] (-> a (m a)))) - (: bind (All [a b] (-> (-> a (m b)) (m a) (m b))))) - -(defstruct ListMonad (Monad List) - (def (return x) - (list x)) +## (list+ (#Form (list+ (#Symbol name) args)) tokens') +## [tokens' [(#Symbol name) args]])) + +## (defsyntax (defsig +## [[name args] parse-ctor] +## [anns ($+ $1)]) +## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) +## (` (#Record (~ (untemplate-list ...)))) +## args)] +## (return (list (` (def (~ name) (~ def-body))))))) + +## (defsyntax (defstruct +## [[name args] parse-ctor] +## signature +## [defs ($+ $1)]) +## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) +## (` (#Record (~ (untemplate-list ...)))) +## args)] +## (return (list (` (def (~ name) +## (: (~ def-body) (~ signature)))))))) + +## (defsig (Monad m) +## (: return (All [a] (-> a (m a)))) +## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b))))) + +## (defstruct ListMonad (Monad List) +## (def (return x) +## (list x)) - (def bind (. concat map))) +## (def bind (. concat map))) -(defsig (Eq a) - (: = (-> a a Bool))) +## (defsig (Eq a) +## (: = (-> a a Bool))) -(defstruct (List_Eq A_Eq) - (All [a] (-> (Eq a) (Eq (List a)))) +## (defstruct (List_Eq A_Eq) +## (All [a] (-> (Eq a) (Eq (List a)))) - (def (= xs ys) - (and (= (length xs) (length ys)) - (map (lambda [[x y]] - (with A_Eq - (= x y))) - (zip2 xs ys))))) +## (def (= xs ys) +## (and (= (length xs) (length ys)) +## (map (lambda [[x y]] +## (with A_Eq +## (= x y))) +## (zip2 xs ys))))) -## (def (with tokens) -## ...) +## ## (def (with tokens) +## ## ...) -## TODO: Full pattern-matching -## TODO: Type-related macros -## TODO: (Im|Ex)ports-related macros -## TODO: Macro-related macros +## ## TODO: Full pattern-matching +## ## TODO: Type-related macros +## ## TODO: (Im|Ex)ports-related macros +## ## TODO: Macro-related macros -## (import "lux") -## (module-alias "lux" "l") -## (def-alias "lux;map" "map") +## ## (import "lux") +## ## (module-alias "lux" "l") +## ## (def-alias "lux;map" "map") -## (def (require tokens) -## (case tokens -## ...)) +## ## (def (require tokens) +## ## (case tokens +## ## ...)) -## (require lux #as l #refer [map]) +## ## (require lux #as l #refer [map]) diff --git a/src/lux.clj b/src/lux.clj index 3516f2a9c..b0a9a3c94 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -1,5 +1,6 @@ (ns lux - (:require [lux.compiler :as &compiler] + (:require [lux.base :as &] + [lux.compiler :as &compiler] :reload-all)) (comment @@ -13,9 +14,9 @@ ;; TODO: All optimizations ;; TODO: Take module-name aliasing into account. ;; TODO: - - (time (&compiler/compile-all ["lux"])) - (time (&compiler/compile-all ["lux" "test2"])) + + (time (&compiler/compile-all (&/|list "lux"))) + (time (&compiler/compile-all (&/|list "lux" "test2"))) ;; 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 235478782..f9c104378 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -14,14 +14,14 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (matchv ::M/objects [token] - [["Form" ["Cons" [["Ident" "jvm-catch"] - ["Cons" [["Ident" ?ex-class] - ["Cons" [["Ident" ?ex-arg] + [["Form" ["Cons" [["Symbol" "jvm-catch"] + ["Cons" [["Symbol" ?ex-class] + ["Cons" [["Symbol" ?ex-arg] ["Cons" [?catch-body ["Nil" _]]]]]]]]]]] [(concat catch+ (list [?ex-class ?ex-arg ?catch-body])) finally+] - [["Form" ["Cons" [["Ident" "jvm-finally"] + [["Form" ["Cons" [["Symbol" "jvm-finally"] ["Cons" [?finally-body ["Nil" _]]]]]]] [catch+ ?finally-body])) @@ -56,197 +56,197 @@ (return (&/|list [&/V "Expression" (&/T (&/V "variant" (&/T ?tag (&/V "Expression" (&/T (&/V "tuple" (&/|list)) tuple-type)))) (&/V "Variant" (&/V "Cons" (&/T (&/T ?tag tuple-type) (&/V "Nil" nil)))))]))) - [["Ident" "jvm-null"]] + [["Symbol" "jvm-null"]] (return (&/|list [&/V "Expression" (&/T (&/V "jvm-null" nil) (&/V "Data" (&/T "null" (&/V "Nil" nil))))])) - [["Ident" ?ident]] + [["Symbol" ?ident]] (&&lux/analyse-ident analyse ?ident) - [["Form" ["Cons" [["Ident" "case'"] + [["Form" ["Cons" [["Symbol" "case'"] ["Cons" [?variant ?branches]]]]]] (&&lux/analyse-case analyse ?variant ?branches) - [["Form" ["Cons" [["Ident" "lambda'"] - ["Cons" [["Ident" ?self] - ["Cons" [["Ident" ?arg] + [["Form" ["Cons" [["Symbol" "lambda'"] + ["Cons" [["Symbol" ?self] + ["Cons" [["Symbol" ?arg] ["Cons" [?body ["Nil" _]]]]]]]]]]] (&&lux/analyse-lambda analyse ?self ?arg ?body) - [["Form" ["Cons" [["Ident" "get@'"] ["Cons" [["Tag" ?slot] ["Cons" [?record ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "get@'"] ["Cons" [["Tag" ?slot] ["Cons" [?record ["Nil" _]]]]]]]]] (&&lux/analyse-get analyse ?slot ?record) - [["Form" ["Cons" [["Ident" "set@'"] ["Cons" [["Tag" ?slot] ["Cons" [?value ["Cons" [?record ["Nil" _]]]]]]]]]]] + [["Form" ["Cons" [["Symbol" "set@'"] ["Cons" [["Tag" ?slot] ["Cons" [?value ["Cons" [?record ["Nil" _]]]]]]]]]]] (&&lux/analyse-set analyse ?slot ?value ?record) - [["Form" ["Cons" [["Ident" "def'"] ["Cons" [["Ident" ?name] ["Cons" [?value ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "def'"] ["Cons" [["Symbol" ?name] ["Cons" [?value ["Nil" _]]]]]]]]] (&&lux/analyse-def analyse ?name ?value) - [["Form" ["Cons" [["Ident" "declare-macro"] ["Cons" [["Ident" ?ident] ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "declare-macro"] ["Cons" [["Symbol" ?ident] ["Nil" _]]]]]]] (&&lux/analyse-declare-macro ?ident) - [["Form" ["Cons" [["Ident" "import'"] ["Cons" [["Text" ?path] ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "import'"] ["Cons" [["Text" ?path] ["Nil" _]]]]]]] (&&lux/analyse-import analyse ?path) - [["Form" ["Cons" [["Ident" ":"] ["Cons" [?value ["Cons" [?type ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" ":"] ["Cons" [?value ["Cons" [?type ["Nil" _]]]]]]]]] (&&lux/analyse-check analyse eval! ?type ?value) - [["Form" ["Cons" [["Ident" "coerce"] ["Cons" [?type ["Cons" [?value ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "coerce"] ["Cons" [?type ["Cons" [?value ["Nil" _]]]]]]]]] (&&lux/analyse-coerce analyse eval! ?type ?value) ;; Host special forms - [["Form" ["Cons" [["Ident" "exec"] ?exprs]]]] + [["Form" ["Cons" [["Symbol" "exec"] ?exprs]]]] (&&host/analyse-exec analyse ?exprs) ;; Integer arithmetic - [["Form" ["Cons" [["Ident" "jvm-iadd"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-iadd"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-iadd analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-isub"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-isub"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-isub analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-imul"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-imul"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-imul analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-idiv"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-idiv"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-idiv analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-irem"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-irem"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-irem analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-ieq"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-ieq"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-ieq analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-ilt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-ilt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-ilt analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-igt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-igt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-igt analyse ?x ?y) ;; Long arithmetic - [["Form" ["Cons" [["Ident" "jvm-ladd"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-ladd"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-ladd analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lsub"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lsub"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lsub analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lmul"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lmul"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lmul analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-ldiv"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-ldiv"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-ldiv analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lrem"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lrem"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lrem analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-leq"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-leq"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-leq analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-llt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-llt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-llt analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lgt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lgt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lgt analyse ?x ?y) ;; Float arithmetic - [["Form" ["Cons" [["Ident" "jvm-fadd"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-fadd"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-fadd analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-fsub"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-fsub"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-fsub analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-fmul"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-fmul"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-fmul analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-fdiv"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-fdiv"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-fdiv analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-frem"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-frem"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-frem analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-feq"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-feq"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-feq analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-flt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-flt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-flt analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-fgt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-fgt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-fgt analyse ?x ?y) ;; Double arithmetic - [["Form" ["Cons" [["Ident" "jvm-dadd"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-dadd"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-dadd analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-dsub"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-dsub"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-dsub analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-dmul"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-dmul"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-dmul analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-ddiv"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-ddiv"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-ddiv analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-drem"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-drem"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-drem analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-deq"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-deq"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-deq analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-dlt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-dlt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-dlt analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-dgt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-dgt"] ["Cons" [?y ["Cons" [?x ["Nil" _]]]]]]]]] (&&host/analyse-jvm-dgt analyse ?x ?y) ;; Objects - [["Form" ["Cons" [["Ident" "jvm-null?"] ["Cons" [?object ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-null?"] ["Cons" [?object ["Nil" _]]]]]]] (&&host/analyse-jvm-null? analyse ?object) - [["Form" ["Cons" [["Ident" "jvm-new"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-new"] + ["Cons" [["Symbol" ?class] ["Cons" [["Tuple" ?classes] ["Cons" [["Tuple" ?args] ["Nil" _]]]]]]]]]]] (&&host/analyse-jvm-new analyse ?class ?classes ?args) - [["Form" ["Cons" [["Ident" "jvm-getstatic"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-getstatic"] + ["Cons" [["Symbol" ?class] ["Cons" [["Text" ?field] ["Nil" _]]]]]]]]] (&&host/analyse-jvm-getstatic analyse ?class ?field) - [["Form" ["Cons" [["Ident" "jvm-getfield"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-getfield"] + ["Cons" [["Symbol" ?class] ["Cons" [["Text" ?field] ["Cons" [?object ["Nil" _]]]]]]]]]]] (&&host/analyse-jvm-getfield analyse ?class ?field ?object) - [["Form" ["Cons" [["Ident" "jvm-putstatic"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-putstatic"] + ["Cons" [["Symbol" ?class] ["Cons" [["Text" ?field] ["Cons" [?value ["Nil" _]]]]]]]]]]] (&&host/analyse-jvm-putstatic analyse ?class ?field ?value) - [["Form" ["Cons" [["Ident" "jvm-putfield"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-putfield"] + ["Cons" [["Symbol" ?class] ["Cons" [["Text" ?field] ["Cons" [?object ["Cons" [?value ["Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value) - [["Form" ["Cons" [["Ident" "jvm-invokestatic"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-invokestatic"] + ["Cons" [["Symbol" ?class] ["Cons" [["Text" ?method] ["Cons" [["Tuple" ?classes] ["Cons" [["Tuple" ?args] ["Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args) - [["Form" ["Cons" [["Ident" "jvm-invokevirtual"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-invokevirtual"] + ["Cons" [["Symbol" ?class] ["Cons" [["Text" ?method] ["Cons" [["Tuple" ?classes] ["Cons" [?object @@ -254,8 +254,8 @@ ["Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args) - [["Form" ["Cons" [["Ident" "jvm-invokeinterface"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-invokeinterface"] + ["Cons" [["Symbol" ?class] ["Cons" [["Text" ?method] ["Cons" [["Tuple" ?classes] ["Cons" [?object @@ -263,8 +263,8 @@ ["Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args) - [["Form" ["Cons" [["Ident" "jvm-invokespecial"] - ["Cons" [["Ident" ?class] + [["Form" ["Cons" [["Symbol" "jvm-invokespecial"] + ["Cons" [["Symbol" ?class] ["Cons" [["Text" ?method] ["Cons" [["Tuple" ?classes] ["Cons" [?object @@ -273,117 +273,117 @@ (&&host/analyse-jvm-invokespecial analyse ?class ?method ?classes ?object ?args) ;; Exceptions - [["Form" ["Cons" [["Ident" "jvm-try"] + [["Form" ["Cons" [["Symbol" "jvm-try"] ["Cons" [?body ?handlers]]]]]] (&&host/analyse-jvm-try analyse ?body (&/fold parse-handler [(list) nil] ?handlers)) - [["Form" ["Cons" [["Ident" "jvm-throw"] + [["Form" ["Cons" [["Symbol" "jvm-throw"] ["Cons" [?ex ["Nil" _]]]]]]] (&&host/analyse-jvm-throw analyse ?ex) ;; Syncronization/monitos - [["Form" ["Cons" [["Ident" "jvm-monitorenter"] + [["Form" ["Cons" [["Symbol" "jvm-monitorenter"] ["Cons" [?monitor ["Nil" _]]]]]]] (&&host/analyse-jvm-monitorenter analyse ?monitor) - [["Form" ["Cons" [["Ident" "jvm-monitorexit"] + [["Form" ["Cons" [["Symbol" "jvm-monitorexit"] ["Cons" [?monitor ["Nil" _]]]]]]] (&&host/analyse-jvm-monitorexit analyse ?monitor) ;; Primitive conversions - [["Form" ["Cons" [["Ident" "jvm-d2f"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-d2f"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-d2f analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-d2i"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-d2i"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-d2i analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-d2l"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-d2l"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-d2l analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-f2d"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-f2d"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-f2d analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-f2i"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-f2i"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-f2i analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-f2l"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-f2l"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-f2l analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-i2b"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-i2b"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-i2b analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-i2c"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-i2c"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-i2c analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-i2d"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-i2d"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-i2d analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-i2f"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-i2f"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-i2f analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-i2l"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-i2l"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-i2l analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-i2s"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-i2s"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-i2s analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-l2d"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-l2d"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-l2d analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-l2f"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-l2f"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-l2f analyse ?value) - [["Form" ["Cons" [["Ident" "jvm-l2i"] ["Cons" [?value ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-l2i"] ["Cons" [?value ["Nil" _]]]]]]] (&&host/analyse-jvm-l2i analyse ?value) ;; Bitwise operators - [["Form" ["Cons" [["Ident" "jvm-iand"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-iand"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] (&&host/analyse-jvm-iand analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-ior"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-ior"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] (&&host/analyse-jvm-ior analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-land"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-land"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] (&&host/analyse-jvm-land analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lor"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lor"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lor analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lxor"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lxor"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lxor analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lshl"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lshl"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lshl analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lshr"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lshr"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lshr analyse ?x ?y) - [["Form" ["Cons" [["Ident" "jvm-lushr"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-lushr"] ["Cons" [?x ["Cons" [?y ["Nil" _]]]]]]]]] (&&host/analyse-jvm-lushr analyse ?x ?y) ;; Arrays - [["Form" ["Cons" [["Ident" "jvm-new-array"] ["Cons" [["Ident" ?class] ["Cons" [["Int" ?length] ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-new-array"] ["Cons" [["Symbol" ?class] ["Cons" [["Int" ?length] ["Nil" _]]]]]]]]] (&&host/analyse-jvm-new-array analyse ?class ?length) - [["Form" ["Cons" [["Ident" "jvm-aastore"] ["Cons" [?array ["Cons" [["Int" ?idx] ["Cons" [?elem ["Nil" _]]]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-aastore"] ["Cons" [?array ["Cons" [["Int" ?idx] ["Cons" [?elem ["Nil" _]]]]]]]]]]] (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["Form" ["Cons" [["Ident" "jvm-aaload"] ["Cons" [?array ["Cons" [["Int" ?idx] ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-aaload"] ["Cons" [?array ["Cons" [["Int" ?idx] ["Nil" _]]]]]]]]] (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - [["Form" ["Cons" [["Ident" "jvm-class"] ["Cons" [["Ident" ?name] ["Cons" [["Ident" ?super-class] ["Cons" [["Tuple" ?fields] ["Nil" _]]]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-class"] ["Cons" [["Symbol" ?name] ["Cons" [["Symbol" ?super-class] ["Cons" [["Tuple" ?fields] ["Nil" _]]]]]]]]]]] (&&host/analyse-jvm-class analyse ?name ?super-class ?fields) - [["Form" ["Cons" [["Ident" "jvm-interface"] ["Cons" [["Ident" ?name] ?members]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-interface"] ["Cons" [["Symbol" ?name] ?members]]]]]] (&&host/analyse-jvm-interface analyse ?name ?members) ;; Programs - [["Form" ["Cons" [["Ident" "jvm-program"] ["Cons" [["Ident" ?args] ["Cons" [?body ["Nil" _]]]]]]]]] + [["Form" ["Cons" [["Symbol" "jvm-program"] ["Cons" [["Symbol" ?args] ["Cons" [?body ["Nil" _]]]]]]]]] (&&host/analyse-jvm-program analyse ?args ?body) [_] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index cd5bf9e39..1574218c3 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -10,7 +10,7 @@ ;; [Resources] (defn locals [member] (matchv ::M/objects [member] - [["Ident" ?name]] + [["Symbol" ?name]] (&/|list ?name) [["Tuple" ?submembers]] diff --git a/src/lux/analyser/def.clj b/src/lux/analyser/def.clj index e83bbb85d..45bb5aca7 100644 --- a/src/lux/analyser/def.clj +++ b/src/lux/analyser/def.clj @@ -14,7 +14,7 @@ (defn <name> [module name] (fn [state] (return* state - (->> state (&/get$ "modules") (&/|get module) (&/get$ <category>) (&/|get name) boolean)))) + (->> state (&/get$ "modules") (&/|get module) (&/get$ <category>) (&/|contains? name))))) defined? "defs" macro? "macros" @@ -31,5 +31,16 @@ bound (&/V "Expression" (&/T (&/V "global" (&/T module name)) type))] (return* (->> state (&/update$ "modules" (fn [ms] (&/|update module (fn [m] (&/update$ "defs" #(&/|put name type %) m)) ms))) - (&/update$ "global-env" #(&/|merge (&/|table full-name bound, name bound) %))) + (&/update$ "global-env" #(matchv ::M/objects [%] + [["None" _]] + (assert false) + + [["Some" table]] + (&/V "Some" (&/update$ "locals" (fn [locals] + (&/update$ "mappings" (fn [mappings] + (&/|merge (&/|table full-name bound, name bound) + mappings)) + locals)) + table)) + ))) nil)))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 816332404..4d1af9aa9 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -13,20 +13,20 @@ (fn [state] (let [old-mappings (->> state (&/get$ "local-envs") &/|head (&/get$ "locals") (&/get$ "mappings")) =return (body (&/update$ "local-envs" - (fn [[top & stack]] - (let [bound-unit (&/V "local" (-> top (&/get$ "locals") (&/get$ "counter")))] - (cons (-> top - (&/update$ "locals" #(&/update$ "counter" inc %)) - (&/update$ "locals" #(&/update$ "mappings" (fn [m] (&/|put name (&/V "Expression" (&/T bound-unit type)) m)) %))) - stack))) + (fn [stack] + (let [bound-unit (&/V "local" (->> (&/|head stack) (&/get$ "locals") (&/get$ "counter")))] + (&/|cons (->> (&/|head stack) + (&/update$ "locals" #(&/update$ "counter" inc %)) + (&/update$ "locals" #(&/update$ "mappings" (fn [m] (&/|put name (&/V "Expression" (&/T bound-unit type)) m)) %))) + (&/|tail stack)))) state))] (matchv ::M/objects [=return] [["Right" [?state ?value]]] - (return* (&/update$ "local-envs" (fn [[top* & stack*]] - (cons (->> top* - (&/update$ "locals" #(&/update$ "counter" dec %)) - (&/update$ "locals" #(&/set$ "mappings" old-mappings %))) - stack*)) + (return* (&/update$ "local-envs" (fn [stack*] + (&/|cons (->> (&/|head stack*) + (&/update$ "locals" #(&/update$ "counter" dec %)) + (&/update$ "locals" #(&/set$ "mappings" old-mappings %))) + (&/|tail stack*))) ?state) ?value) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 15680d681..6fff76590 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -10,21 +10,13 @@ [env :as &&env]))) ;; [Utils] -(defn ^:private ->seq [xs] - (matchv ::M/objects [xs] - [["Nil" _]] - (list) - - [["Cons" [x xs*]]] - (cons x (->seq xs*)))) - (defn ^:private extract-ident [ident] (matchv ::M/objects [ident] - [["Ident" ?ident]] + [["Symbol" ?ident]] (return ?ident) [_] - (fail "[Analyser Error] Can't extract Ident."))) + (fail "[Analyser Error] Can't extract Symbol."))) ;; [Resources] (do-template [<name> <output-tag> <input-class> <output-class>] @@ -144,7 +136,7 @@ (defn analyse-jvm-new-array [analyse ?class ?length] (exec [=class (&host/full-class-name ?class)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-new-array" (&/T =class ?length)) (&/V "array" (&/T (&/V "Data" (to-array [=class (&/V "Nil" nil)])) - (&/V "Nil" nil))))))))) + (&/V "Nil" nil))))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (exec [=array+=elem (&&/analyse-2 analyse ?array ?elem) @@ -161,13 +153,13 @@ (defn analyse-jvm-class [analyse ?name ?super-class ?fields] (exec [?fields (&/map% (fn [?field] - (matchv ::M/objects [?field] - [["Tuple" ["Cons" [["Ident" ?class] ["Cons" [["Ident" ?field-name] ["Nil" _]]]]]]] - (return [?class ?field-name]) - - [_] - (fail "[Analyser Error] Fields must be Tuple2 of [Ident, Ident]"))) - ?fields) + (matchv ::M/objects [?field] + [["Tuple" ["Cons" [["Symbol" ?class] ["Cons" [["Symbol" ?field-name] ["Nil" _]]]]]]] + (return [?class ?field-name]) + + [_] + (fail "[Analyser Error] Fields must be Tuple2 of [Symbol, Symbol]"))) + ?fields) :let [=fields (into {} (for [[class field] ?fields] [field {:access :public :type class}]))] @@ -175,25 +167,26 @@ (return (&/|list (&/V "Statement" (&/V "jvm-class" (&/T $module ?name ?super-class =fields {}))))))) (defn analyse-jvm-interface [analyse ?name ?members] - ;; (prn 'analyse-jvm-interface ?name ?members) - (exec [?members (&/map% (fn [member] - ;; (prn 'analyse-jvm-interface (&/show-ast member)) - (matchv ::M/objects [member] - [["Form" ["Cons" [["Ident" ":"] - ["Cons" [["Ident" ?member-name] - ["Cons" [["Form" ["Cons" [["Ident" "->"] - ["Cons" [["Tuple" ?inputs] - ["Cons" [["Ident" ?output] - ["Nil" _]]]]]]]] - ["Nil" _]]]]]]]]] - (do ;; (prn 'analyse-jvm-interface ?member-name ?inputs ?output) - (exec [?inputs (&/map% extract-ident (->seq ?inputs))] - (return [?member-name [?inputs ?output]]))) - - [_] - (fail "[Analyser Error] Invalid method signature!"))) - (->seq ?members)) - :let [=methods (into {} (for [[method [inputs output]] ?members] + (prn 'analyse-jvm-interface ?name ?members) + (exec [=members (&/map% (fn [member] + ;; (prn 'analyse-jvm-interface (&/show-ast member)) + (matchv ::M/objects [member] + [["Form" ["Cons" [["Symbol" ":"] + ["Cons" [["Symbol" ?member-name] + ["Cons" [["Form" ["Cons" [["Symbol" "->"] + ["Cons" [["Tuple" ?inputs] + ["Cons" [["Symbol" ?output] + ["Nil" _]]]]]]]] + ["Nil" _]]]]]]]]] + (do ;; (prn 'analyse-jvm-interface ?member-name ?inputs ?output) + (exec [?inputs (&/map% extract-ident ?inputs)] + (return [?member-name [?inputs ?output]]))) + + [_] + (fail "[Analyser Error] Invalid method signature!"))) + ?members) + :let [_ (prn '=members =members) + =methods (into {} (for [[method [inputs output]] (&/->seq =members)] [method {:access :public :type [inputs output]}]))] $module &/get-module-name] @@ -208,10 +201,10 @@ (defn analyse-jvm-try [analyse ?body [?catches ?finally]] (exec [=body (&&/analyse-1 analyse ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (&&env/with-local ?ex-arg (&/V "Data" (&/T ?ex-class (&/V "Nil" nil))) - (exec [=catch-body (&&/analyse-1 analyse ?catch-body)] - (return [?ex-class ?ex-arg =catch-body])))) - ?catches) + (&&env/with-local ?ex-arg (&/V "Data" (&/T ?ex-class (&/V "Nil" nil))) + (exec [=catch-body (&&/analyse-1 analyse ?catch-body)] + (return [?ex-class ?ex-arg =catch-body])))) + ?catches) =finally (&&/analyse-1 analyse ?finally) =body-type (&&/expr-type =body)] (return (&/|list (&/V "Expression" (&/T (&/V "jvm-try" (&/T =body =catches =finally)) =body-type)))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index e70fd7bf6..758d0bb6b 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -13,13 +13,13 @@ (&env/with-local arg arg-type (exec [=return body =captured &env/captured-vars] - (return [scope-name =captured =return]))))))) + (return (&/T scope-name =captured =return)))))))) (defn close-over [scope ident register frame] (matchv ::M/objects [register] [["Expression" [_ register-type]]] (let [register* (&/V "Expression" (&/T (&/V "captured" (&/T scope (->> frame (&/get$ "closure") (&/get$ "counter")) register)) register-type))] - [register* (&/update$ "closure" #(-> % - (&/update$ "counter" inc) - (&/update$ "mappings" (fn [mps] (&/|put ident register* mps)))) - frame)]))) + (&/T register* (&/update$ "closure" #(->> % + (&/update$ "counter" inc) + (&/update$ "mappings" (fn [mps] (&/|put ident register* mps)))) + frame))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index c0124936e..daec2bd0a 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -2,7 +2,7 @@ (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return return* fail fail*]] + (lux [base :as & :refer [exec return return* fail fail* |let]] [parser :as &parser] [type :as &type] [macro :as ¯o] @@ -23,48 +23,64 @@ (defn analyse-record [analyse ?elems] (exec [=elems (&/map% (fn [kv] - (matchv ::M/objects [kv] - [[k v]] - (exec [=v (&&/analyse-1 analyse v)] - (return (to-array [k =v]))))) - ?elems) + (matchv ::M/objects [kv] + [[k v]] + (exec [=v (&&/analyse-1 analyse v)] + (return (to-array [k =v]))))) + ?elems) =elems-types (&/map% (fn [kv] - (matchv ::M/objects [kv] - [[k v]] - (exec [=v (&&/expr-type v)] - (return (to-array [k =v]))))) - =elems) + (matchv ::M/objects [kv] + [[k v]] + (exec [=v (&&/expr-type v)] + (return (to-array [k =v]))))) + =elems) ;; :let [_ (prn 'analyse-tuple =elems)] ] (return (&/|list (&/V "Expression" (&/T (&/V "record" =elems) (&/V "Record" =elems-types))))))) (defn analyse-ident [analyse ident] + (prn 'analyse-ident ident) (exec [module-name &/get-module-name] (fn [state] - (let [[top & stack*] (&/get$ "local-envs" state)] - (if-let [=bound (or (->> top (&/get$ "locals") (&/get$ "mappings") (&/|get ident)) - (->> top (&/get$ "closure") (&/get$ "mappings") (&/|get ident)))] - (return* state (&/|list =bound)) - (let [no-binding? #(and (->> % (&/get$ "locals") (&/get$ "mappings") (&/|contains? ident) not) - (->> % (&/get$ "closure") (&/get$ "mappings") (&/|contains? ident) not)) - [inner outer] (split-with no-binding? stack*)] - (if (empty? outer) - (if-let [global (->> state (&/get$ "global-env") (&/|get ident))] - (return* state (&/|list global)) - (fail* (str "[Analyser Error] Unresolved identifier: " ident))) - (let [in-stack (cons top inner) - scopes (rest (reductions #(cons (&/get$ "name" %2) %1) (map #(&/get$ "name" %) outer) (reverse in-stack))) - _ (prn 'in-stack module-name ident (map #(&/get$ "name" %) in-stack) scopes) - [=local inner*] (reduce (fn [[register new-inner] [frame in-scope]] - (let [[register* frame*] (&&lambda/close-over (cons module-name (reverse in-scope)) ident register frame)] - [register* (cons frame* new-inner)])) - [(or (->> outer &/|head (&/get$ "locals") (&/get$ "mappings") (&/|get ident)) - (->> outer &/|head (&/get$ "closure") (&/get$ "mappings") (&/|get ident))) - '()] - (map vector (reverse in-stack) scopes) - )] - (return* (&/set$ "local-envs" (&/|concat inner* outer) state) (&/|list =local))) - )) + (prn 'module-name module-name) + (prn '(&/get$ "local-envs" state) (&/get$ "local-envs" state)) + (prn '(&/->seq (&/get$ "local-envs" state)) (&/->seq (&/get$ "local-envs" state))) + (println (&/show-state state)) + (let [stack (&/get$ "local-envs" state)] + (matchv ::M/objects [(&/get$ "local-envs" state)] + [["Nil" _]] + (fail* (str "[Analyser Error] Unresolved identifier: " ident)) + + [["Cons" [top stack*]]] + (if-let [=bound (or (->> stack &/|head (&/get$ "locals") (&/get$ "mappings") (&/|get ident)) + (->> stack &/|head (&/get$ "closure") (&/get$ "mappings") (&/|get ident)))] + (return* state (&/|list =bound)) + (|let [no-binding? #(and (->> % (&/get$ "locals") (&/get$ "mappings") (&/|contains? ident) not) + (->> % (&/get$ "closure") (&/get$ "mappings") (&/|contains? ident) not)) + [inner outer] (&/|split-with no-binding? stack*)] + (matchv ::M/objects [outer] + [["Nil" _]] + (if-let [global (->> state (&/get$ "global-env") &/from-some (&/get$ "locals") (&/get$ "mappings") (&/|get ident))] + (return* state (&/|list global)) + (fail* (str "[Analyser Error] Unresolved identifier: " ident))) + + [["Cons" [top-outer _]]] + (let [in-stack (&/|cons top inner) + scopes (&/|tail (&/folds #(&/|cons (&/get$ "name" %2) %1) + (&/|map #(&/get$ "name" %) outer) + (&/|reverse in-stack))) + _ (prn 'in-stack module-name ident (&/->seq (&/|map #(&/get$ "name" %) in-stack)) scopes) + [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] + (|let [[register new-inner] register+new-inner + [frame in-scope] frame+in-scope + [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ "locals") (&/get$ "mappings") (&/|get ident)) + (->> top-outer (&/get$ "closure") (&/get$ "mappings") (&/|get ident))) + (&/|list)) + (&/zip2 (&/|reverse in-stack) scopes))] + (return* (&/set$ "local-envs" (&/|++ inner* outer) state) (&/|list =local))) + ))) )) ))) @@ -72,17 +88,18 @@ (exec [=args (&/flat-map% analyse ?args) =fn-type (&&/expr-type =fn) =apply+=apply-type (&/fold (fn [[=fn =fn-type] =input] - (exec [=input-type (&&/expr-type =input) - =output-type (&type/apply-lambda =fn-type =input-type)] - (return [(&/V "apply" (&/T =fn =input)) =output-type]))) - [=fn =fn-type] - =args) + (exec [=input-type (&&/expr-type =input) + =output-type (&type/apply-lambda =fn-type =input-type)] + (return [(&/V "apply" (&/T =fn =input)) =output-type]))) + [=fn =fn-type] + =args) :let [[=apply =apply-type] (matchv ::M/objects [=apply+=apply-type] [[=apply =apply-type]] [=apply =apply-type])]] (return (&/|list (&/V "Expression" (&/T =apply =apply-type)))))) (defn analyse-apply [analyse =fn ?args] + (prn 'analyse-apply (aget =fn 0)) (exec [loader &/loader] (matchv ::M/objects [=fn] [["Expression" [=fn-form =fn-type]]] @@ -90,7 +107,7 @@ [["global" [?module ?name]]] (exec [macro? (&&def/macro? ?module ?name)] (if macro? - (let [macro-class (&host/location (list ?module ?name))] + (let [macro-class (&host/location (&/|list ?module ?name))] (exec [macro-expansion (¯o/expand loader macro-class ?args) output (&/flat-map% analyse macro-expansion)] (return output))) @@ -105,24 +122,24 @@ (defn analyse-case [analyse ?value ?branches] ;; (prn 'analyse-case ?value ?branches) - (exec [:let [num-branches (count ?branches)] + (exec [:let [num-branches (&/|length ?branches)] _ (&/assert! (and (> num-branches 0) (even? num-branches)) "[Analyser Error] Unbalanced branches in \"case'\" expression.") - :let [branches (partition 2 ?branches) - locals-per-branch (map (comp &&case/locals first) branches) - max-locals (reduce max 0 (map count locals-per-branch))] + :let [branches (&/|as-pairs ?branches) + locals-per-branch (&/|map (comp &&case/locals &/|first) branches) + max-locals (&/fold max 0 (&/|map &/|length locals-per-branch))] ;; :let [_ (prn '[branches locals-per-branch max-locals] [branches locals-per-branch max-locals])] base-register &&env/next-local-idx ;; :let [_ (prn 'base-register base-register)] =value (&&/analyse-1 analyse ?value) ;; :let [_ (prn '=value =value)] =bodies (&/map% (partial &&case/analyse-branch analyse max-locals) - (map vector locals-per-branch (map second branches))) + (&/zip2 locals-per-branch (&/|map &/|second branches))) ;; :let [_ (prn '=bodies =bodies)] ;; :let [_ (prn 'analyse-case/=bodies =bodies)] =body-types (&/map% &&/expr-type =bodies) :let [=case-type (&/fold &type/merge (&/|table) =body-types)] - :let [=branches (map vector (map first branches) =bodies)]] + :let [=branches (&/zip2 (&/|map &/|first branches) =bodies)]] (return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value base-register max-locals =branches)) =case-type)))))) (defn analyse-lambda [analyse ?self ?arg ?body] diff --git a/src/lux/base.clj b/src/lux/base.clj index 0706a563b..74b1a6d9e 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -30,7 +30,8 @@ (loop [idx 0] (if (< idx size) (if (= slot (aget record idx)) - (aset record (+ 1 idx) value) + (doto record + (aset (+ 1 idx) value)) (recur (+ 2 idx))) (assert false))))) @@ -45,6 +46,14 @@ (defn return* [state value] (V "Right" (T state value))) +(defmacro |let [bindings body] + (reduce (fn [inner [left right]] + `(matchv ::M/objects [~right] + [~left] + ~inner)) + body + (reverse (partition 2 bindings)))) + (defmacro |list [& elems] (reduce (fn [tail head] `(V "Cons" (T ~head ~tail))) @@ -58,13 +67,14 @@ (partition 2 elems))) (defn |get [slot table] + (prn '|get slot (aget table 0)) (matchv ::M/objects [table] [["Nil" _]] - (V "Left" (str "Not found: " slot)) + nil [["Cons" [[k v] table*]]] (if (= k slot) - (V "Right" v) + v (|get slot table*)))) (defn |put [slot value table] @@ -78,6 +88,7 @@ (V "Cons" (T (T k v) (|put slot value table*)))))) (defn |merge [table1 table2] + (prn '|merge (aget table1 0) (aget table2 0)) (matchv ::M/objects [table2] [["Nil" _]] table1 @@ -103,6 +114,14 @@ [["Cons" [x _]]] x)) +(defn |tail [xs] + (matchv ::M/objects [xs] + [["Nil" _]] + (assert false) + + [["Cons" [_ xs*]]] + xs*)) + ;; [Resources/Monads] (defn fail [message] (fn [_] @@ -113,8 +132,10 @@ (V "Right" (T state value)))) (defn bind [m-value step] + ;; (prn 'bind m-value step) (fn [state] (let [inputs (m-value state)] + ;; (prn 'bind/inputs (aget inputs 0)) (matchv ::M/objects [inputs] [["Right" [?state ?datum]]] ((step ?datum) ?state) @@ -146,13 +167,14 @@ (defn |cons [head tail] (V "Cons" (T head tail))) -(defn |concat [xs ys] +(defn |++ [xs ys] + (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0))) (matchv ::M/objects [xs] [["Nil" _]] ys [["Cons" [x xs*]]] - (V "Cons" (T x (|concat xs* ys))))) + (V "Cons" (T x (|++ xs* ys))))) (defn |map [f xs] (matchv ::M/objects [xs] @@ -168,7 +190,18 @@ xs [["Cons" [x xs*]]] - (|concat (f x) (flat-map f xs*)))) + (|++ (f x) (flat-map f xs*)))) + +(defn |split-with [p xs] + (matchv ::M/objects [xs] + [["Nil" _]] + (T xs xs) + + [["Cons" [x xs*]]] + (if (p x) + (|let [[pre post] (|split-with p xs*)] + (T (|cons x pre) post)) + (T (V "Nil" nil) xs)))) (defn |contains? [k table] (matchv ::M/objects [table] @@ -187,9 +220,33 @@ [["Cons" [x xs*]]] (fold f (f init x) xs*))) +(defn folds [f init xs] + (matchv ::M/objects [xs] + [["Nil" _]] + (|list init) + + [["Cons" [x xs*]]] + (|cons init (folds f (f init x) xs*)))) + (defn |length [xs] + (prn '|length (aget xs 0)) (fold (fn [acc _] (inc acc)) 0 xs)) +(let [|range* (fn |range* [from to] + (if (< from to) + (V "Cons" (T from (|range* (inc from) to))) + (V "Nil" nil)))] + (defn |range [n] + (|range* 0 n))) + +(defn |first [pair] + (|let [[_1 _2] pair] + _1)) + +(defn |second [pair] + (|let [[_1 _2] pair] + _2)) + (defn zip2 [xs ys] (matchv ::M/objects [xs ys] [["Cons" [x xs*]] ["Cons" [y ys*]]] @@ -217,28 +274,19 @@ [["Cons" [x xs*]]] (V "Cons" (T x (V "Cons" (T sep (|interpose sep xs*))))))) -(let [cons% (fn [head tail] - (V "Cons" (T head tail))) - ++% (fn ++% [xs ys] - (matchv ::M/objects [xs] - [["Nil" _]] - ys - - [["Cons" [x xs*]]] - (V "Cons" (T x (++% xs* ys)))))] - (do-template [<name> <joiner>] - (defn <name> [f xs] - (matchv ::M/objects [xs] - [["Nil" _]] - (return xs) - - [["Cons" [x xs*]]] - (exec [y (f x) - ys (<name> f xs*)] - (return (<joiner> y ys))))) - - map% cons% - flat-map% ++%)) +(do-template [<name> <joiner>] + (defn <name> [f xs] + (matchv ::M/objects [xs] + [["Nil" _]] + (return xs) + + [["Cons" [x xs*]]] + (exec [y (f x) + ys (<name> f xs*)] + (return (<joiner> y ys))))) + + map% |cons + flat-map% |++) (defn |as-pairs [xs] (matchv ::M/objects [xs] @@ -388,7 +436,7 @@ "locals" +init-bindings+ "closure" +init-bindings+)) -(defn init-state [] +(defn init-state [_] (R "source" (V "None" nil) "modules" (|list) "global-env" (V "None" nil) @@ -398,18 +446,54 @@ "loader" (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.) "eval-ctor" 0)) +(defn from-some [some] + (matchv ::M/objects [some] + [["Some" datum]] + datum + + [_] + (assert false))) + +(defn show-state [state] + (let [source (get$ "source" state) + modules (get$ "modules" state) + global-env (get$ "global-env" state) + local-envs (get$ "local-envs" state) + types (get$ "types" state) + writer (get$ "writer" state) + loader (get$ "loader" state) + eval-ctor (get$ "eval-ctor" state)] + (str "{" + (->> (for [slot ["source", "modules", "global-env", "local-envs", "types", "writer", "loader", "eval-ctor"] + :let [value (get$ slot state)]] + (str "#" slot " " (case slot + "source" "???" + "modules" "???" + "global-env" "???" + "local-envs" (|length value) + "types" "???" + "writer" "???" + "loader" "???" + "eval-ctor" value))) + (interpose " ") + (reduce str "")) + "}"))) + (def get-eval-ctor (fn [state] (return* (update$ "eval-ctor" inc state) (get$ "eval-ctor" state)))) (def get-writer (fn [state] - (matchv ::M/objects [(get$ "writer" state)] - [["Some" datum]] - (return* state datum) + (let [writer* (get$ "writer" state)] + (prn 'get-writer (class writer*)) + (prn 'get-writer (aget writer* 0)) + (matchv ::M/objects [writer*] + [["Some" datum]] + (return* state datum) - [_] - (fail* "Writer hasn't been set.")))) + [_] + (fail* "Writer hasn't been set."))))) (def get-top-local-env (fn [state] @@ -417,12 +501,32 @@ (def get-current-module-env (fn [state] - (matchv ::M/objects [(get$ "global-env" state)] - [["Some" datum]] - (return* state datum) + (let [global-env* (get$ "global-env" state)] + (prn 'get-current-module-env (aget global-env* 0)) + (matchv ::M/objects [global-env*] + [["Some" datum]] + (return* state datum) - [_] - (fail* "Module hasn't been set.")))) + [_] + (fail* "Module hasn't been set."))))) + +(defn ->seq [xs] + (matchv ::M/objects [xs] + [["Nil" _]] + (list) + + [["Cons" [x xs*]]] + (cons x (->seq xs*)))) + +(defn ->list [seq] + (if (empty? seq) + (|list) + (|cons (first seq) (->list (rest seq))))) + +(defn |repeat [n x] + (if (> n 0) + (|cons x (|repeat (dec n) x)) + (|list))) (def get-module-name (exec [module get-current-module-env] @@ -430,36 +534,45 @@ (defn ^:private with-scope [name body] (fn [state] - (let [output (body (update$ "local-envs" #(conj % (env name)) state))] + (let [output (body (update$ "local-envs" #(|cons (env name) %) state))] (matchv ::M/objects [output] [["Right" [state* datum]]] - (return* (update$ "local-envs" rest state*) datum) + (return* (update$ "local-envs" |tail state*) datum) [_] output)))) (defn with-closure [body] - (exec [[local? closure-name] (try-all% (list (exec [top get-top-local-env] - (return [true (->> top (get$ "inner-closures") str)])) - (exec [global get-current-module-env] - (return [false (->> global (get$ "inner-closures") str)]))))] - (fn [state] - (let [body* (with-scope closure-name - body)] - (body* (if local? - (update$ "local-envs" #(cons (update$ "inner-closures" inc (first %)) - (rest %)) - state) - (update$ "global-env" #(update$ "inner-closures" inc %) state))))))) + (exec [closure-info (try-all% (|list (exec [top get-top-local-env] + (return (T true (->> top (get$ "inner-closures") str)))) + (exec [global get-current-module-env] + (return (T false (->> global (get$ "inner-closures") str))))))] + (matchv ::M/objects [closure-info] + [[local? closure-name]] + (fn [state] + (let [body* (with-scope closure-name + body)] + (body* (if local? + (update$ "local-envs" #(|cons (update$ "inner-closures" inc (|head %)) + (|tail %)) + state) + (update$ "global-env" #(matchv ::M/objects [%] + [["Some" global-env]] + (V "Some" (update$ "inner-closures" inc global-env)) + + [_] + %) + state))))) + ))) (def get-scope-name (exec [module-name get-module-name] (fn [state] - (return* state (->> state (get$ "local-envs") (map #(get$ "name" %)) reverse (cons module-name)))))) + (return* state (->> state (get$ "local-envs") (|map #(get$ "name" %)) |reverse (|cons module-name)))))) (defn with-writer [writer body] (fn [state] - (let [output (body (set$ "writer" writer state))] + (let [output (body (set$ "writer" (V "Some" writer) state))] (matchv ::M/objects [output] [["Right" [?state ?value]]] (return* (set$ "writer" (get$ "writer" state) ?state) ?value) @@ -490,7 +603,7 @@ [["Tag" ?tag]] (str "#" ?tag) - [["Ident" ?ident]] + [["Symbol" ?ident]] ?ident [["Tuple" ?elems]] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index fd60537e5..1489cceb2 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -28,287 +28,288 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - ;; (prn 'compile-expression syntax) + (prn 'compile-expression (aget syntax 0)) (matchv ::M/objects [syntax] - [["Expression" ?form ?type]] - (matchv ::M/objects [?form] - [["bool" ?value]] - (&&lux/compile-bool compile-expression ?type ?value) - - [["int" ?value]] - (&&lux/compile-int compile-expression ?type ?value) - - [["real" ?value]] - (&&lux/compile-real compile-expression ?type ?value) - - [["char" ?value]] - (&&lux/compile-char compile-expression ?type ?value) - - [["text" ?value]] - (&&lux/compile-text compile-expression ?type ?value) - - [["tuple" ?elems]] - (&&lux/compile-tuple compile-expression ?type ?elems) - - [["record" ?elems]] - (&&lux/compile-record compile-expression ?type ?elems) - - [["local" ?idx]] - (&&lux/compile-local compile-expression ?type ?idx) - - [["captured" [?scope ?captured-id ?source]]] - (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - - [["global" [?owner-class ?name]]] - (&&lux/compile-global compile-expression ?type ?owner-class ?name) - - [["call" [?fn ?args]]] - (&&lux/compile-call compile-expression ?type ?fn ?args) - - [["variant" [?tag ?members]]] - (&&lux/compile-variant compile-expression ?type ?tag ?members) - - [["case" [?variant ?base-register ?num-registers ?branches]]] - (&&case/compile-case compile-expression ?type ?variant ?base-register ?num-registers ?branches) - - [["lambda" [?scope ?env ?args ?body]]] - (&&lambda/compile-lambda compile-expression ?scope ?env ?args ?body) - - [["get" [?slot ?record]]] - (&&lux/compile-get compile-expression ?type ?slot ?record) - - [["set" [?slot ?value ?record]]] - (&&lux/compile-set compile-expression ?type ?slot ?value ?record) - - ;; Integer arithmetic - [["jvm-iadd" [?x ?y]]] - (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - - [["jvm-isub" [?x ?y]]] - (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - - [["jvm-imul" [?x ?y]]] - (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - - [["jvm-idiv" [?x ?y]]] - (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - - [["jvm-irem" [?x ?y]]] - (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - - [["jvm-ieq" [?x ?y]]] - (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - - [["jvm-ilt" [?x ?y]]] - (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - - [["jvm-igt" [?x ?y]]] - (&&host/compile-jvm-igt compile-expression ?type ?x ?y) - - ;; Long arithmetic - [["jvm-ladd" [?x ?y]]] - (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - - [["jvm-lsub" [?x ?y]]] - (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - - [["jvm-lmul" [?x ?y]]] - (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - - [["jvm-ldiv" [?x ?y]]] - (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - - [["jvm-lrem" [?x ?y]]] - (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - - [["jvm-leq" [?x ?y]]] - (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - - [["jvm-llt" [?x ?y]]] - (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - - [["jvm-lgt" [?x ?y]]] - (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) - - ;; Float arithmetic - [["jvm-fadd" [?x ?y]]] - (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - - [["jvm-fsub" [?x ?y]]] - (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - - [["jvm-fmul" [?x ?y]]] - (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - - [["jvm-fdiv" [?x ?y]]] - (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - - [["jvm-frem" [?x ?y]]] - (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - - [["jvm-feq" [?x ?y]]] - (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - - [["jvm-flt" [?x ?y]]] - (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - - [["jvm-fgt" [?x ?y]]] - (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) - - ;; Double arithmetic - [["jvm-dadd" [?x ?y]]] - (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - - [["jvm-dsub" [?x ?y]]] - (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - - [["jvm-dmul" [?x ?y]]] - (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - - [["jvm-ddiv" [?x ?y]]] - (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - - [["jvm-drem" [?x ?y]]] - (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - - [["jvm-deq" [?x ?y]]] - (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - - [["jvm-dlt" [?x ?y]]] - (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - - [["jvm-dgt" [?x ?y]]] - (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - - [["exec" ?exprs]] - (&&host/compile-exec compile-expression ?type ?exprs) - - [["jvm-null" _]] - (&&host/compile-jvm-null compile-expression ?type) - - [["jvm-null?" ?object]] - (&&host/compile-jvm-null? compile-expression ?type ?object) - - [["jvm-new" [?class ?classes ?args]]] - (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - - [["jvm-getstatic" [?class ?field]]] - (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - - [["jvm-getfield" [?class ?field ?object]]] - (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - - [["jvm-putstatic" [?class ?field ?value]]] - (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - - [["jvm-putfield" [?class ?field ?object ?value]]] - (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - - [["jvm-invokestatic" [?class ?method ?classes ?args]]] - (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) + [["Expression" [?form ?type]]] + (do (prn 'compile-expression2 (aget ?form 0)) + (matchv ::M/objects [?form] + [["bool" ?value]] + (&&lux/compile-bool compile-expression ?type ?value) + + [["int" ?value]] + (&&lux/compile-int compile-expression ?type ?value) + + [["real" ?value]] + (&&lux/compile-real compile-expression ?type ?value) + + [["char" ?value]] + (&&lux/compile-char compile-expression ?type ?value) + + [["text" ?value]] + (&&lux/compile-text compile-expression ?type ?value) + + [["tuple" ?elems]] + (&&lux/compile-tuple compile-expression ?type ?elems) + + [["record" ?elems]] + (&&lux/compile-record compile-expression ?type ?elems) + + [["local" ?idx]] + (&&lux/compile-local compile-expression ?type ?idx) + + [["captured" [?scope ?captured-id ?source]]] + (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) + + [["global" [?owner-class ?name]]] + (&&lux/compile-global compile-expression ?type ?owner-class ?name) + + [["call" [?fn ?args]]] + (&&lux/compile-call compile-expression ?type ?fn ?args) + + [["variant" [?tag ?members]]] + (&&lux/compile-variant compile-expression ?type ?tag ?members) + + [["case" [?variant ?base-register ?num-registers ?branches]]] + (&&case/compile-case compile-expression ?type ?variant ?base-register ?num-registers ?branches) + + [["lambda" [?scope ?env ?args ?body]]] + (&&lambda/compile-lambda compile-expression ?scope ?env ?args ?body) + + [["get" [?slot ?record]]] + (&&lux/compile-get compile-expression ?type ?slot ?record) + + [["set" [?slot ?value ?record]]] + (&&lux/compile-set compile-expression ?type ?slot ?value ?record) + + ;; Integer arithmetic + [["jvm-iadd" [?x ?y]]] + (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) + + [["jvm-isub" [?x ?y]]] + (&&host/compile-jvm-isub compile-expression ?type ?x ?y) + + [["jvm-imul" [?x ?y]]] + (&&host/compile-jvm-imul compile-expression ?type ?x ?y) + + [["jvm-idiv" [?x ?y]]] + (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) + + [["jvm-irem" [?x ?y]]] + (&&host/compile-jvm-irem compile-expression ?type ?x ?y) + + [["jvm-ieq" [?x ?y]]] + (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) + + [["jvm-ilt" [?x ?y]]] + (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) + + [["jvm-igt" [?x ?y]]] + (&&host/compile-jvm-igt compile-expression ?type ?x ?y) + + ;; Long arithmetic + [["jvm-ladd" [?x ?y]]] + (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) + + [["jvm-lsub" [?x ?y]]] + (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) + + [["jvm-lmul" [?x ?y]]] + (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) + + [["jvm-ldiv" [?x ?y]]] + (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) + + [["jvm-lrem" [?x ?y]]] + (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) + + [["jvm-leq" [?x ?y]]] + (&&host/compile-jvm-leq compile-expression ?type ?x ?y) + + [["jvm-llt" [?x ?y]]] + (&&host/compile-jvm-llt compile-expression ?type ?x ?y) + + [["jvm-lgt" [?x ?y]]] + (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) + + ;; Float arithmetic + [["jvm-fadd" [?x ?y]]] + (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) + + [["jvm-fsub" [?x ?y]]] + (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) + + [["jvm-fmul" [?x ?y]]] + (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) + + [["jvm-fdiv" [?x ?y]]] + (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) + + [["jvm-frem" [?x ?y]]] + (&&host/compile-jvm-frem compile-expression ?type ?x ?y) + + [["jvm-feq" [?x ?y]]] + (&&host/compile-jvm-feq compile-expression ?type ?x ?y) + + [["jvm-flt" [?x ?y]]] + (&&host/compile-jvm-flt compile-expression ?type ?x ?y) + + [["jvm-fgt" [?x ?y]]] + (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) + + ;; Double arithmetic + [["jvm-dadd" [?x ?y]]] + (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) + + [["jvm-dsub" [?x ?y]]] + (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) + + [["jvm-dmul" [?x ?y]]] + (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) + + [["jvm-ddiv" [?x ?y]]] + (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) + + [["jvm-drem" [?x ?y]]] + (&&host/compile-jvm-drem compile-expression ?type ?x ?y) + + [["jvm-deq" [?x ?y]]] + (&&host/compile-jvm-deq compile-expression ?type ?x ?y) + + [["jvm-dlt" [?x ?y]]] + (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) + + [["jvm-dgt" [?x ?y]]] + (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) + + [["exec" ?exprs]] + (&&host/compile-exec compile-expression ?type ?exprs) + + [["jvm-null" _]] + (&&host/compile-jvm-null compile-expression ?type) + + [["jvm-null?" ?object]] + (&&host/compile-jvm-null? compile-expression ?type ?object) + + [["jvm-new" [?class ?classes ?args]]] + (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) + + [["jvm-getstatic" [?class ?field]]] + (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) + + [["jvm-getfield" [?class ?field ?object]]] + (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) + + [["jvm-putstatic" [?class ?field ?value]]] + (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) + + [["jvm-putfield" [?class ?field ?object ?value]]] + (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) + + [["jvm-invokestatic" [?class ?method ?classes ?args]]] + (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) + + [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) + [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - - [["jvm-new-array" [?class ?length]]] - (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) + [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) + + [["jvm-new-array" [?class ?length]]] + (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) - [["jvm-aastore" [?array ?idx ?elem]]] - (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) + [["jvm-aastore" [?array ?idx ?elem]]] + (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) - [["jvm-aaload" [?array ?idx]]] - (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) + [["jvm-aaload" [?array ?idx]]] + (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) - [["jvm-try" [?body ?catches ?finally]]] - (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) + [["jvm-try" [?body ?catches ?finally]]] + (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) - [["jvm-throw" ?ex]] - (&&host/compile-jvm-throw compile-expression ?type ?ex) + [["jvm-throw" ?ex]] + (&&host/compile-jvm-throw compile-expression ?type ?ex) - [["jvm-monitorenter" ?monitor]] - (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) + [["jvm-monitorenter" ?monitor]] + (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) - [["jvm-monitorexit" ?monitor]] - (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) + [["jvm-monitorexit" ?monitor]] + (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) - [["jvm-d2f" ?value]] - (&&host/compile-jvm-d2f compile-expression ?type ?value) + [["jvm-d2f" ?value]] + (&&host/compile-jvm-d2f compile-expression ?type ?value) - [["jvm-d2i" ?value]] - (&&host/compile-jvm-d2i compile-expression ?type ?value) + [["jvm-d2i" ?value]] + (&&host/compile-jvm-d2i compile-expression ?type ?value) - [["jvm-d2l" ?value]] - (&&host/compile-jvm-d2l compile-expression ?type ?value) - - [["jvm-f2d" ?value]] - (&&host/compile-jvm-f2d compile-expression ?type ?value) + [["jvm-d2l" ?value]] + (&&host/compile-jvm-d2l compile-expression ?type ?value) + + [["jvm-f2d" ?value]] + (&&host/compile-jvm-f2d compile-expression ?type ?value) - [["jvm-f2i" ?value]] - (&&host/compile-jvm-f2i compile-expression ?type ?value) + [["jvm-f2i" ?value]] + (&&host/compile-jvm-f2i compile-expression ?type ?value) - [["jvm-f2l" ?value]] - (&&host/compile-jvm-f2l compile-expression ?type ?value) - - [["jvm-i2b" ?value]] - (&&host/compile-jvm-i2b compile-expression ?type ?value) + [["jvm-f2l" ?value]] + (&&host/compile-jvm-f2l compile-expression ?type ?value) + + [["jvm-i2b" ?value]] + (&&host/compile-jvm-i2b compile-expression ?type ?value) - [["jvm-i2c" ?value]] - (&&host/compile-jvm-i2c compile-expression ?type ?value) + [["jvm-i2c" ?value]] + (&&host/compile-jvm-i2c compile-expression ?type ?value) - [["jvm-i2d" ?value]] - (&&host/compile-jvm-i2d compile-expression ?type ?value) + [["jvm-i2d" ?value]] + (&&host/compile-jvm-i2d compile-expression ?type ?value) - [["jvm-i2f" ?value]] - (&&host/compile-jvm-i2f compile-expression ?type ?value) + [["jvm-i2f" ?value]] + (&&host/compile-jvm-i2f compile-expression ?type ?value) - [["jvm-i2l" ?value]] - (&&host/compile-jvm-i2l compile-expression ?type ?value) + [["jvm-i2l" ?value]] + (&&host/compile-jvm-i2l compile-expression ?type ?value) - [["jvm-i2s" ?value]] - (&&host/compile-jvm-i2s compile-expression ?type ?value) + [["jvm-i2s" ?value]] + (&&host/compile-jvm-i2s compile-expression ?type ?value) - [["jvm-l2d" ?value]] - (&&host/compile-jvm-l2d compile-expression ?type ?value) + [["jvm-l2d" ?value]] + (&&host/compile-jvm-l2d compile-expression ?type ?value) - [["jvm-l2f" ?value]] - (&&host/compile-jvm-l2f compile-expression ?type ?value) + [["jvm-l2f" ?value]] + (&&host/compile-jvm-l2f compile-expression ?type ?value) - [["jvm-l2i" ?value]] - (&&host/compile-jvm-l2i compile-expression ?type ?value) + [["jvm-l2i" ?value]] + (&&host/compile-jvm-l2i compile-expression ?type ?value) - [["jvm-iand" [?x ?y]]] - (&&host/compile-jvm-iand compile-expression ?type ?x ?y) + [["jvm-iand" [?x ?y]]] + (&&host/compile-jvm-iand compile-expression ?type ?x ?y) - [["jvm-ior" [?x ?y]]] - (&&host/compile-jvm-ior compile-expression ?type ?x ?y) + [["jvm-ior" [?x ?y]]] + (&&host/compile-jvm-ior compile-expression ?type ?x ?y) - [["jvm-land" [?x ?y]]] - (&&host/compile-jvm-land compile-expression ?type ?x ?y) + [["jvm-land" [?x ?y]]] + (&&host/compile-jvm-land compile-expression ?type ?x ?y) - [["jvm-lor" [?x ?y]]] - (&&host/compile-jvm-lor compile-expression ?type ?x ?y) + [["jvm-lor" [?x ?y]]] + (&&host/compile-jvm-lor compile-expression ?type ?x ?y) - [["jvm-lxor" [?x ?y]]] - (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) + [["jvm-lxor" [?x ?y]]] + (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) - [["jvm-lshl" [?x ?y]]] - (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) + [["jvm-lshl" [?x ?y]]] + (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) - [["jvm-lshr" [?x ?y]]] - (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) + [["jvm-lshr" [?x ?y]]] + (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) - [["jvm-lushr" [?x ?y]]] - (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) + [["jvm-lushr" [?x ?y]]] + (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) - [["jvm-program" ?body]] - (&&host/compile-jvm-program compile-expression ?type ?body) - ) + [["jvm-program" ?body]] + (&&host/compile-jvm-program compile-expression ?type ?body) + )) [_] (fail "[Compiler Error] Can't compile statements as expressions."))) @@ -317,15 +318,16 @@ ;; (prn 'compile-statement syntax) (matchv ::M/objects [syntax] [["Statement" ?form]] - (matchv ::M/objects [?form] - [["def" ?name ?body]] - (&&lux/compile-def compile-expression ?name ?body) - - [["jvm-interface" ?package ?name ?methods]] - (&&host/compile-jvm-interface compile-expression ?package ?name ?methods) + (do (prn 'compile-statement (aget syntax 0) (aget ?form 0)) + (matchv ::M/objects [?form] + [["def" [?name ?body]]] + (&&lux/compile-def compile-expression ?name ?body) + + [["jvm-interface" [?package ?name ?methods]]] + (&&host/compile-jvm-interface compile-expression ?package ?name ?methods) - [["jvm-class" ?package ?name ?super-class ?fields ?methods]] - (&&host/compile-jvm-class compile-expression ?package ?name ?super-class ?fields ?methods)) + [["jvm-class" [?package ?name ?super-class ?fields ?methods]]] + (&&host/compile-jvm-class compile-expression ?package ?name ?super-class ?fields ?methods))) [_] (fail "[Compiler Error] Can't compile expressions as top-level forms."))) @@ -361,7 +363,7 @@ (let [compiler-step (exec [analysis+ (&optimizer/optimize eval!) ;; :let [_ (prn 'analysis+ analysis+)] ] - (&/flat-map% compile-statement analysis+))] + (&/map% compile-statement analysis+))] (defn ^:private compile-module [name] (fn [state] (if (->> state (&/get$ "modules") (&/|contains? name)) @@ -369,13 +371,14 @@ (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (&host/->class name) nil "java/lang/Object" nil))] - (matchv ::M/objects [(&/run-state (&/exhaust% compiler-step) (-> state - (&/set$ "source" (slurp (str "source/" name ".lux"))) - (&/set$ "global-env" (&/env name)) - (&/set$ "writer" =class) - (&/update$ "modules" #(&/|put name &a-def/init-module %))))] + (matchv ::M/objects [(&/run-state (&/exhaust% compiler-step) (->> state + (&/set$ "source" (slurp (str "source/" name ".lux"))) + (&/set$ "global-env" (&/V "Some" (&/env name))) + (&/set$ "writer" (&/V "Some" =class)) + (&/update$ "modules" #(&/|put name &a-def/init-module %))))] [["Right" [?state ?vals]]] (do (.visitEnd =class) + (prn 'compile-module 'DONE name) ;; (prn 'compile-module/?vals ?vals) (&/run-state (&&/save-class! name (.toByteArray =class)) ?state)) @@ -385,7 +388,7 @@ ;; [Resources] (defn compile-all [modules] (.mkdir (java.io.File. "output")) - (matchv ::M/objects [(&/run-state (&/map% compile-module modules) (&/init-state))] + (matchv ::M/objects [(&/run-state (&/map% compile-module modules) (&/init-state nil))] [["Right" [?state _]]] (println (str "Compilation complete! " (pr-str modules))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index f09008ca8..09fc811d8 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -32,97 +32,104 @@ (return nil))) (defn total-locals [expr] + (prn 'total-locals1 (aget expr 0)) (matchv ::M/objects [expr] - [["case" [?variant ?base-register ?num-registers ?branches]]] - (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches))) - - [["tuple" ?members]] - (&/fold max 0 (&/|map total-locals ?members)) + [["Expression" [?struct ?type]]] + (do (prn 'total-locals2 (aget ?struct 0)) + (matchv ::M/objects [?struct] + [["case" [?variant ?base-register ?num-registers ?branches]]] + (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches))) + + [["tuple" ?members]] + (&/fold max 0 (&/|map total-locals ?members)) - [["variant" ?tag ?value]] - (total-locals ?value) + [["variant" [?tag ?value]]] + (total-locals ?value) - [["call" [?fn ?args]]] - (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args))) - - [["jvm-iadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-isub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-imul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-idiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-irem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ladd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ldiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lrem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fdiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-frem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ddiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-drem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + [["call" [?fn ?args]]] + (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args))) + + [["jvm-iadd" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-isub" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-imul" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-idiv" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-irem" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-ladd" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-lsub" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-lmul" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-ldiv" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-lrem" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-fadd" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-fsub" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-fmul" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-fdiv" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-frem" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-dadd" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-dsub" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-dmul" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-ddiv" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-drem" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - [["exec" ?exprs]] - (&/fold max 0 (&/|map total-locals ?exprs)) + [["exec" ?exprs]] + (&/fold max 0 (&/|map total-locals ?exprs)) - [["jvm-new" [?class ?classes ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) + [["jvm-new" [?class ?classes ?args]]] + (&/fold max 0 (&/|map total-locals ?args)) - [["jvm-invokestatic" [?class ?method ?classes ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) + [["jvm-invokestatic" [?class ?method ?classes ?args]]] + (&/fold max 0 (&/|map total-locals ?args)) - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) + [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] + (&/fold max 0 (&/|map total-locals ?args)) - [["jvm-aastore" [?array ?idx ?elem]]] - (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem))) + [["jvm-aastore" [?array ?idx ?elem]]] + (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem))) - [["jvm-aaload" [?array ?idx]]] - (total-locals ?array) - - ;; [_] - ;; 0 - )) + [["jvm-aaload" [?array ?idx]]] + (total-locals ?array) + + [["lambda" _]] + 0 + + ;; [_] + ;; 0 + )))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 6f9fd998a..336d0c645 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -3,7 +3,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail*]] + (lux [base :as & :refer [exec return* return fail fail* |let]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -17,51 +17,56 @@ ;; [Utils] (defn ^:private ->match [$body register token] + (prn '->match token) + (prn '->match (aget token 0)) (matchv ::M/objects [token] - [["Ident" ?name]] - [(inc register) (&/V "Pattern" (&/T $body [&/V "StoreMatch" register]))] + [["Symbol" ?name]] + (&/T (inc register) (&/V "Pattern" (&/T $body [&/V "StoreMatch" register]))) [["Bool" ?value]] - [register (&/V "Pattern" (&/T $body [&/V "BoolMatch" ?value]))] + (&/T register (&/V "Pattern" (&/T $body [&/V "BoolMatch" ?value]))) [["Int" ?value]] - [register (&/V "Pattern" (&/T $body [&/V "IntMatch" ?value]))] + (&/T register (&/V "Pattern" (&/T $body [&/V "IntMatch" ?value]))) [["Real" ?value]] - [register (&/V "Pattern" (&/T $body [&/V "RealMatch" ?value]))] + (&/T register (&/V "Pattern" (&/T $body [&/V "RealMatch" ?value]))) [["Char" ?value]] - [register (&/V "Pattern" (&/T $body [&/V "CharMatch" ?value]))] + (&/T register (&/V "Pattern" (&/T $body [&/V "CharMatch" ?value]))) [["Text" ?value]] - [register (&/V "Pattern" (&/T $body [&/V "TextMatch" ?value]))] + (&/T register (&/V "Pattern" (&/T $body [&/V "TextMatch" ?value]))) [["Tuple" ?members]] - (let [[register* =members] (&/fold (fn [[register =members] member] - (let [[register* =member] (->match $body register member)] - [register* (cons =member =members)])) - [register (list)] - ?members)] - [register* (&/V "Pattern" (&/T $body [&/V "TupleMatch" (reverse =members)]))]) + (|let [[register* =members] (&/fold (fn [[register =members] member] + (|let [[register* =member] (->match $body register member)] + (&/T register* (&/|cons =member =members)))) + (&/T register (&/|list)) + ?members)] + (&/T register* (&/V "Pattern" (&/T $body [&/V "TupleMatch" (&/|reverse =members)])))) [["Tag" ?tag]] - [register (&/V "Pattern" (&/T $body [&/V "VariantMatch" (&/T ?tag [&/V "Pattern" (&/T $body [&/V "TupleMatch" (list)])])]))] + (&/T register (&/V "Pattern" (&/T $body [&/V "VariantMatch" (&/T ?tag [&/V "Pattern" (&/T $body [&/V "TupleMatch" (list)])])]))) [["Form" ["Cons" [["Tag" ?tag] ["Cons" [?value ["Nil" _]]]]]]] - (let [[register* =value] (->match $body register ?value)] + (|let [[register* =value] (->match $body register ?value)] - [register* (&/V "Pattern" (&/T $body [&/V "VariantMatch" (&/T ?tag =value)]))]) + (&/T register* (&/V "Pattern" (&/T $body [&/V "VariantMatch" (&/T ?tag =value)])))) )) (defn ^:private process-branches [base-register branches] - (let [[_ mappings pms] (reduce (fn [[$id mappings =matches] [pattern body]] - (let [[_ =match] (->match $id base-register pattern)] - [(inc $id) (assoc mappings $id body) (cons =match =matches)])) - [0 {} (list)] - branches)] - [mappings (reverse pms)])) + (prn 'process-branches base-register branches) + (|let [[_ mappings pms] (&/fold (fn [$id+mappings+=matches pattern+body] + (|let [[$id mappings =matches] $id+mappings+=matches + [pattern body] pattern+body + [_ =match] (->match $id base-register pattern)] + (&/T (inc $id) (&/|put $id body mappings) (&/|cons =match =matches)))) + (&/T 0 (&/|table) (&/|list)) + branches)] + (&/T mappings (&/|reverse pms)))) (let [+tag-sig+ (&host/->type-signature "java.lang.String") +oclass+ (&host/->class "java.lang.Object") @@ -131,9 +136,10 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $else) (.visitLabel $next)) - (->> (doseq [[idx [_ _ member]] (map vector (range (count ?members)) ?members) - :let [$next (new Label) - $sub-else (new Label)]]))) + (->> (|let [[idx [_ _ member]] idx+member + $next (new Label) + $sub-else (new Label)]) + (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) @@ -162,16 +168,19 @@ (let [ex-class (&host/->class "java.lang.IllegalStateException")] (defn ^:private compile-pattern-matching [writer compile mappings patterns $end] - ;; (prn 'compile-pattern-matching patterns) - (let [entries (for [[?branch ?body] mappings - :let [label (new Label)]] - [[?branch label] - [label ?body]]) - mappings* (into {} (map first entries))] + (prn 'compile-pattern-matching mappings patterns $end) + (let [entries (&/|map (fn [?branch+?body] + (|let [[?branch ?body] ?branch+?body + label (new Label)] + (&/T (&/T ?branch label) + (&/T label ?body)))) + mappings) + mappings* (&/|map &/|first entries)] (doto writer - (-> (doto (compile-match ?match (get mappings* ?body) $else) + (-> (doto (compile-match ?match (&/|get ?body mappings*) $else) (.visitLabel $else)) - (->> (doseq [[_ ?body ?match :as pattern] patterns + (->> (|let [[_ ?body ?match] ?body+?match]) + (doseq [?body+?match (&/->seq patterns) :let [;; _ (prn 'compile-pattern-matching/pattern pattern) $else (new Label)]]))) (.visitInsn Opcodes/POP) @@ -179,20 +188,22 @@ (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V") (.visitInsn Opcodes/ATHROW)) - (&/map% (fn [[?label ?body]] - (exec [:let [_ (.visitLabel writer ?label)] - ret (compile ?body) - :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] - (return ret))) - (map second entries)) + (&/map% (fn [?label+?body] + (|let [[?label ?body] ?label+?body] + (exec [:let [_ (.visitLabel writer ?label)] + ret (compile ?body) + :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] + (return ret)))) + (&/|map &/|second entries)) ))) ;; [Resources] (defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches] (exec [*writer* &/get-writer :let [$end (new Label)] - _ (compile ?variant) - :let [[mappings patterns] (process-branches ?base-register ?branches)] - _ (compile-pattern-matching *writer* compile mappings patterns $end) - :let [_ (.visitLabel *writer* $end)]] - (return nil))) + _ (compile ?variant)] + (|let [[mappings patterns] (process-branches ?base-register ?branches)] + (exec [_ (compile-pattern-matching *writer* compile mappings patterns $end) + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + )) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 08a00b536..c14924efd 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -310,6 +310,7 @@ (&&/save-class! full-name (.toByteArray =class)))) (defn compile-jvm-interface [compile ?package ?name ?methods] + (prn 'compile-jvm-interface ?package ?name ?methods) (let [parent-dir (&host/->package ?package) full-name (str parent-dir "/" ?name) =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -317,10 +318,12 @@ full-name nil "java/lang/Object" nil)) _ (do (doseq [[?method ?props] ?methods :let [[?args ?return] (:type ?props) - signature (str "(" (reduce str "" (map &host/->type-signature ?args)) ")" (&host/->type-signature ?return))]] + signature (str "(" (&/fold str "" (&/|map &host/->type-signature ?args)) ")" (&host/->type-signature ?return)) + _ (prn 'signature signature)]] (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) (.visitEnd =interface) (.mkdirs (java.io.File. (str "output/" parent-dir))))] + (prn 'SAVED_CLASS full-name) (&&/save-class! full-name (.toByteArray =interface)))) (defn compile-exec [compile *type* ?exprs] diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 45a75337c..c249924ec 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -12,7 +12,8 @@ [host :as &host]) [lux.analyser.base :as &a] (lux.compiler [base :as &&]) - :reload) + ;; :reload + ) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -24,11 +25,10 @@ (def ^:private <init>-return "V") (def ^:private lambda-impl-signature - (str (reduce str "(" clo-field-sig) ")" - lambda-return-sig)) + (str "(" clo-field-sig ")" lambda-return-sig)) (defn ^:private lambda-<init>-signature [env] - (str "(" (reduce str "" (repeat (count env) clo-field-sig)) ")" + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" <init>-return)) (defn ^:private add-lambda-<init> [class class-name env] @@ -40,9 +40,9 @@ (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?captured] - [["Expression" [["captured" [_ ?captured-id ?source]] _]]]) - (doseq [[?name ?captured] env]))) + (matchv ::M/objects [?name+?captured] + [[?name ["Expression" [["captured" [_ ?captured-id ?source]] _]]]]) + (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))) @@ -77,25 +77,28 @@ (return ret)))) (defn ^:private instance-closure [compile lambda-class closed-over init-signature] + (prn 'instance-closure lambda-class closed-over init-signature) (exec [*writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] _ (->> closed-over - (sort #(matchv ::M/objects [(second %1) (second %2)] + &/->seq + (sort #(matchv ::M/objects [(&/|second %1) (&/|second %2)] [["Expression" [["captured" [_ ?cid1 _]] _]] ["Expression" [["captured" [_ ?cid2 _]] _]]] (< ?cid1 ?cid2))) - (&/map% (fn [[?name ?captured]] - (matchv ::M/objects [?captured] - [["Expression" [["captured" [_ _ ?source]] _]]] - (compile ?source))))) + &/->list + (&/map% (fn [?name+?captured] + (matchv ::M/objects [?name+?captured] + [[?name ["Expression" [["captured" [_ _ ?source]] _]]]] + (compile ?source))))) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature)]] (return nil))) ;; [Exports] (defn compile-lambda [compile ?scope ?env ?arg ?body] - (prn 'compile-lambda ?scope ?arg) + (prn 'compile-lambda ?scope (&host/location ?scope) ?arg ?env) (exec [:let [lambda-class (&host/location ?scope) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) @@ -103,10 +106,10 @@ (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?captured] - [["Expression" [["captured" [_ ?captured-id ?source]] _]]]) - (doseq [[?name ?captured] ?env - ;; :let [_ (prn '?captured ?captured)] + (matchv ::M/objects [?name+?captured] + [[?name ["Expression" [["captured" [_ ?captured-id ?source]] _]]]]) + (doseq [?name+?captured (&/->seq ?env) + ;; :let [_ (prn '?captured ?name ?captured)] ]))) (add-lambda-apply lambda-class ?env) (add-lambda-<init> lambda-class ?env) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 9ce0da213..22018808a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -4,7 +4,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return* return fail fail*]] + (lux [base :as & :refer [exec return* return fail fail* |let]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -50,40 +50,42 @@ (defn compile-tuple [compile *type* ?elems] (exec [*writer* &/get-writer - :let [num-elems (count ?elems) + :let [num-elems (&/|length ?elems) _ (doto *writer* (.visitLdcInsn (int num-elems)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] - _ (&/map% (fn [[idx elem]] - (exec [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret))) - (map vector (range num-elems) ?elems))] + _ (&/map% (fn [idx+elem] + (|let [[idx elem] idx+elem] + (exec [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret)))) + (&/zip2 (&/|range num-elems) ?elems))] (return nil))) (defn compile-record [compile *type* ?elems] (exec [*writer* &/get-writer - :let [num-elems (count ?elems) + :let [num-elems (&/|length ?elems) _ (doto *writer* (.visitLdcInsn (int (* 2 num-elems))) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] - _ (&/map% (fn [[idx [k v]]] - (exec [:let [idx* (* 2 idx) - _ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx*)) - (.visitLdcInsn k) - (.visitInsn Opcodes/AASTORE))] - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int (inc idx*))))] - ret (compile v) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret))) - (map vector (range num-elems) ?elems))] + _ (&/map% (fn [idx+kv] + (|let [[idx [k v]] idx+kv] + (exec [:let [idx* (* 2 idx) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx*)) + (.visitLdcInsn k) + (.visitInsn Opcodes/AASTORE))] + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int (inc idx*))))] + ret (compile v) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret)))) + (&/zip2 (&/|range num-elems) ?elems))] (return nil))) (defn compile-variant [compile *type* ?tag ?value] @@ -119,7 +121,7 @@ (defn compile-global [compile *type* ?owner-class ?name] (exec [*writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] (return nil))) (defn compile-call [compile *type* ?fn ?args] @@ -237,17 +239,22 @@ current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) (doto (.visitEnd))))] + :let [_ (prn 'compile-def/pre-body)] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) (exec [*writer* &/get-writer :let [_ (.visitCode *writer*)] + :let [_ (prn 'compile-def/pre-body2)] _ (compile ?body) + :let [_ (prn 'compile-def/post-body2)] :let [_ (doto *writer* (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] (return nil))) + :let [_ (prn 'compile-def/post-body)] :let [_ (.visitEnd *writer*)] + :let [_ (prn 'compile-def/_1 ?name current-class)] _ (&&/save-class! current-class (.toByteArray =class)) - :let [_ (prn 'compile-def ?name)]] + :let [_ (prn 'compile-def/_2 ?name)]] (return nil))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 0becee945..e76f6625f 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -96,10 +96,10 @@ (defn extract-jvm-param [token] (matchv ::M/objects [token] - [["Ident" ?ident]] + [["Symbol" ?ident]] (full-class-name ?ident) - [["Form" ["Cons" [["Ident" "Array"] ["Cons" [["Ident" ?inner] ["Nil" _]]]]]]] + [["Form" ["Cons" [["Symbol" "Array"] ["Cons" [["Symbol" ?inner] ["Nil" _]]]]]]] (exec [=inner (full-class-name ?inner)] (return (str "[L" (->class =inner) ";"))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 1c506950c..bebf9423e 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -75,7 +75,7 @@ ^:private lex-bool "Bool" #"^(true|false)" ^:private lex-real "Real" #"^-?(0|[1-9][0-9]*)\.[0-9]+" ^:private lex-int "Int" #"^-?(0|[1-9][0-9]*)" - ^:private lex-ident "Ident" +ident-re+) + ^:private lex-ident "Symbol" +ident-re+) (def ^:private lex-char (exec [_ (lex-prefix "#\"") diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 49a636bd6..56d8eb38f 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -12,7 +12,8 @@ token &lexer/lex] (matchv ::M/objects [token] [[<close-token> _]] - (return (&/|list (&/V <tag> (&/|concat elems)))) + (return (&/|list (&/V <tag> (&/fold &/|++ (&/|list) elems)))) + [_] (fail (str "[Parser Error] Unbalanced " <description> "."))))) @@ -23,7 +24,7 @@ (defn ^:private parse-record [parse] (exec [elems* (&/repeat% parse) token &lexer/lex - :let [elems (&/|concat elems*)]] + :let [elems (&/fold &/|++ (&/|list) elems*)]] (matchv ::M/objects [token] [["Close_Brace" _]] (fail (str "[Parser Error] Unbalanced braces.")) @@ -37,6 +38,7 @@ (def parse (exec [token &lexer/lex ;; :let [_ (prn 'parse/token token)] + ;; :let [_ (prn 'parse (aget token 0))] ] (matchv ::M/objects [token] [["White_Space" _]] @@ -60,8 +62,8 @@ [["Text" ?value]] (return (&/|list (&/V "Text" ?value))) - [["Ident" ?value]] - (return (&/|list (&/V "Ident" ?value))) + [["Symbol" ?value]] + (return (&/|list (&/V "Symbol" ?value))) [["Tag" ?value]] (return (&/|list (&/V "Tag" ?value))) @@ -69,9 +71,12 @@ [["Open_Paren" _]] (parse-form parse) - [["Open-Bracket" _]] + [["Open_Bracket" _]] (parse-tuple parse) - [["Open_Brace"]] + [["Open_Brace" _]] (parse-record parse) + + [_] + (fail "[Parser Error] Unknown lexer token.") ))) diff --git a/src/lux/type.clj b/src/lux/type.clj index a59ef19ca..927110cc6 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -9,8 +9,13 @@ (defn ^:private deref [id] (fn [state] - (if-let [type (->> state (&/get$ "types") (&/get$ "mappings") (&/|get id))] - (return* state type) + (if-let [type* (->> state (&/get$ "types") (&/get$ "mappings") (&/|get id))] + (matchv ::M/objects [type*] + [["Some" type]] + (return* state type) + + [["None" _]] + (fail* (str "Unbound type-var: " id))) (fail* (str "Unknown type-var: " id))))) (defn ^:private reset [id type] @@ -26,9 +31,9 @@ (def fresh-var (fn [state] (let [id (->> state (&/get$ "types") (&/get$ "counter"))] - (return* (&/update$ "types" #(-> % - (&/update$ "counter" inc) - (&/update$ "mappings" (fn [ms] (&/|put id (&/V "None" nil) ms)))) + (return* (&/update$ "types" #(->> % + (&/update$ "counter" inc) + (&/update$ "mappings" (fn [ms] (&/|put id (&/V "None" nil) ms)))) state) (&/V "Var" id))))) @@ -82,7 +87,7 @@ (def +list+ [::All (&/|list) "List" "a" [::Variant (&/|list ["Cons" [::Tuple (&/|list [::Bound "a"] [::App [::Bound "List"] [::Bound "a"]])]] - ["Nil" [::Tuple (&/|list)]])]]) + ["Nil" [::Tuple (&/|list)]])]]) (def +type+ (let [text [::Data "java.lang.String" (&/|list)] @@ -105,52 +110,58 @@ ["All" [::Tuple (&/|list string=>type text text type)]] )]]))) -(defn clean [type] - (matchv ::M/objects [type] - [["Var" ?id]] - (exec [=type (deref ?id)] - (clean =type)) - - [["Lambda" [?arg ?return]]] - (exec [=arg (clean ?arg) - =return (clean ?return)] - (return (&/V "Lambda" (to-array [=arg =return])))) - - [["App" [?lambda ?param]]] - (exec [=lambda (clean ?lambda) - =param (clean ?param)] - (return (&/V "App" (to-array [=lambda =param])))) - - [["Tuple" ?members]] - (exec [=members (&/map% clean ?members)] - (return (&/V "Tuple" =members))) - - [["Variant" ?members]] - (exec [=members (&/map% (fn [[k v]] - (exec [=v (clean v)] - (return (to-array [k =v])))) - ?members)] - (return (&/V "Variant" =members))) - - [["Record" ?members]] - (exec [=members (&/map% (fn [[k v]] - (exec [=v (clean v)] +(defn clean [tvar type] + (matchv ::M/objects [tvar] + [["Var" ?tid]] + (matchv ::M/objects [type] + [["Var" ?id]] + (if (= ?tid ?id) + (&/try-all% (&/|list (exec [=type (deref ?id)] + (clean tvar =type)) + (return type))) + (return type)) + + [["Lambda" [?arg ?return]]] + (exec [=arg (clean tvar ?arg) + =return (clean tvar ?return)] + (return (&/V "Lambda" (to-array [=arg =return])))) + + [["App" [?lambda ?param]]] + (exec [=lambda (clean tvar ?lambda) + =param (clean tvar ?param)] + (return (&/V "App" (to-array [=lambda =param])))) + + [["Tuple" ?members]] + (exec [=members (&/map% (partial clean tvar) ?members)] + (return (&/V "Tuple" =members))) + + [["Variant" ?members]] + (exec [=members (&/map% (fn [[k v]] + (exec [=v (clean tvar v)] + (return (to-array [k =v])))) + ?members)] + (return (&/V "Variant" =members))) + + [["Record" ?members]] + (exec [=members (&/map% (fn [[k v]] + (exec [=v (clean tvar v)] + (return (to-array [k =v])))) + ?members)] + (return (&/V "Record" =members))) + + [["All" [?env ?name ?arg ?body]]] + (exec [=env (&/map% (fn [[k v]] + (exec [=v (clean tvar v)] (return (to-array [k =v])))) - ?members)] - (return (&/V "Record" =members))) - - [["All" [?env ?name ?arg ?body]]] - (exec [=env (&/map% (fn [[k v]] - (exec [=v (clean v)] - (return (to-array [k =v])))) - ?env)] - (return (&/V "All" (to-array [=env ?name ?arg ?body])))) + ?env)] + (return (&/V "All" (to-array [=env ?name ?arg ?body])))) - [_] - (return type) - )) + [_] + (return type) + ))) (defn ^:private show-type [type] + (prn 'show-type (aget type 0)) (matchv ::M/objects [type] [["Any" _]] "Any" @@ -206,6 +217,7 @@ (str "Type " (show-type expected) " does not subsume type " (show-type actual))) (defn solve [expected actual] + (prn 'solve (aget expected 0) (aget actual 0)) (matchv ::M/objects [expected actual] [["Any" _] _] success @@ -243,16 +255,20 @@ (solve e!output a!output)) [["Var" e!id] _] - (exec [=e!type (deref e!id) - _ (solve =e!type actual) - _ (reset e!id =e!type)] - success) + (&/try-all% (&/|list (exec [=e!type (deref e!id) + _ (solve =e!type actual) + _ (reset e!id =e!type)] + success) + (exec [_ (reset e!id actual)] + success))) [_ ["Var" a!id]] - (exec [=a!type (deref a!id) - _ (solve expected =a!type) - _ (reset a!id =a!type)] - success) + (&/try-all% (&/|list (exec [=a!type (deref a!id) + _ (solve expected =a!type) + _ (reset a!id =a!type)] + success) + (exec [_ (reset a!id expected)] + success))) [_ _] (solve-error expected actual) |