diff options
| -rw-r--r-- | source/lux.lux | 882 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 36 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 76 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 36 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 113 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 3 | ||||
| -rw-r--r-- | src/lux/lexer.clj | 4 |
7 files changed, 684 insertions, 466 deletions
diff --git a/source/lux.lux b/source/lux.lux index 24b5cb837..30a0c6628 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -69,14 +69,11 @@ (def (defmacro tokens state) (let' [fn-name fn-def] (case' tokens - (#Cons [(#Form (#Cons [(#Ident ?name) (#Cons [(#Ident ?tokens) (#Cons [(#Ident ?state) #Nil])])])) + (#Cons [(#Form (#Cons [(#Ident name) args])) (#Cons [body #Nil])]) - [?name + [name (#Form (#Cons [(#Ident "lux;def") - (#Cons [(#Form (#Cons [(#Ident ?name) - (#Cons [(#Ident ?tokens) - (#Cons [(#Ident ?state) - #Nil])])])) + (#Cons [(#Form (#Cons [(#Ident name) args])) (#Cons [body #Nil])])]))]) (let' declaration (#Form (#Cons [(#Ident "declare-macro") (#Cons [(#Ident fn-name) #Nil])])) @@ -87,7 +84,7 @@ (#Ok [state #Nil])) (def (int+ x y) - (jvm-iadd x y)) + (jvm-ladd x y)) (def (id x) x) @@ -155,6 +152,9 @@ (reverse (as-pairs bindings))) (#Ok [state (list output)])))) +(def (. f g) + (lambda [x] (f (g x)))) + (def (++ xs ys) (case' xs #Nil @@ -163,6 +163,9 @@ (#Cons [x xs*]) (#Cons [x (++ xs* ys)]))) +(def concat + (fold ++ #Nil)) + (def (map f xs) (case' xs #Nil @@ -171,6 +174,8 @@ (#Cons [x xs*]) (#Cons [(f x) (map f xs*)]))) +(def flat-map (. concat map)) + (def (untemplate-list tokens) (case' tokens #Nil @@ -215,16 +220,17 @@ )) (defmacro (` tokens state) - (#Ok [state - (list (untemplate-list (map untemplate tokens)))])) + (case' tokens + (#Cons [template #Nil]) + (#Ok [state (list (untemplate template))]))) (defmacro (if tokens state) (case' tokens (#Cons [test (#Cons [then (#Cons [else #Nil])])]) (#Ok [state - (` (case' (~ test) - true (~ then) - false (~ else)))]))) + (list (` (case' (~ test) + true (~ then) + false (~ else))))]))) (def (filter p xs) (case' xs @@ -253,466 +259,506 @@ (#Error msg) (#Error msg)))) -#( +(def (first pair) + (case' pair + [f s] + f)) -## TODO: Full pattern-matching -## TODO: Type-related macros -## TODO: (Im|Ex)ports-related macros -## TODO: Macro-related macros +(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)]))))))) -(def (apply-template env template) -(case template -(#Ident ident) -(if-let [subst (get ident env)] -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)) - -(def (do-template tokens) -(case tokens -(list+ bindings template data) -(let [bindings-list (tuple->list bindings) -data-lists (map tuple->list data)] -(return (map (lambda [env] (apply-template env template)) -(map (zip 2 bindings) data-lists)))))) -(declare-macro do-template) +## (defmacro (do tokens) +## (case tokens +## (list (#Tuple bindings) body) +## (let [output (fold (lambda [inner binding] +## (case binding +## [lhs rhs] +## (' (bind (lambda [(~ lhs)] (~ body)) +## (~ rhs))))) +## body +## (reverse (as-pairs bindings)))] +## (return (list output))))) + +(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 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 (loop tokens) -(case' tokens -(#Cons [bindings (#Cons [body #Nil])]) -(let [pairs (as-pairs bindings)] -(return (list (' ((lambda (~ (#Ident "recur")) (~ (#Tuple (map first pairs))) -(~ body)) -(~@ (map second pairs))))))))) -(declare-macro loop) - -(def (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)))) -))) -(declare-macro case) - -(def (do tokens state) -(case tokens -(list (#Tuple bindings) body) -(let [output (fold (lambda [inner binding] -(case binding -[lhs rhs] -(' (bind (lambda [(~ lhs)] (~ body)) -(~ rhs))))) -body -(reverse (as-pairs bindings)))] -[(list output) state]))) -(declare-macro do) - -(def (export tokens) -(return (map (lambda [t] -(' (export' (~ t)))) -tokens))) -(declare-macro export) +(def (not x) + (case' x + true false + false true)) -## (import "lux") -## (module-alias "lux" "l") -## (def-alias "lux;map" "map") +(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 (require tokens) -## (case tokens -## ...)) +(def complement (. not)) -## (require lux #as l #refer [map]) +(def (constant x) + (lambda [_] x)) -(def (type tokens) -(case tokens -(#Tuple elems) -(return (list (' (#Tuple (~ (map untemplate elems)))))) - -(#Record fields) -(return (list (' (#Record (~ (map (lambda [kv] -(case kv -[(#Tag tag) val] -[tag (untemplate val)])) -fields)))))) - -(#Form (list+ (#Ident "|") options)) -(do [options' (map% (lambda [opt] -(case opt -(#Tag tag) -[tag (#Tuple (list))] - -(#Form (list (#Tag tag) value)) -[tag value] - -_ -(fail ""))) -options)] -(#Variant options')) -)) -(declare-macro type) +(def (int> x y) + (jvm-lgt x y)) -## (type (| #Nil -## (#Cons [a (List a)]))) +(def (int< x y) + (jvm-llt x y)) -## (type [Int Bool Text]) +(def inc (int+ 1)) +(def dec (int+ -1)) -## (type {#id Int #alive? Bool #name Text}) +(def (repeat n x) + (if (int> n 0) + (#Cons [x (repeat (dec n) x)]) + #Nil)) -(def (All tokens) -(let [[name args body] (case tokens -(list (#Tuple args) body) -["" args body] - -(list (#Ident name) (#Tuple args) body) -[name args body])] -(return (list (' (#All (~ name) [(~@ (map (lambda [arg] -(case arg -(#Ident arg') -(#Text arg'))) -args))] -(~ body))))))) -(declare-macro All) - -(def (Exists tokens) -(case tokens -(list (#Ident name) body) -(return (list (' (#Exists (~ name) (~ body))))))) -(declare-macro Exists) - -(def (deftype tokens) -(case tokens -(list (#Ident name) definition) -(return (list (' (def (~ (#Ident name)) -(type (~ definition)))))) - -(list (#Form (list+ (#Ident name) args)) definition) -(let [name' (#Ident name)] -(return (list (' (def (~ name') -(All (~ name') [(~@ args)] -(type (~ definition)))))))) -)) -(declare-macro deftype) - -(def (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)))) -(declare-macro and) - -(def (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)))) -(declare-macro or) +(def size + (fold (lambda [acc _] (inc acc)) 0)) -(def (not x) -(case x -true false -false true)) - -(def (get@ tokens) -(let [output (case tokens -(list (#Tag tag) record) -(' (get@' (~ (#Tag tag)) (~ record))) - -(list (#Tag tag)) -(' (lambda [record] (get@' (~ (#Tag tag)) record))))] -(return (list output)))) -(declare-macro get@) - -(def (set@ tokens) -(let [output (case tokens -(list (#Tag tag) value record) -(' (set@' (~ (#Tag tag)) (~ value) (~ record))) - -(list (#Tag tag) value) -(' (lambda [record] (set@' (~ (#Tag tag)) (~ value) record))) - -(list (#Tag tag)) -(' (lambda [value record] (set@' (~ (#Tag tag)) value record))))] -(return (list output)))) -(declare-macro set@) - -(def (update@ tokens) -(let [output (case tokens -(list tag func record) -(` (let [_record_ (~ record)] -(set@ (~ tag) _record_ ((~ func) (get@ (~ tag) _record_))))) - -(list (#Tag tag) func) -(' (lambda [record] -(` (set@ (~ tag) record ((~ func) (get@ (~ tag) record)))))) - -(list (#Tag tag)) -(' (lambda [func record] -(set@ (~ tag) record (func (get@ (~ tag) record))))))] -(return (list output)))) -(declare-macro update@) +(def (last xs) + (case' xs + #Nil #None + (#Cons [x #Nil]) (#Some x) + (#Cons [_ xs']) (last xs'))) -(def (. f g) -(lambda [x] (f (g x)))) - -(def (|> tokens) -(case tokens -(list+ init apps) -(return (list (fold (lambda [acc app] -(case app -(#Form parts) -(#Form (++ parts (list acc))) - -_ -(` (~ app) (~ acc)))) -init -apps))))) - -(def ($ tokens) -(case tokens -(list+ op init args) -(return (list (fold (lambda [acc elem] -(` (~ op) (~ acc) (~ elem))) -init -args))))) - -(def ($keys tokens) -(case tokens -(list (#Tuple fields)) -(let [record (#Record (map (lambda [slot] -(case slot -(#Tag name) -[(#Tag name) (#Ident name)])) -fields))] -(return (list record))))) - -(def ($or tokens) -(case tokens -(list (#Tuple patterns) body) -(return (flat-map (lambda [pattern] (list pattern body)) -patterns)))) - -(def (-> 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 (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 (defsyntax tokens) -...) +(def (interleave xs ys) + (case' [xs ys] + [(#Cons [x xs']) (#Cons [y ys'])] + (list+ x y (interleave xs' ys')) -(def (defsig tokens) -...) + _ + #Nil)) -(def (defstruct tokens) -...) +(def (interpose sep xs) + (case' xs + #Nil + xs + + (#Cons [x #Nil]) + xs -(def (with tokens) -...) + (#Cons [x xs']) + (list+ x sep (interpose sep xs')))) -## (deftype (List a) -## (| #Nil -## (#Cons [a (List a)]))) +(def (empty? xs) + (case' xs + #Nil true + _ false)) -(def (complement f) -(lambda [x] (not (f x)))) +## (do-template [<name> <op>] +## (def (<name> p xs) +## (case xs +## #Nil true +## (#Cons [x xs']) (<op> (p x) (<name> p xs')))) -(def (cond tokens) -(let [else (last tokens) -branches (as-pairs (init tokens))] -(return (list (fold (lambda [else branch] -(case branch -[test then] -(` (if (~ test) (~ then) (~ else))))) -else -branches))))) -(declare-macro cond) +## [every? and] +## [any? or]) -(def (constant x) -(lambda [_] x)) +(def (range from to) + (if (int< from to) + (#Cons [from (range (inc from) to)]) + #Nil)) + +## (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 (tuple->list tuple) + (case' tuple + (#Tuple list) + list)) + +(def (zip xs ys) + (case' [xs ys] + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (zip xs' ys')]) -(def (repeat n x) -(if (> n 0) -(list+ x (repeat (dec n) x)) -#Nil)) + _ + #Nil)) -(def (size xs) -(case xs -#Nil 0 -(#Cons [_ xs']) (int+ 1 (size xs')))) +(def (get key map) + (case' map + #Nil + #None -(def (last xs) -(case xs -#Nil #None -(list x) (#Some x) -(list+ _ xs') (last xs'))) + (#Cons [[k v] map']) + (if (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] + k [key]) + (#Some v) + (get key map')))) -(def (init xs) -(case xs -#Nil #None -(list _) (#Some #Nil) -(#Cons [x xs']) (case (init xs') -(#Some xs'') -(#Cons [x xs'']) +(def (get-ident x) + (case' x + (#Ident ident) + ident)) -_ -#None))) +(def (text-++ x y) + (jvm-invokevirtual java.lang.String "concat" [java.lang.String] + x [y])) -(do-template [<name> <offset>] -(def <name> (int+ <offset>)) +(def (show-env env) + (|> env (map first) (interpose ", ") (fold text-++ ""))) -[inc 1] -[dec -1]) +(def (apply-template env template) + (case' template + (#Ident ident) + (case' (get ident env) + (#Some subst) + subst + + _ + template) + + (#Tuple elems) + (#Tuple (map (apply-template env) elems)) -(def (interleave xs ys) -(case [xs ys] -[(#Cons [x xs']) (#Cons [y ys'])] -(list+ x y (interleave xs' ys')) + (#Form elems) + (#Form (map (apply-template env) elems)) -_ -#Nil)) + (#Record members) + (#Record (map (lambda [kv] + (case' kv + [slot value] + [(apply-template env slot) (apply-template env value)])) + members)) -(def (interpose sep xs) -(case xs -(#Cons [x #Nil]) -xs + _ + 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 (zip bindings-list))) + return)))) -(#Cons [x xs']) -(list+ x sep (interpose sep xs')) +## (do-template [<name> <offset>] +## (def <name> (int+ <offset>)) -_ -xs)) +## [inc 1] +## [dec -1]) -(def (flatten xss) -(fold ++ (list) xs)) +(def (int= x y) + (jvm-leq x y)) -(def (flat-map f xs) -(flatten (map f xs))) +(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)) + (def (<name> x y) + (if (<cmp> x y) + x + y)) -[max >] -[min <]) + [max int>] + [min int<]) (do-template [<name> <cmp>] -(def (<name> n) (<cmp> n 0)) + (def (<name> n) (<cmp> n 0)) -[neg? <] -[pos? >=]) + [neg? int<] + [pos? int>=]) (def (even? n) -(int= 0 (int% n 0))) + (int= 0 (int% n 0))) (def (odd? n) -(not (even? n))) + (not (even? n))) (do-template [<name> <done> <step>] -(def (<name> n xs) -(if (> n 0) -(case xs -#Nil #Nil -(list+ x xs') <step>) -<done>)) + (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')]) + [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 -(list+ x xs') (if (f x) <step> #Nil))) + (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 tag) (#Cons [record #Nil])]) + (` (get@' (~ (#Tag tag)) (~ record))) + + (#Cons [(#Tag tag) #Nil]) + (` (lambda [record] (get@' (~ (#Tag tag)) record))))] + (return (list output)))) + +(defmacro (set@ tokens) + (let [output (case' tokens + (#Cons [(#Tag tag) (#Cons [value (#Cons [record #Nil])])]) + (` (set@' (~ (#Tag tag)) (~ value) (~ record))) + + (#Cons [(#Tag tag) (#Cons [value #Nil])]) + (` (lambda [record] (set@' (~ (#Tag tag)) (~ value) record))) + + (#Cons [(#Tag tag) #Nil]) + (` (lambda [value record] (set@' (~ (#Tag 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) _record_ ((~ func) (get@' (~ tag) _record_))))) + + (#Cons [tag (#Cons [func #Nil])]) + (` (lambda [record] + (` (set@' (~ tag) record ((~ func) (get@' (~ tag) record)))))) + + (#Cons [tag #Nil]) + (` (lambda [func record] + (set@' (~ tag) record (func (get@' (~ tag) record))))))] + (return (list output)))) -[take-while #Nil (list+ x (take-while f xs'))] -[drop-while xs (drop-while f xs')]) +(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]) + +(defmacro (type tokens) + (case tokens + (#Tuple elems) + (return (list (' (#Tuple (~ (map untemplate elems)))))) + + (#Record fields) + (return (list (' (#Record (~ (map (lambda [kv] + (case kv + [(#Tag tag) val] + [tag (untemplate val)])) + fields)))))) + + (#Form (list+ (#Ident "|") options)) + (do [options' (map% (lambda [opt] + (case opt + (#Tag tag) + [tag (#Tuple (list))] + + (#Form (list (#Tag tag) value)) + [tag value] + + _ + (fail ""))) + options)] + (#Variant options')) + )) + +(defmacro (All tokens) + (let [[name args body] (case tokens + (list (#Tuple args) body) + ["" args body] + + (list (#Ident name) (#Tuple args) body) + [name args body])] + (return (list (' (#All (~ name) [(~@ (map (lambda [arg] + (case arg + (#Ident arg') + (#Text arg'))) + args))] + (~ body))))))) + +(defmacro (Exists tokens) + (case tokens + (list (#Ident name) body) + (return (list (' (#Exists (~ name) (~ body))))))) + +(defmacro (deftype tokens) + (case tokens + (list (#Ident name) definition) + (return (list (' (def (~ (#Ident name)) + (type (~ definition)))))) + + (list (#Form (list+ (#Ident name) args)) definition) + (let [name' (#Ident name)] + (return (list (' (def (~ name') + (All (~ name') [(~@ args)] + (type (~ definition)))))))) + )) + +(defmacro ($keys tokens) + (case tokens + (list (#Tuple fields)) + (let [record (#Record (map (lambda [slot] + (case slot + (#Tag name) + [(#Tag name) (#Ident name)])) + fields))] + (return (list record))))) + +(defmacro ($or tokens) + (case tokens + (list (#Tuple patterns) body) + (return (flat-map (lambda [pattern] (list pattern body)) + patterns)))) + +(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 (empty? xs) -(case xs -#Nil true -_ false)) +(def (defsyntax tokens) + ...) + +(def (defsig tokens) + ...) -(do-template [<name> <op>] -(def (<name> p xs) -(case xs -#Nil true -(#Cons [x xs']) (<op> (p x) (<name> p xs')))) +(def (defstruct tokens) + ...) -[every? and] -[any? or]) +## (def (with tokens) +## ...) -(def (range from to) -(if (< from to) -(list+ from (range (inc from) to)) -#Nil)) +## 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") + +## (def (require tokens) +## (case tokens +## ...)) + +## (require lux #as l #refer [map]) + +## (type (| #Nil +## (#Cons [a (List a)]))) + +## (type [Int Bool Text]) + +## (type {#id Int #alive? Bool #name Text}) + +## (deftype (List a) +## (| #Nil +## (#Cons [a (List a)]))) )# diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3575c3007..8f05232a2 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -78,6 +78,15 @@ [::&parser/Form ([[::&parser/Ident "jvm-irem"] ?x ?y] :seq)] (&&host/analyse-jvm-irem analyse-ast ?x ?y) + [::&parser/Form ([[::&parser/Ident "jvm-ieq"] ?x ?y] :seq)] + (&&host/analyse-jvm-ieq analyse-ast ?x ?y) + + [::&parser/Form ([[::&parser/Ident "jvm-ilt"] ?x ?y] :seq)] + (&&host/analyse-jvm-ilt analyse-ast ?x ?y) + + [::&parser/Form ([[::&parser/Ident "jvm-igt"] ?x ?y] :seq)] + (&&host/analyse-jvm-igt analyse-ast ?x ?y) + ;; Long arithmetic [::&parser/Form ([[::&parser/Ident "jvm-ladd"] ?x ?y] :seq)] (&&host/analyse-jvm-ladd analyse-ast ?x ?y) @@ -94,6 +103,15 @@ [::&parser/Form ([[::&parser/Ident "jvm-lrem"] ?x ?y] :seq)] (&&host/analyse-jvm-lrem analyse-ast ?x ?y) + [::&parser/Form ([[::&parser/Ident "jvm-leq"] ?x ?y] :seq)] + (&&host/analyse-jvm-leq analyse-ast ?x ?y) + + [::&parser/Form ([[::&parser/Ident "jvm-llt"] ?x ?y] :seq)] + (&&host/analyse-jvm-llt analyse-ast ?x ?y) + + [::&parser/Form ([[::&parser/Ident "jvm-lgt"] ?x ?y] :seq)] + (&&host/analyse-jvm-lgt analyse-ast ?x ?y) + ;; Float arithmetic [::&parser/Form ([[::&parser/Ident "jvm-fadd"] ?x ?y] :seq)] (&&host/analyse-jvm-fadd analyse-ast ?x ?y) @@ -110,6 +128,15 @@ [::&parser/Form ([[::&parser/Ident "jvm-frem"] ?x ?y] :seq)] (&&host/analyse-jvm-frem analyse-ast ?x ?y) + [::&parser/Form ([[::&parser/Ident "jvm-feq"] ?x ?y] :seq)] + (&&host/analyse-jvm-feq analyse-ast ?x ?y) + + [::&parser/Form ([[::&parser/Ident "jvm-flt"] ?x ?y] :seq)] + (&&host/analyse-jvm-flt analyse-ast ?x ?y) + + [::&parser/Form ([[::&parser/Ident "jvm-fgt"] ?x ?y] :seq)] + (&&host/analyse-jvm-fgt analyse-ast ?x ?y) + ;; Double arithmetic [::&parser/Form ([[::&parser/Ident "jvm-dadd"] ?x ?y] :seq)] (&&host/analyse-jvm-dadd analyse-ast ?x ?y) @@ -126,6 +153,15 @@ [::&parser/Form ([[::&parser/Ident "jvm-drem"] ?x ?y] :seq)] (&&host/analyse-jvm-drem analyse-ast ?x ?y) + [::&parser/Form ([[::&parser/Ident "jvm-deq"] ?x ?y] :seq)] + (&&host/analyse-jvm-deq analyse-ast ?x ?y) + + [::&parser/Form ([[::&parser/Ident "jvm-dlt"] ?x ?y] :seq)] + (&&host/analyse-jvm-dlt analyse-ast ?x ?y) + + [::&parser/Form ([[::&parser/Ident "jvm-dgt"] ?x ?y] :seq)] + (&&host/analyse-jvm-dgt analyse-ast ?x ?y) + ;; Fields & methods [::&parser/Form ([[::&parser/Ident "jvm-getstatic"] [::&parser/Ident ?class] [::&parser/Text ?field]] :seq)] (&&host/analyse-jvm-getstatic analyse-ast ?class ?field) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index aa7812421..5b96a2a74 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -19,7 +19,7 @@ (fail "[Analyser Error] Can't extract Ident."))) ;; [Resources] -(do-template [<name> <ident> <output-tag> <wrapper-class>] +(do-template [<name> <output-tag> <wrapper-class>] (let [elem-type [::&type/Data <wrapper-class>]] (defn <name> [analyse ?x ?y] (exec [[=x =y] (&&/analyse-2 analyse ?x ?y) @@ -30,29 +30,57 @@ ] (return (list [::&&/Expression [<output-tag> =x =y] elem-type]))))) - analyse-jvm-iadd "jvm;iadd" ::&&/jvm-iadd "java.lang.Integer" - analyse-jvm-isub "jvm;isub" ::&&/jvm-isub "java.lang.Integer" - analyse-jvm-imul "jvm;imul" ::&&/jvm-imul "java.lang.Integer" - analyse-jvm-idiv "jvm;idiv" ::&&/jvm-idiv "java.lang.Integer" - analyse-jvm-irem "jvm;irem" ::&&/jvm-irem "java.lang.Integer" - - analyse-jvm-ladd "jvm;ladd" ::&&/jvm-ladd "java.lang.Long" - analyse-jvm-lsub "jvm;lsub" ::&&/jvm-lsub "java.lang.Long" - analyse-jvm-lmul "jvm;lmul" ::&&/jvm-lmul "java.lang.Long" - analyse-jvm-ldiv "jvm;ldiv" ::&&/jvm-ldiv "java.lang.Long" - analyse-jvm-lrem "jvm;lrem" ::&&/jvm-lrem "java.lang.Long" - - analyse-jvm-fadd "jvm;fadd" ::&&/jvm-fadd "java.lang.Float" - analyse-jvm-fsub "jvm;fsub" ::&&/jvm-fsub "java.lang.Float" - analyse-jvm-fmul "jvm;fmul" ::&&/jvm-fmul "java.lang.Float" - analyse-jvm-fdiv "jvm;fdiv" ::&&/jvm-fdiv "java.lang.Float" - analyse-jvm-frem "jvm;frem" ::&&/jvm-frem "java.lang.Float" - - analyse-jvm-dadd "jvm;dadd" ::&&/jvm-dadd "java.lang.Double" - analyse-jvm-dsub "jvm;dsub" ::&&/jvm-dsub "java.lang.Double" - analyse-jvm-dmul "jvm;dmul" ::&&/jvm-dmul "java.lang.Double" - analyse-jvm-ddiv "jvm;ddiv" ::&&/jvm-ddiv "java.lang.Double" - analyse-jvm-drem "jvm;drem" ::&&/jvm-drem "java.lang.Double" + analyse-jvm-iadd ::&&/jvm-iadd "java.lang.Integer" + analyse-jvm-isub ::&&/jvm-isub "java.lang.Integer" + analyse-jvm-imul ::&&/jvm-imul "java.lang.Integer" + analyse-jvm-idiv ::&&/jvm-idiv "java.lang.Integer" + analyse-jvm-irem ::&&/jvm-irem "java.lang.Integer" + + analyse-jvm-ladd ::&&/jvm-ladd "java.lang.Long" + analyse-jvm-lsub ::&&/jvm-lsub "java.lang.Long" + analyse-jvm-lmul ::&&/jvm-lmul "java.lang.Long" + analyse-jvm-ldiv ::&&/jvm-ldiv "java.lang.Long" + analyse-jvm-lrem ::&&/jvm-lrem "java.lang.Long" + + analyse-jvm-fadd ::&&/jvm-fadd "java.lang.Float" + analyse-jvm-fsub ::&&/jvm-fsub "java.lang.Float" + analyse-jvm-fmul ::&&/jvm-fmul "java.lang.Float" + analyse-jvm-fdiv ::&&/jvm-fdiv "java.lang.Float" + analyse-jvm-frem ::&&/jvm-frem "java.lang.Float" + + analyse-jvm-dadd ::&&/jvm-dadd "java.lang.Double" + analyse-jvm-dsub ::&&/jvm-dsub "java.lang.Double" + analyse-jvm-dmul ::&&/jvm-dmul "java.lang.Double" + analyse-jvm-ddiv ::&&/jvm-ddiv "java.lang.Double" + analyse-jvm-drem ::&&/jvm-drem "java.lang.Double" + ) + +(do-template [<name> <output-tag> <input-class> <output-class>] + (let [elem-type [::&type/Data <output-class>]] + (defn <name> [analyse ?x ?y] + (exec [[=x =y] (&&/analyse-2 analyse ?x ?y) + ;; =x-type (&&/expr-type =x) + ;; =y-type (&&/expr-type =y) + ;; _ (&type/solve elem-type =x-type) + ;; _ (&type/solve elem-type =y-type) + ] + (return (list [::&&/Expression [<output-tag> =x =y] elem-type]))))) + + analyse-jvm-ieq ::&&/jvm-ieq "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-ilt ::&&/jvm-ilt "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-igt ::&&/jvm-igt "java.lang.Integer" "java.lang.Boolean" + + analyse-jvm-leq ::&&/jvm-leq "java.lang.Long" "java.lang.Boolean" + analyse-jvm-llt ::&&/jvm-llt "java.lang.Long" "java.lang.Boolean" + analyse-jvm-lgt ::&&/jvm-lgt "java.lang.Long" "java.lang.Boolean" + + analyse-jvm-feq ::&&/jvm-feq "java.lang.Float" "java.lang.Boolean" + analyse-jvm-flt ::&&/jvm-flt "java.lang.Float" "java.lang.Boolean" + analyse-jvm-fgt ::&&/jvm-fgt "java.lang.Float" "java.lang.Boolean" + + analyse-jvm-deq ::&&/jvm-deq "java.lang.Double" "java.lang.Boolean" + analyse-jvm-dlt ::&&/jvm-dlt "java.lang.Double" "java.lang.Boolean" + analyse-jvm-dgt ::&&/jvm-dgt "java.lang.Double" "java.lang.Boolean" ) (defn analyse-jvm-getstatic [analyse ?class ?field] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 503f041ea..79682754c 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -88,6 +88,15 @@ [::&a/jvm-irem ?x ?y] (&&host/compile-jvm-irem compile-expression ?type ?x ?y) + [::&a/jvm-ieq ?x ?y] + (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) + + [::&a/jvm-ilt ?x ?y] + (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) + + [::&a/jvm-igt ?x ?y] + (&&host/compile-jvm-igt compile-expression ?type ?x ?y) + ;; Long arithmetic [::&a/jvm-ladd ?x ?y] (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) @@ -104,6 +113,15 @@ [::&a/jvm-lrem ?x ?y] (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) + [::&a/jvm-leq ?x ?y] + (&&host/compile-jvm-leq compile-expression ?type ?x ?y) + + [::&a/jvm-llt ?x ?y] + (&&host/compile-jvm-llt compile-expression ?type ?x ?y) + + [::&a/jvm-lgt ?x ?y] + (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) + ;; Float arithmetic [::&a/jvm-fadd ?x ?y] (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) @@ -120,6 +138,15 @@ [::&a/jvm-frem ?x ?y] (&&host/compile-jvm-frem compile-expression ?type ?x ?y) + [::&a/jvm-feq ?x ?y] + (&&host/compile-jvm-feq compile-expression ?type ?x ?y) + + [::&a/jvm-flt ?x ?y] + (&&host/compile-jvm-flt compile-expression ?type ?x ?y) + + [::&a/jvm-fgt ?x ?y] + (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) + ;; Double arithmetic [::&a/jvm-dadd ?x ?y] (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) @@ -135,6 +162,15 @@ [::&a/jvm-drem ?x ?y] (&&host/compile-jvm-drem compile-expression ?type ?x ?y) + + [::&a/jvm-deq ?x ?y] + (&&host/compile-jvm-deq compile-expression ?type ?x ?y) + + [::&a/jvm-dlt ?x ?y] + (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) + + [::&a/jvm-dgt ?x ?y] + (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) [::&a/exec ?exprs] (&&host/compile-exec compile-expression ?type ?exprs) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 879bc52f3..f1a6492b9 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -36,25 +36,31 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class class-name))))) -;; (let [boolean-class "java.lang.Boolean" -;; integer-class "java.lang.Integer" -;; char-class "java.lang.Character"] -;; (defn prepare-return! [*writer* *type*] -;; (match *type* -;; ::&type/nothing -;; (.visitInsn *writer* Opcodes/ACONST_NULL) +(let [boolean-class "java.lang.Boolean" + integer-class "java.lang.Integer" + long-class "java.lang.Long" + char-class "java.lang.Character"] + (defn prepare-return! [*writer* *type*] + (match *type* + [::&type/Nothing] + (.visitInsn *writer* Opcodes/ACONST_NULL) -;; [::&type/primitive "char"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) + [::&type/Data "char"] + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) -;; [::&type/primitive "int"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class integer-class) "valueOf" (str "(I)" (&host/->type-signature integer-class))) + [::&type/Data "int"] + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class integer-class) "valueOf" (str "(I)" (&host/->type-signature integer-class))) -;; [::&type/primitive "boolean"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) + [::&type/Data "long"] + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) -;; [::&type/Data ?oclass] -;; nil))) + [::&type/Data "boolean"] + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) + + [::&type/Data _] + nil + ) + *writer*)) ;; [Resources] (do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>] @@ -99,6 +105,71 @@ compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" ) +(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>] + (defn <name> [compile *type* ?x ?y] + (exec [:let [+wrapper-class+ (&host/->class <wrapper-class>)] + *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn <opcode> $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I" + compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I" + compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" + ) + +(do-template [<name> <cmpcode> <ifcode> <wrapper-class> <value-method> <value-method-sig>] + (defn <name> [compile *type* ?x ?y] + (exec [:let [+wrapper-class+ (&host/->class <wrapper-class>)] + *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn <cmpcode>) + (.visitJumpInsn <ifcode> $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + compile-jvm-leq Opcodes/LCMP Opcodes/IFEQ "java.lang.Long" "longValue" "()J" + compile-jvm-llt Opcodes/LCMP Opcodes/IFLT "java.lang.Long" "longValue" "()J" + compile-jvm-lgt Opcodes/LCMP Opcodes/IFGT "java.lang.Long" "longValue" "()J" + + compile-jvm-feq Opcodes/FCMPL Opcodes/IFEQ "java.lang.Float" "floatValue" "()F" + compile-jvm-flt Opcodes/FCMPL Opcodes/IFLT "java.lang.Float" "floatValue" "()F" + compile-jvm-fgt Opcodes/FCMPL Opcodes/IFGT "java.lang.Float" "floatValue" "()F" + + compile-jvm-deq Opcodes/DCMPL Opcodes/IFEQ "java.lang.Double" "doubleValue" "()I" + compile-jvm-dlt Opcodes/DCMPL Opcodes/IFLT "java.lang.Double" "doubleValue" "()I" + compile-jvm-dgt Opcodes/FCMPL Opcodes/IFGT "java.lang.Double" "doubleValue" "()I" + ) + (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] (exec [*writer* &/get-writer :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] @@ -107,9 +178,9 @@ :let [_ (prepare-arg! *writer* class-name)]] (return ret))) (map vector ?classes ?args)) - :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) - ;; (prepare-return! *writer* *type*) - )]] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) + (prepare-return! *type*))]] (return nil))) (defn compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args] @@ -123,9 +194,9 @@ :let [_ (prepare-arg! *writer* class-name)]] (return ret))) (map vector ?classes ?args)) - :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (&host/->class ?class) ?method method-sig) - ;; (prepare-return! *writer* *type*) - )]] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class ?class) ?method method-sig) + (prepare-return! *type*))]] (return nil))) (defn compile-jvm-new [compile *type* ?class ?classes ?args] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 7e9e55b23..2b6c7909e 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -135,5 +135,6 @@ (.visitEnd))]] (return nil))) :let [_ (.visitEnd *writer*)] - _ (&&/save-class! current-class (.toByteArray =class))] + _ (&&/save-class! current-class (.toByteArray =class)) + :let [_ (prn 'compile-def ?name)]] (return nil))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index fe899691c..c302ef75d 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -74,8 +74,8 @@ (return [<tag> token]))) ^: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-real ::real #"^-?(0|[1-9][0-9]*)\.[0-9]+" + ^:private lex-int ::int #"^-?(0|[1-9][0-9]*)" ^:private lex-ident ::ident +ident-re+) (def ^:private lex-char |