aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lux/analyser.clj26
-rw-r--r--src/lux/compiler.clj82
-rw-r--r--test2.lux149
3 files changed, 235 insertions, 22 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index b192a2e31..07d3fb3b7 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -609,6 +609,17 @@
(let [fold-branch (fn [struct entry]
(let [struct* (clojure.core.match/match (nth entry 0)
+ [::pm-char ?token]
+ (clojure.core.match/match (:type struct)
+ ::char-tests (update-in struct [:patterns ?token] (fn [bodies]
+ (if bodies
+ (conj bodies (nth entry 1))
+ #{(nth entry 1)})))
+ nil (-> struct
+ (assoc :type ::char-tests)
+ (assoc-in [:patterns ?token] #{(nth entry 1)}))
+ _ (assert false "Can't do match."))
+
[::pm-text ?text]
(clojure.core.match/match (:type struct)
::text-tests (update-in struct [:patterns ?text] (fn [bodies]
@@ -676,6 +687,7 @@
;; (.print System/out (prn-str 'branches* branches*))
;; (.print System/out (prn-str '(:type branches*) (:type branches*)))
(clojure.core.match/match (:type branches*)
+ ::char-tests branches*
::text-tests branches*
::tuple (do (assert (<= (count (:defaults branches*)) 1))
{:type ::tuple*
@@ -710,6 +722,9 @@
:branches (:branches branches*)})))
get-vars (fn get-vars [pattern]
(clojure.core.match/match pattern
+ [::&parser/char ?token]
+ '()
+
[::&parser/text ?text]
'()
@@ -730,6 +745,9 @@
))
->instructions (fn ->instructions [locals pattern]
(clojure.core.match/match pattern
+ [::&parser/char ?token]
+ [::pm-char ?token]
+
[::&parser/text ?text]
[::pm-text ?text]
@@ -801,6 +819,14 @@
[registers mappings tree] (exec [=branches (map-m (fn [[?pattern ?body]]
;; (prn '?branch ?branch)
(match ?pattern
+ [::&parser/char ?token]
+ (exec [=body (analyse-form* ?body)]
+ (return [::case-branch [::&parser/char ?token] =body]))
+
+ [::&parser/text ?token]
+ (exec [=body (analyse-form* ?body)]
+ (return [::case-branch [::&parser/text ?token] =body]))
+
[::&parser/ident ?name]
(exec [=body (with-locals {?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []])}
(analyse-form* ?body))]
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 5b257eaed..ae8c75aa0 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -318,17 +318,38 @@
(defn compile-decision-tree [writer mappings default-label decision-tree]
;; (prn 'compile-decision-tree decision-tree)
(match decision-tree
- [::test-text ?text $body]
- (let [$else (new Label)]
+ [::test-char ?pairs]
+ (do (doseq [[?token $body] ?pairs
+ :let [$else (new Label)]]
+ (doto writer
+ ;; object
+ (.visitInsn Opcodes/DUP) ;; object, object
+ (.visitTypeInsn Opcodes/NEW (->class "java.lang.Character"))
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn ?token) ;; object, object, text
+ (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Character") "<init>" "(C)V")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
+ (.visitJumpInsn Opcodes/IFEQ $else) ;; object
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel $else)))
(doto writer
- ;; object
- (.visitInsn Opcodes/DUP) ;; object, object
- (.visitLdcInsn ?text) ;; object, object, text
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
- (.visitJumpInsn Opcodes/IFEQ $else) ;; object
(.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel $else)
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+
+ [::test-text ?pairs]
+ (do (doseq [[?text $body] ?pairs
+ :let [$else (new Label)]]
+ (doto writer
+ ;; object
+ (.visitInsn Opcodes/DUP) ;; object, object
+ (.visitLdcInsn ?text) ;; object, object, text
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
+ (.visitJumpInsn Opcodes/IFEQ $else) ;; object
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel $else)))
+ (doto writer
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO default-label)))
@@ -427,12 +448,24 @@
]
[[::store ?local ?body] #{?body}])
+ ::&analyser/char-tests
+ (concat (list [[::test-char (for [[?token ?supports] (:patterns head)
+ ?body (set/intersection branches ?supports)
+ ;; :when (set/subset? branches ?supports)
+ ]
+ [?token ?body])]
+ branches])
+ (for [[_ ?local ?body] (:defaults head)
+ :when (contains? branches ?body)]
+ [[::store ?local ?body] #{?body}]))
+
::&analyser/text-tests
- (concat (for [[?text ?supports] (:patterns head)
- ?body (set/intersection branches ?supports)
- ;; :when (set/subset? branches ?supports)
- ]
- [[::test-text ?text ?body] #{?body}])
+ (concat (list [[::test-text (for [[?token ?supports] (:patterns head)
+ ?body (set/intersection branches ?supports)
+ ;; :when (set/subset? branches ?supports)
+ ]
+ [?token ?body])]
+ branches])
(for [[_ ?local ?body] (:defaults head)
:when (contains? branches ?body)]
[[::store ?local ?body] #{?body}]))
@@ -519,6 +552,7 @@
[::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree]
(do ;; (prn 'compile-case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree)
;; (assert false)
+ ;; (prn 'compile-case ?decision-tree)
(let [start-label (new Label)
end-label (new Label)
;; default-label (new Label)
@@ -539,24 +573,28 @@
;; (prn 'sequence-parts
;; (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))
(doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))]
- (if (:default ?decision-tree)
+ (if (or (:default ?decision-tree)
+ (not (empty? (:defaults ?decision-tree))))
(butlast pieces)
pieces))]
(compile-decision-tree *writer* mappings* default-label decision-tree))
(.visitLabel *writer* default-label)
- (if-let [[_ [_ _ ?idx] ?body] (:default ?decision-tree)]
+ (if-let [[_ [_ _ ?idx] ?body] (or (:default ?decision-tree)
+ (first (:defaults ?decision-tree)))]
(doto *writer*
(.visitInsn Opcodes/DUP)
(.visitVarInsn Opcodes/ASTORE ?idx)
(.visitJumpInsn Opcodes/GOTO (get mappings* ?body)))
(doto *writer*
- ;; (.visitInsn Opcodes/POP)
- (.visitTypeInsn Opcodes/CHECKCAST (->class +variant-class+))
- (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" (->type-signature "java.lang.String"))
+ (.visitInsn Opcodes/POP)
+ ;; (.visitTypeInsn Opcodes/CHECKCAST (->class +variant-class+))
+ ;; (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" (->type-signature "java.lang.String"))
(.visitTypeInsn Opcodes/NEW ex-class)
- (.visitInsn Opcodes/DUP_X1)
- (.visitInsn Opcodes/SWAP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" (str "(" (->type-signature "java.lang.String") ")" "V"))
+ (.visitInsn Opcodes/DUP)
+ ;; (.visitInsn Opcodes/DUP_X1)
+ ;; (.visitInsn Opcodes/SWAP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+ ;; (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" (str "(" (->type-signature "java.lang.String") ")" "V"))
(.visitInsn Opcodes/ATHROW)))
;; (if default-code
;; ;; (do (prn 'default-code default-code)
diff --git a/test2.lux b/test2.lux
index e5e3ad6da..c3854ab19 100644
--- a/test2.lux
+++ b/test2.lux
@@ -269,6 +269,103 @@
outputs (map-m f inputs')]
(return (#Cons output outputs)))))
+(def (fold-m f init inputs)
+ (case inputs
+ #Nil (return init)
+ (#Cons x inputs') (exec [init* (f init x)]
+ (fold-m f init* inputs'))))
+
+(def (apply-m monad call-state)
+ (lambda [state]
+ (let output (monad call-state)
+ (case output
+ (#Ok [?state ?datum])
+ (#Ok [state ?datum])
+
+ _
+ output))))
+
+(def (assert test message)
+ (if test
+ (return [])
+ (fail message)))
+
+(def (pass %value)
+ (lambda [state]
+ %value))
+
+(def get-state
+ (lambda [state]
+ (return* state state)))
+
+(def (show x)
+ (jvm/invokevirtual Object "toString" []
+ x []))
+
+(def (concat t1 t2)
+ (jvm/invokevirtual String "concat" [String]
+ t1 [t2]))
+
+(def (normalize-char char)
+ (case char
+ #"*" "_ASTER_"
+ #"+" "_PLUS_"
+ #"-" "_DASH_"
+ #"/" "_SLASH_"
+ #"_" "_UNDERS_"
+ #"%" "_PERCENT_"
+ #"$" "_DOLLAR_"
+ #"'" "_QUOTE_"
+ #"`" "_BQUOTE_"
+ #"@" "_AT_"
+ #"^" "_CARET_"
+ #"&" "_AMPERS_"
+ #"=" "_EQ_"
+ #"!" "_BANG_"
+ #"?" "_QM_"
+ #":" "_COLON_"
+ #";" "_SCOLON_"
+ #"." "_PERIOD_"
+ #"," "_COMMA_"
+ #"<" "_LT_"
+ #">" "_GT_"
+ #"~" "_TILDE_"
+ ##;;#"\" "_BSLASH_"
+ _ (show char)
+ ))
+
+(def (range from to)
+ (if (= to from)
+ #Nil
+ (#Cons from (range (inc from) to))))
+
+#(
+ (def (text->list text)
+ (let length (jvm/invokevirtual String "length" []
+ text [])
+ (map (lambda [idx]
+ (jvm/invokevirtual String "charAt" [int]
+ text [idx]))
+ (range-to 0 length))))
+
+ (def (normalize-ident ident)
+ (fold concat "" (map normalize-char (text->list ident))))
+
+ (def (fresh-class-loader path)
+ (let file (jvm/new java.io.File [String] [path])
+ (let url (jvm/invokevirtual java.io.File "toURL" []
+ file [])
+ (let urls (array java.net.URL (list url))
+ (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))))
+
+ (def (fresh-class-loader path)
+ (let [file (jvm/new java.io.File [String] [path])
+ url (jvm/invokevirtual java.io.File "toURL" []
+ file [])
+ urls (array java.net.URL (list url))]
+ (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))
+ )#
+
(def (cons tail head)
(#Cons head tail))
@@ -307,6 +404,53 @@
(def (run-state monad state)
(monad state))
+(def list-map #Nil)
+
+(def (put key val map)
+ (case map
+ #Nil
+ (#Cons [key val] map)
+
+ (#Cons [?key ?val] map')
+ (if (= key ?key)
+ (#Cons [?key val] map')
+ (#Cons [?key ?val] (put key val map')))))
+
+(def (get key map)
+ (case map
+ #Nil
+ #None
+
+ (#Cons [?key ?val] map')
+ (if (= key ?key)
+ (#Some ?val)
+ (get key map'))))
+
+(def (show-kv kv)
+ (case kv
+ [?key ?val]
+ (fold concat "" (list "#" ?key " " (show ?val)))))
+
+(def (interpose elem list)
+ (case list
+ (#Cons x (#Cons y list'))
+ (#Cons x (#Cons elem (#Cons y list')))
+
+ _
+ list))
+
+(def (print-map list-map)
+ (do (print "{")
+ (print (fold concat "" (interpose " " (map show-kv list-map))))
+ (println "}")))
+
+(def (show-list xs)
+ (case xs
+ #Nil
+ "#Nil"
+ (#Cons x xs')
+ (fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")"))))
+
## Program
(def (main args)
(case (' ((~ "Oh yeah...")))
@@ -333,6 +477,11 @@
(#Failure ?message)
(println ?message))
(print-enum (enumerate (list #"a" #"b" #"c" #"d" #"e")))
+ (print-map (put "Nyan" "cat" (put "Yolo" "lol" list-map)))
+ (let char #"*"
+ (do (print (show char)) (print " -> ")
+ (println (normalize-char char))))
+ (println (show-list (range 0 10)))
)
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 01:48:46 +0000