aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--another.lang5
-rw-r--r--src/lang/analyser.clj33
-rw-r--r--src/lang/compiler.clj111
-rw-r--r--test2.lang16
4 files changed, 112 insertions, 53 deletions
diff --git a/another.lang b/another.lang
index 9ff9f8885..ff5bb6f0a 100644
--- a/another.lang
+++ b/another.lang
@@ -2,8 +2,3 @@
## (ann id #type (All [x] (-> [x] x)))
(def (id x)
x)
-
-#( (def (id x)
- (let return "RETURN"
- return))
- )#
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index 7c94c77d5..64bdbac9b 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -445,21 +445,36 @@
(with-anon-locals num-members
(fn [=locals]
;; (prn '?branch/=locals (map :form =locals))
- (exec [=members (reduce-m (fn [[locals-map =members] [?local ?member]]
- (match ?member
- [::&parser/ident ?name]
- (return [(assoc locals-map ?name ?local) (conj =members (:form ?local))])))
- [{} []]
- (map vector =locals ?members))
+ (exec [[inner-num locals+ members+] (reduce-m (fn member-fold [[?inner-num locals-map =members] [?local ?member]]
+ (match ?member
+ [::&parser/ident ?name]
+ (return [?inner-num
+ (assoc locals-map ?name ?local)
+ (conj =members (:form ?local))])
+
+ [::&parser/variant ?subtag ?submembers]
+ (let [num-submembers (count ?submembers)]
+ (with-anon-locals num-submembers
+ (fn [=sublocals]
+ (exec [[subinner-num sublocals+ submembers+] (reduce-m member-fold [0 {} []] (map vector =sublocals ?submembers))
+ ;; :let [_ (prn 'subinner-num subinner-num 'sublocals+ sublocals+ 'submembers+ submembers+)]
+ ]
+ (return [(+ ?inner-num num-submembers subinner-num)
+ (merge locals-map sublocals+)
+ (conj =members [::subcase ?subtag submembers+])])))))
+ ))
+ [0 {} []]
+ (map vector =locals ?members))
+ ;; :let [_ (prn 'inner-num inner-num 'locals+ locals+ 'members+ members+)]
;; :let [_ (prn (first =members) ?body)]
- =body (with-locals (first =members)
+ =body (with-locals locals+
(analyse-form* ?body))
;; :let [_ (prn '?body ?body =body)]
]
- (return [num-members [::branch-adt ?tag (second =members) =body]])))))))
+ (return [(+ num-members inner-num) [::branch-adt ?tag members+ =body]])))))))
?branches)]
(return [(first =locals) =branches]))))
- :let [total-registers (reduce + 1 (map first =branches))
+ :let [total-registers (+ 1 (reduce max 0 (map first =branches)))
;; _ (prn '=branches total-registers (map second =branches))
;; _ (assert false)
]
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index e425fa0f1..f26d111a4 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -288,46 +288,87 @@
(defcompiler ^:private compile-case
;; [::&analyser/case ?variant ?branches]
[::&analyser/case ?base ?variant ?registers ?branches]
- (do ;; (prn [:case ?base ?variant ?registers ?branches])
- (match (:form ?base)
- [::&analyser/local _ ?base-idx]
- (let [start-label (new Label)
- end-label (new Label)]
- (dotimes [idx ?registers]
- (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx idx)))
- (.visitLabel *writer* start-label)
- (compile-form (assoc *state* :form ?variant))
- (.visitVarInsn *writer* Opcodes/ASTORE ?base-idx)
- (let [variant-class* (->class +variant-class+)]
+ (let [variant-class* (->class +variant-class+)]
+ ;; (prn [:case ?base ?variant ?registers ?branches])
+ (match (:form ?base)
+ [::&analyser/local _ ?base-idx]
+ (let [start-label (new Label)
+ end-label (new Label)
+ default-label (new Label)]
+ (dotimes [idx ?registers]
+ (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx idx)))
+ (.visitLabel *writer* start-label)
+ (compile-form (assoc *state* :form ?variant))
+ (.visitTypeInsn *writer* Opcodes/CHECKCAST variant-class*)
+ (.visitVarInsn *writer* Opcodes/ASTORE ?base-idx)
(doseq [?branch ?branches
:let [else-label (new Label)]]
(match ?branch
[::&analyser/branch-adt ?tag ?members ?body]
- (let [tuple-class (str "test2/Tuple" (count ?members))]
- (when (not (empty? ?members))
- (do (doto *writer*
- (.visitVarInsn Opcodes/ALOAD ?base-idx)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class))
- (doseq [[?tfield member] (map vector (range (count ?members)) ?members)]
- (match member
- [:lang.analyser/local 0 ?idx]
+ (doto *writer*
+ (.visitVarInsn Opcodes/ALOAD ?base-idx)
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
+ (.visitLdcInsn ?tag)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
+ (.visitJumpInsn Opcodes/IFEQ else-label)
+ (do (when (not (empty? ?members))
+ (let [tuple-class (str "test2/Tuple" (count ?members))
+ mk-sub-fold (fn mk-sub-fold [cleanup-level default-label tuple-class]
+ (fn sub-fold [?tfield member]
+ (let [next-label (new Label)]
+ (match member
+ [::&analyser/local 0 ?idx]
+ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
+ (.visitVarInsn Opcodes/ASTORE ?idx))
+
+ [::&analyser/subcase ?subtag ?submembers]
+ (let [tuple-class* (str "test2/Tuple" (count ?submembers))
+ cleanup-label (new Label)]
+ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
+ (.visitTypeInsn Opcodes/CHECKCAST variant-class*)
+ (.visitInsn Opcodes/DUP)
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
+ (.visitLdcInsn ?subtag)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
+ (.visitJumpInsn Opcodes/IFEQ cleanup-label)
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class*)
+ (do (dorun (map (mk-sub-fold (inc cleanup-level) default-label tuple-class*)
+ (range (count ?submembers))
+ ?submembers)))
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO next-label)
+ (.visitLabel cleanup-label)
+ (-> (doto (.visitInsn Opcodes/POP))
+ (->> (dotimes [_ (inc cleanup-level)])))
+ (.visitJumpInsn Opcodes/GOTO default-label)
+ (.visitLabel next-label)
+ ))))))]
(doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
- (.visitVarInsn Opcodes/ASTORE ?idx))))
- (.visitInsn *writer* Opcodes/POP)))
- (doto *writer*
- (.visitVarInsn Opcodes/ALOAD ?base-idx)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
- (.visitLdcInsn ?tag)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
- (.visitJumpInsn Opcodes/IFEQ else-label)
- (do (compile-form (assoc *state* :form ?body)))
- (.visitJumpInsn Opcodes/GOTO end-label)
- (.visitLabel else-label))))))
- (.visitInsn *writer* Opcodes/ACONST_NULL)
- (.visitLabel *writer* end-label)))
+ (.visitVarInsn Opcodes/ALOAD ?base-idx)
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class))
+ (dorun (map (mk-sub-fold 1 default-label tuple-class)
+ (range (count ?members))
+ ?members))
+ (.visitInsn *writer* Opcodes/POP)))
+ (compile-form (assoc *state* :form ?body)))
+ (.visitJumpInsn Opcodes/GOTO end-label)
+ (.visitLabel else-label))))
+ ;; Default branch
+ (let [ex-class (->class "java.lang.IllegalStateException")]
+ (doto *writer*
+ (.visitLabel default-label)
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitTypeInsn Opcodes/NEW ex-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+ (.visitInsn Opcodes/ATHROW)))
+ (.visitLabel *writer* end-label)))
)))
(defcompiler ^:private compile-let
diff --git a/test2.lang b/test2.lang
index cbce36ce8..55d7a14af 100644
--- a/test2.lang
+++ b/test2.lang
@@ -1,5 +1,5 @@
(import java.lang.System)
-## (require "./another" as another)
+(require "./another" as another)
(definterface Function
(: apply (-> [java.lang.Object] java.lang.Object)))
@@ -18,11 +18,19 @@
(#Cons x xs*)
(#Cons x (++ xs* ys)))) )#
+#( (def (main args)
+ (if true
+ (case (#Pair "Pattern" "Matching")
+ (#Pair first second)
+ (do (:: (:: System out) (println first))
+ (:: (:: System out) (println second))))
+ (:: (:: System out) (println "FALSE")))) )#
+
(def (main args)
(if true
- (let variant (#Pair "Pattern" "Matching")
- (case variant
- (#Pair first second)
+ (let xs+ys (#Cons "Pattern" (#Cons "Matching" #Nil))
+ (case xs+ys
+ (#Cons first (#Cons second #Nil))
(do (:: (:: System out) (println first))
(:: (:: System out) (println second)))))
(:: (:: System out) (println "FALSE"))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 08:51:10 +0000