aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--source/lux.lux259
-rw-r--r--src/lux.clj1
-rw-r--r--src/lux/analyser.clj106
-rw-r--r--src/lux/compiler.clj43
4 files changed, 248 insertions, 161 deletions
diff --git a/source/lux.lux b/source/lux.lux
index cab8a31d2..63ab93a4c 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -67,111 +67,152 @@
[java.lang.Object _7] [java.lang.Object _8]])
## Base functions & macros
-(def' id
- (lambda' id x
- x))
-
-(def' + (lambda' + x (lambda' _ y (jvm:iadd x y))))
-
-(def' fold
- (lambda' fold f
- (lambda' _ init
- (lambda' _ values
- (case values
- #Nil
- init
- (#Cons x xs)
- (fold f (f init x) xs)
- )))))
-
(annotate lambda Macro)
(def' lambda
(lambda' _ tokens
(lambda' _ state
- (let output (case tokens
- (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)))
- (#Form (#Cons (#Ident "lambda'")
- (#Cons self
- (#Cons arg
- (case args'
- #Nil
- (#Cons body #Nil)
-
- _
- (#Cons (#Ident "lux:lambda")
- (#Cons (#Tuple args')
- (#Cons body #Nil))))))))
-
- (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))
- (#Form (#Cons (#Ident "lambda'")
- (#Cons (#Ident "_")
- (#Cons arg
- (case args'
- #Nil
- (#Cons body #Nil)
-
- _
- (#Cons (#Ident "lux:lambda")
- (#Cons (#Tuple args')
- (#Cons body #Nil)))))))))
- [(#Cons output #Nil) state]))))
-
-(def cons
- (lambda [tail head]
- (#Cons head tail)))
-
-#(
- (defmacro (lambda tokens)
+ (let' output (case tokens
+ (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)))
+ (#Form (#Cons (#Ident "lambda'")
+ (#Cons self
+ (#Cons arg
+ (#Cons (case args'
+ #Nil
+ body
+
+ _
+ (#Form (#Cons (#Ident "lux:lambda")
+ (#Cons (#Tuple args')
+ (#Cons body #Nil)))))
+ #Nil)))))
+
+ (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))
+ (#Form (#Cons (#Ident "lambda'")
+ (#Cons (#Ident "_")
+ (#Cons arg
+ (#Cons (case args'
+ #Nil
+ body
+
+ _
+ (#Form (#Cons (#Ident "lux:lambda")
+ (#Cons (#Tuple args')
+ (#Cons body #Nil)))))
+ #Nil))))))
+ [(#Cons output #Nil) state]))))
+
+(annotate def Macro)
+(def' def
+ (lambda [tokens state]
+ (let' output (case tokens
+ (#Cons (#Ident name) (#Cons body #Nil))
+ (#Form (#Cons (#Ident "def'")
+ (#Cons (#Ident name)
+ (#Cons body #Nil))))
+
+ (#Cons (#Form (#Cons (#Ident name) args))
+ (#Cons body #Nil))
+ (#Form (#Cons (#Ident "def'")
+ (#Cons (#Ident name)
+ (#Cons (#Form (#Cons (#Ident "lux:lambda")
+ (#Cons (#Ident name)
+ (#Cons (#Tuple args)
+ (#Cons body #Nil)))))
+ #Nil)))))
+ [(#Cons output #Nil) state])))
+
+(def (+ x y)
+ (jvm:iadd x y))
+
+(def (id x)
+ x)
+
+(def (fold f init values)
+ (case values
+ #Nil
+ init
+
+ (#Cons x xs)
+ (fold f (f init x) xs)))
+
+(def (reverse list)
+ (fold (lambda [tail head] (#Cons head tail))
+ #Nil
+ list))
+
+(annotate list Macro)
+(def (list xs state)
+ (let' output (fold (lambda [tail head]
+ (#Form (#Cons (#Tag "Cons")
+ (#Cons head
+ (#Cons tail #Nil)))))
+ (#Tag "Nil")
+ (reverse xs))
+ [(#Cons output #Nil) state]))
+
+(annotate list+ Macro)
+(def (list+ xs state)
+ (case (reverse xs)
+ #Nil
+ [#Nil state]
+
+ (#Cons last init')
+ (let' output (fold (lambda [tail head]
+ (#Form (#Cons (#Tag "Cons")
+ (#Cons head tail))))
+ last
+ init')
+ [(#Cons output #Nil) state])))
+
+(def (->pairs xs)
+ (case xs
+ (#Cons x (#Cons y xs'))
+ (#Cons [x y] (->pairs xs'))
+
+ _
+ #Nil))
+
+#((annotate let Macro)
+ (def (let tokens state)
(case tokens
- (#Cons self (#Cons args (#Cons body #Nil)))
-
-
- (#Cons args (#Cons body #Nil))
- ))
-
- (def' id (lambda [x] x))
-
- (def' + (lambda [x y] (jvm:iadd x y)))
-
- (def (fold f init values)
- (case values
- #Nil
- init
- (#Cons x xs)x
- (fold f (f init x) xs)))
-
- (def (cons tail head)
- (#Cons head tail))
-
- (def (reverse list)
- (fold cons #Nil list))
-
- (annotate list Macro)
- (def (list xs)
- (fold (lambda' tail
- (lambda' head
- (#Form (#Cons (#Tag "Cons")
- (#Cons head
- (#Cons tail #Nil))))))
- (#Tag "Nil")
- (reverse xs)))
-
- (def (++ xs ys)
- (case xs
- #Nil
- ys
-
- (#Cons x xs*)
- (#Cons x (++ xs* ys))))
-
- (def (map f xs)
- (case xs
- #Nil
- #Nil
-
- (#Cons x xs*)
- (#Cons (f x) (map f xs*))))
+ (#Cons (#Tuple bindings) (#Cons body #Nil))
+ (let' output (fold (lambda [body binding]
+ (case binding
+ [label value]
+ (#Form (list (#Ident "let'") label value body))))
+ body
+ (reverse (->pairs bindings)))
+ [(list output) state]))))#
+
+(annotate let Macro)
+(def (let tokens state)
+ (case tokens
+ (#Cons (#Tuple bindings) (#Cons body #Nil))
+ (let' output (fold (lambda [body binding]
+ (case binding
+ [label value]
+ (#Form (#Cons (#Ident "let'") (#Cons label (#Cons value (#Cons body #Nil)))))))
+ body
+ (reverse (->pairs bindings)))
+ [(list output) state])))
+
+(def (++ xs ys)
+ (case xs
+ #Nil
+ ys
+
+ (#Cons x xs*)
+ (#Cons x (++ xs* ys))))
+
+(def (map f xs)
+ (case xs
+ #Nil
+ #Nil
+
+ (#Cons x xs*)
+ (#Cons (f x) (map f xs*))))
+#(
(def (untemplate-list untemplate tokens)
(case tokens
#Nil
@@ -265,19 +306,19 @@
(#Cons from (range (inc from) to))))
(def (text->list text)
- (let length (jvm:invokevirtual String "length" []
- text [])
- (map (lambda' idx
- (jvm:invokevirtual String "charAt" [int]
- text [idx]))
- (range 0 length))))
+ (let' length (jvm:invokevirtual String "length" []
+ text [])
+ (map (lambda' idx
+ (jvm:invokevirtual String "charAt" [int]
+ text [idx]))
+ (range 0 length))))
(def (enumerate list)
(case (fold (lambda' state
- (lambda' x
- (case state
- [idx list']
- [(inc idx) (#Cons [idx x] list')])))
+ (lambda' x
+ (case state
+ [idx list']
+ [(inc idx) (#Cons [idx x] list')])))
[0 #Nil]
list)
[_ list']
diff --git a/src/lux.clj b/src/lux.clj
index f748fd0f3..6d2374edb 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -23,7 +23,6 @@
;; TODO: Reinplement "if" as a macro on top of case.
;; TODO: Remember to optimized calling global functions.
;; TODO: Reader macros.
- ;; TODO: Automatic currying of functions.
;; TODO:
;; TODO:
;; TODO:
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index d44c333b1..8fd6dfb47 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -305,7 +305,7 @@
(reduce (fn [tail x]
(doto (.newInstance (.loadClass loader "lux.Variant2"))
(-> .-tag (set! "Cons"))
- (-> .-_1 (set! (->lux x)))
+ (-> .-_1 (set! (->lux loader x)))
(-> .-_2 (set! tail))))
(doto (.newInstance (.loadClass loader "lux.Variant0"))
(-> .-tag (set! "Nil")))
@@ -354,6 +354,7 @@
(def ^:private ->lux+ (partial ->lux+* ->lux))
(defn ->clojure+* [->clojure xs]
+ (prn '->clojure+* (.-tag xs))
(case (.-tag xs)
"Nil" '()
"Cons" (cons (->clojure (.-_1 xs))
@@ -361,21 +362,23 @@
))
(defn ->clojure [x]
+ (pr '->clojure (.-tag x))
(case (.-tag x)
- "Bool" [::&parser/bool (-> x .-_1)]
- "Int" [::&parser/int (-> x .-_1)]
- "Real" [::&parser/real (-> x .-_1)]
- "Char" [::&parser/char (-> x .-_1)]
- "Text" [::&parser/text (-> x .-_1)]
- "Tag" [::&parser/tag (-> x .-_1)]
- "Ident" [::&parser/ident (-> x .-_1)]
- "Tuple" [::&parser/tuple (->> x .-_1 (->clojure+* ->clojure))]
- "Form" [::&parser/form (->> x .-_1 (->clojure+* ->clojure))]))
+ "Bool" (do (println) [::&parser/bool (.-_1 x)])
+ "Int" (do (println) [::&parser/int (.-_1 x)])
+ "Real" (do (println) [::&parser/real (.-_1 x)])
+ "Char" (do (println) [::&parser/char (.-_1 x)])
+ "Text" (do (println) [::&parser/text (.-_1 x)])
+ "Tag" (do (println " " (.-_1 x)) [::&parser/tag (.-_1 x)])
+ "Ident" (do (println) [::&parser/ident (.-_1 x)])
+ "Tuple" (do (println) [::&parser/tuple (->clojure+* ->clojure (.-_1 x))])
+ "Form" (do (println) [::&parser/form (->clojure+* ->clojure (.-_1 x))])))
(def ^:private ->clojure+ (partial ->clojure+* ->clojure))
(defn ^:private analyse-tuple [analyse-ast ?elems]
- (exec [=elems (do-all-m* (map analyse-ast ?elems))]
+ (exec [=elems (do-all-m* (map analyse-ast ?elems))
+ :let [_ (prn 'analyse-tuple =elems)]]
(return (list (annotated [::tuple =elems] [::&type/tuple (mapv :type =elems)])))))
(defn ^:private analyse-ident [analyse-ast ?ident]
@@ -388,12 +391,19 @@
[::global-fn ?module ?name]
(exec [macro? (is-macro? ?module ?name)]
(if macro?
- (let [macro-class (str ?module "$" (normalize-ident ?name))]
- (-> (.loadClass loader macro-class)
- .newInstance
- (.apply (->lux+ loader ?args))
- ->clojure
- analyse-ast))
+ (let [macro-class (str ?module "$" (normalize-ident ?name))
+ output (-> (.loadClass loader macro-class)
+ .getDeclaredConstructors
+ first
+ (.newInstance (to-array [(int 0) nil]))
+ (.apply (->lux+ loader ?args))
+ (.apply nil))
+ _ (prn 'output (str ?module ":" ?name) output (.-_1 output) (.-tag (.-_1 output)))
+ macro-expansion (->clojure+ (.-_1 output))
+ state* (.-_2 output)
+ _ (prn 'macro-expansion (str ?module ":" ?name) state* macro-expansion)
+ ]
+ (do-all-m* (map analyse-ast macro-expansion)))
(exec [=args (do-all-m* (map analyse-ast ?args))
:let [[needs-num =return-type] (match (:type =fn)
[::&type/function ?fargs ?freturn]
@@ -654,17 +664,35 @@
(exec [[=value] (analyse-ast ?value)
idx next-local-idx
[=body] (with-let ?label (:type =value)
- (analyse-ast ?body))]
+ (analyse-ast ?body))
+ :let [_ (prn 'analyse-let =body)]]
(return (list (annotated [::let idx ?label =value =body] (:type =body))))))
-(defn ^:private raise-tree-bindings [raise-expr outer-scope ?tree]
- (let [partial-f (partial raise-expr outer-scope)
- tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)]
+(defn ^:private raise-tree-bindings [raise-expr outer-scope offset ?tree]
+ (let [partial-f (partial raise-expr outer-scope offset)
+ tree-partial-f (partial raise-tree-bindings raise-expr outer-scope offset)]
(case (:type ?tree)
+ ::tuple*
+ (-> ?tree
+ (update-in [:patterns]
+ #(into {} (for [[?tag ?unapply] %]
+ [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
+ (update-in [:default]
+ (fn [[tag local $branch :as total]]
+ ;; (prn 'total total)
+ (if total
+ [tag (-> {:form local :type ::&type/nothing} partial-f :form) $branch]))))
+
::adt*
- (update-in ?tree [:patterns]
- #(into {} (for [[?tag ?unapply] %]
- [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
+ (-> ?tree
+ (update-in [:patterns]
+ #(into {} (for [[?tag ?unapply] %]
+ [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
+ (update-in [:default]
+ (fn [[tag local $branch :as total]]
+ ;; (prn 'total total)
+ (if total
+ [tag (-> {:form local :type ::&type/nothing} partial-f :form) $branch]))))
::defaults
(update-in ?tree [:stores]
@@ -675,10 +703,10 @@
(assert false (pr-str ?tree))
)))
-(defn ^:private raise-expr [outer-scope syntax]
+(defn ^:private raise-expr [outer-scope offset syntax]
;; (prn 'raise-bindings body)
- (let [partial-f (partial raise-expr outer-scope)
- tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)]
+ (let [partial-f (partial raise-expr outer-scope offset)
+ tree-partial-f (partial raise-tree-bindings raise-expr outer-scope offset)]
(match (:form syntax)
[::literal ?value]
syntax
@@ -702,20 +730,24 @@
{:form [::self outer-scope (mapv partial-f ?curried)]
:type (:type syntax)}
+ [::global _ _]
+ syntax
+
[::jvm:iadd ?x ?y]
{:form [::jvm:iadd (partial-f ?x) (partial-f ?y)]
:type (:type syntax)}
[::let ?idx ?name ?value ?body]
- {:form [::let ?idx ?name (partial-f ?value) (partial-f ?body)]
+ {:form [::let offset ?name (partial-f ?value)
+ (raise-expr outer-scope (inc offset) ?body)]
:type (:type syntax)}
[::case ?base ?variant ?registers ?mappings ?tree]
(let [=variant (partial-f ?variant)
=mappings (into {} (for [[idx syntax] ?mappings]
- [idx (partial-f syntax)]))
+ [idx (raise-expr outer-scope (+ offset ?registers) syntax)]))
=tree (tree-partial-f ?tree)]
- {:form [::case ?base =variant ?registers =mappings =tree]
+ {:form [::case offset =variant ?registers =mappings =tree]
:type (:type syntax)})
[::lambda ?scope ?captured ?args ?value]
@@ -748,7 +780,7 @@
:let [;; _ (prn '(:form =body) (:form =body))
=lambda (match (:form =body)
[::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body]
- [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope ?sub-body)]
+ [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope (-> ?sub-args count (+ 2)) ?sub-body)]
_
[::lambda =scope =captured (list ?arg) =body])]
@@ -757,6 +789,7 @@
(return (list (annotated =lambda =function)))))
(defn ^:private analyse-def [analyse-ast ?name ?value]
+ ;; (prn 'analyse-def ?name ?value)
(exec [def?? (defined? ?name)]
(if def??
(fail (str "Can't redefine function/constant: " ?name))
@@ -769,12 +802,12 @@
new-scope [$module ?name]
=value (match (:form =value)
[::lambda ?old-scope ?env ?args ?body]
- {:form [::lambda new-scope ?env ?args (raise-expr new-scope ?body)]
+ {:form [::lambda new-scope ?env ?args (raise-expr new-scope (-> ?args count inc) ?body)]
:type (:type =value)}
_
=value)]
- ;; :let [_ (prn 'DEF/POST =value)]
+ ;; :let [_ (prn 'DEF/POST ?name =value)]
_ (if ann??
(return nil)
(annotate ?name ::constant ::public false (:type =value)))
@@ -886,7 +919,7 @@
(return (list (annotated [::literal ?value] [::&type/object "java.lang.String" []])))
[::&parser/tag ?tag]
- (do (prn 'analyse-basic-ast/variant0 ?tag)
+ (do ;; (prn 'analyse-basic-ast/variant0 ?tag)
(return (list (annotated [::variant ?tag '()] [::&type/variant ?tag '()]))))
[::&parser/tuple ?elems]
@@ -898,7 +931,7 @@
[::&parser/form ([[::&parser/ident "if"] ?test ?then ?else] :seq)]
(analyse-if analyse-ast ?test ?then ?else)
- [::&parser/form ([[::&parser/ident "let"] [::&parser/ident ?label] ?value ?body] :seq)]
+ [::&parser/form ([[::&parser/ident "let'"] [::&parser/ident ?label] ?value ?body] :seq)]
(analyse-let analyse-ast ?label ?value ?body)
[::&parser/form ([[::&parser/ident "case"] ?variant & ?branches] :seq)]
@@ -967,7 +1000,8 @@
(match token
[::&parser/form ([[::&parser/tag ?tag] & ?data] :seq)]
(exec [=data (do-all-m* (map analyse-ast ?data))
- :let [_ (prn 'analyse-ast/variant+ ?tag '=data =data)]]
+ ;; :let [_ (prn 'analyse-ast/variant+ ?tag '=data =data)]
+ ]
(return (list (annotated [::variant ?tag =data] [::&type/variant ?tag (map :type =data)]))))
[::&parser/form ([?fn & ?args] :seq)]
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index f6daaca0f..76f480a14 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -605,6 +605,7 @@
(.visitInsn Opcodes/DUP)
(.visitLabel start-label))
default-label (new Label)
+ ;; _ (prn '?decision-tree ?decision-tree)
_ (do (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))]
(if (or (:default ?decision-tree)
(not (empty? (:defaults ?decision-tree))))
@@ -693,7 +694,7 @@
(let [num-args (count args)]
(str "(" (reduce str "" (repeat (count closed-over) clo-field-sig))
(if (> num-args 1)
- (reduce str counter-sig (repeat num-args clo-field-sig)))
+ (reduce str counter-sig (repeat (dec num-args) clo-field-sig)))
")"
<init>-return)))
@@ -728,6 +729,22 @@
(.visitMaxs 0 0)
(.visitEnd))))
+ (defn add-closed-over-vars [writer class-name closed-over]
+ (dotimes [capt_idx (count closed-over)]
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name (str "__" capt_idx) clo-field-sig))))
+
+ (defn add-partial-vars [writer class-name args]
+ (dotimes [clo_idx (count args)]
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig))))
+
+ (defn add-nulls [writer amount]
+ (dotimes [_ amount]
+ (.visitInsn writer Opcodes/ACONST_NULL)))
+
(defn add-lambda-apply [class class-name closed-over args impl-signature init-signature]
(let [num-args (count args)
num-captured (dec num-args)
@@ -736,31 +753,24 @@
(new Label))]
(doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil)
(.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
(-> (doto (.visitVarInsn Opcodes/ALOAD 0)
(.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig)
(.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
(-> (doto (.visitLabel branch-label)
(.visitTypeInsn Opcodes/NEW class-name)
(.visitInsn Opcodes/DUP)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name (str "__" capt_idx) clo-field-sig))
- (->> (dotimes [capt_idx (count closed-over)])))
+ (add-closed-over-vars class-name closed-over)
(.visitLdcInsn (-> current-captured inc int))
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig))
- (->> (dotimes [clo_idx current-captured])))
+ (add-partial-vars class-name (take current-captured args))
(.visitVarInsn Opcodes/ALOAD 1)
- (-> (.visitInsn Opcodes/ACONST_NULL)
- (->> (dotimes [clo_idx (- (dec num-captured) current-captured)])))
+ (add-nulls (- (dec num-captured) current-captured))
(.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" init-signature)
(.visitInsn Opcodes/ARETURN))
(->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))])))
- (.visitLabel default-label)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig))
- (->> (dotimes [clo_idx num-captured]))))
+ (.visitLabel default-label))
(->> (when (> num-args 1))))
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (add-partial-vars class-name (butlast args))
(.visitVarInsn Opcodes/ALOAD 1)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature)
(.visitInsn Opcodes/ARETURN)
@@ -1066,7 +1076,9 @@
))
;; [Interface]
-(let [compiler-step (exec [analysis+ &analyser/analyse]
+(let [compiler-step (exec [analysis+ &analyser/analyse
+ ;; :let [_ (prn 'analysis+ analysis+)]
+ ]
(map-m compile analysis+))]
(defn compile-module [name]
(exec [loader &util/loader]
@@ -1090,6 +1102,7 @@
(fail* ?message))))))))
(defn compile-all [modules]
+ (.mkdir (java.io.File. "output"))
(let [state {::&lexer/source nil
::&analyser/current-module nil
::&analyser/scope []
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 13:28:01 +0000