diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/lux/analyser/case.clj | 159 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 17 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 5 | ||||
| -rw-r--r-- | src/lux/analyser/module.clj | 11 | ||||
| -rw-r--r-- | src/lux/analyser/parser.clj | 59 | ||||
| -rw-r--r-- | src/lux/base.clj | 70 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 197 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 24 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 17 | ||||
| -rw-r--r-- | src/lux/compiler/module.clj | 5 |
10 files changed, 314 insertions, 250 deletions
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index d71782914..517a58ab7 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -238,105 +238,104 @@ (&&/analyse-1 analyse exo-type body))] (return (&/Cons$ pattern+body patterns)))) -(let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] - (defn ^:private merge-total [struct test+body] - (|let [[test ?body] test+body] - (|case [struct test] - [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return (&/V $DefaultTotal true)) +(defn ^:private merge-total [struct test+body] + (|let [[test ?body] test+body] + (|case [struct test] + [($DefaultTotal total?) ($StoreTestAC ?idx)] + (return (&/V $DefaultTotal true)) - [($BoolTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $BoolTotal (&/T true ?values))) + [($BoolTotal total? ?values) ($StoreTestAC ?idx)] + (return (&/V $BoolTotal (&/T true ?values))) - [($IntTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $IntTotal (&/T true ?values))) + [($IntTotal total? ?values) ($StoreTestAC ?idx)] + (return (&/V $IntTotal (&/T true ?values))) - [($RealTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $RealTotal (&/T true ?values))) + [($RealTotal total? ?values) ($StoreTestAC ?idx)] + (return (&/V $RealTotal (&/T true ?values))) - [($CharTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $CharTotal (&/T true ?values))) + [($CharTotal total? ?values) ($StoreTestAC ?idx)] + (return (&/V $CharTotal (&/T true ?values))) - [($TextTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $TextTotal (&/T true ?values))) + [($TextTotal total? ?values) ($StoreTestAC ?idx)] + (return (&/V $TextTotal (&/T true ?values))) - [($TupleTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $TupleTotal (&/T true ?values))) + [($TupleTotal total? ?values) ($StoreTestAC ?idx)] + (return (&/V $TupleTotal (&/T true ?values))) - [($VariantTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $VariantTotal (&/T true ?values))) + [($VariantTotal total? ?values) ($StoreTestAC ?idx)] + (return (&/V $VariantTotal (&/T true ?values))) - [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($BoolTestAC ?value)] + (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) - [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/Cons$ ?value ?values)))) + [($BoolTotal total? ?values) ($BoolTestAC ?value)] + (return (&/V $BoolTotal (&/T total? (&/Cons$ ?value ?values)))) - [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($IntTestAC ?value)] + (return (&/V $IntTotal (&/T total? (&/|list ?value)))) - [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/Cons$ ?value ?values)))) + [($IntTotal total? ?values) ($IntTestAC ?value)] + (return (&/V $IntTotal (&/T total? (&/Cons$ ?value ?values)))) - [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($RealTestAC ?value)] + (return (&/V $RealTotal (&/T total? (&/|list ?value)))) - [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/Cons$ ?value ?values)))) + [($RealTotal total? ?values) ($RealTestAC ?value)] + (return (&/V $RealTotal (&/T total? (&/Cons$ ?value ?values)))) - [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($CharTestAC ?value)] + (return (&/V $CharTotal (&/T total? (&/|list ?value)))) - [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/Cons$ ?value ?values)))) + [($CharTotal total? ?values) ($CharTestAC ?value)] + (return (&/V $CharTotal (&/T total? (&/Cons$ ?value ?values)))) - [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($TextTestAC ?value)] + (return (&/V $TextTotal (&/T total? (&/|list ?value)))) - [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/Cons$ ?value ?values)))) + [($TextTotal total? ?values) ($TextTestAC ?value)] + (return (&/V $TextTotal (&/T total? (&/Cons$ ?value ?values)))) - [($DefaultTotal total?) ($TupleTestAC ?tests)] - (|do [structs (&/map% (fn [t] - (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) - ?tests)] - (return (&/V $TupleTotal (&/T total? structs)))) + [($DefaultTotal total?) ($TupleTestAC ?tests)] + (|do [structs (&/map% (fn [t] + (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) + ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) - [($TupleTotal total? ?values) ($TupleTestAC ?tests)] - (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map2% (fn [v t] - (merge-total v (&/T t ?body))) - ?values ?tests)] - (return (&/V $TupleTotal (&/T total? structs)))) - (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - - [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (&/V $DefaultTotal total?) - (&/T ?test ?body)) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) - (&/$Some list) - (return list) - - (&/$None) - (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T total? structs)))) - - [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) - (&/$Some sub) - sub - - (&/$None) - (&/V $DefaultTotal total?)) - (&/T ?test ?body)) - structs (|case (&/|list-put ?tag sub-struct ?branches) - (&/$Some list) - (return list) - - (&/$None) - (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T total? structs)))) - )))) + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T t ?body))) + ?values ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) + + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (&/V $DefaultTotal total?) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return (&/V $VariantTotal (&/T total? structs)))) + + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) + (&/$Some sub) + sub + + (&/$None) + (&/V $DefaultTotal total?)) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct ?branches) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return (&/V $VariantTotal (&/T total? structs)))) + ))) (defn check-totality+ [check-totality] (fn [?token] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 5a85fbe66..25f7852dc 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -723,9 +723,10 @@ _ (check-method-completion all-supers =methods) =captured &&env/captured-vars :let [=fields (&/|map (fn [^objects idx+capt] - (&/T (str &c!base/closure-prefix (aget idx+capt 0)) - (&/|list) - captured-slot-type)) + (|let [[idx _] idx+capt] + (&/T (str &c!base/closure-prefix idx) + (&/|list) + captured-slot-type))) (&/enumerate =captured))] :let [sources (&/|map captured-source =captured)] _ (compile-token (&/V &&/$jvm-class (&/T class-decl super-class interfaces (&/|list) =fields =methods =captured (&/Some$ =ctor-args)))) @@ -737,13 +738,17 @@ (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] - =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class &/Nil$) + =catches (&/map% (fn [_catch_] + (|do [:let [[?ex-class ?ex-arg ?catch-body] _catch_] + =catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class &/Nil$) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - :let [catched-exceptions (&/|map #(aget ^objects % 0) =catches)] + :let [catched-exceptions (&/|map (fn [=catch] + (|let [[_c-class _ _] =catch] + _c-class)) + =catches)] =body (with-catches catched-exceptions (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 3777e8053..4bfe10873 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -372,8 +372,9 @@ (|case (&&meta/meta-get &&meta/macro?-tag ?meta) (&/$Some _) (|do [macro-expansion (fn [state] (-> ?value (.apply ?args) (.apply state))) - ;; :let [_ (when (or (= "using" (aget real-name 1)) - ;; ;; (= "defsig" (aget real-name 1)) + ;; :let [[r-prefix r-name] real-name + ;; _ (when (or (= "using" r-prefix) + ;; ;; (= "defsig" r-prefix) ;; ) ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 83a641707..158fd7487 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -244,19 +244,20 @@ nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(do-template [<name> <idx> <doc>] +(do-template [<name> <part> <doc>] (defn <name> [module tag-name] <doc> (fn [state] (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [^objects idx+tags+type (&/|get tag-name (&/get$ $tags =module))] - (return* state (aget idx+tags+type <idx>)) + (|let [[?idx ?tags ?type] idx+tags+type] + (return* state <part>)) (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) (fail* (str "[Module Error] Unknown module: " module))))) - tag-index 0 "(-> Text Text (Lux Int))" - tag-group 1 "(-> Text Text (Lux (List Ident)))" - tag-type 2 "(-> Text Text (Lux Type))" + tag-index ?idx "(-> Text Text (Lux Int))" + tag-group ?tags "(-> Text Text (Lux (List Ident)))" + tag-type ?type "(-> Text Text (Lux Type))" ) (def defs diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj index c6a24c4e2..8a843dc59 100644 --- a/src/lux/analyser/parser.clj +++ b/src/lux/analyser/parser.clj @@ -72,22 +72,23 @@ _ (fail (str "[Analyser Error] Not constructor argument: " (&/show-ast ast))))) -(defn parse-handler [[catch+ finally+] token] - (|case token - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] - (&/$Cons [_ (&/$TextS ?ex-class)] - (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] - (&/$Cons ?catch-body - (&/$Nil))))))] - (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] - (&/$Cons ?finally-body - (&/$Nil))))] - (return (&/T catch+ (&/V &/$Some ?finally-body))) +(defn parse-handler [catch+&finally+ token] + (|let [[catch+ finally+] catch+&finally+] + (|case token + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] + (&/$Cons [_ (&/$TextS ?ex-class)] + (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] + (&/$Cons ?catch-body + (&/$Nil))))))] + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) + + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] + (&/$Cons ?finally-body + (&/$Nil))))] + (return (&/T catch+ (&/V &/$Some ?finally-body))) - _ - (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) + _ + (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token)))))) (let [failure (fail (str "[Analyser Error] Invalid annotation parameter."))] (defn ^:private parse-ann-param [param] @@ -145,7 +146,7 @@ _ (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast))))) -(defn parse-method-def [ast] +(defn ^:private parse-method-init-def [ast] (|case ast [_ (&/$FormS (&/$Cons [_ (&/$TextS "init")] (&/$Cons [_ (&/$TupleS anns)] @@ -161,6 +162,11 @@ =ctor-args (&/map% parse-ctor-arg ?ctor-args)] (return (&/V &/$ConstructorMethodSyntax (&/T =anns =gvars =exceptions =inputs =ctor-args body)))) + _ + (fail ""))) + +(defn ^:private parse-method-virtual-def [ast] + (|case ast [_ (&/$FormS (&/$Cons [_ (&/$TextS "virtual")] (&/$Cons [_ (&/$TextS ?name)] (&/$Cons [_ (&/$TupleS anns)] @@ -176,25 +182,38 @@ =output (parse-gclass output)] (return (&/V &/$VirtualMethodSyntax (&/T ?name =anns =gvars =exceptions =inputs =output body)))) + _ + (fail ""))) + +(defn ^:private parse-method-override-def [ast] + (|case ast [_ (&/$FormS (&/$Cons [_ (&/$TextS "override")] (&/$Cons ?class-decl - (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons ?name (&/$Cons [_ (&/$TupleS anns)] (&/$Cons [_ (&/$TupleS gvars)] (&/$Cons [_ (&/$TupleS exceptions)] (&/$Cons [_ (&/$TupleS inputs)] (&/$Cons output (&/$Cons body (&/$Nil)))))))))))] - (|do [=class-decl (parse-gclass-decl ?class-decl) + (|do [=name (parse-text ?name) + =class-decl (parse-gclass-decl ?class-decl) =anns (&/map% parse-ann anns) =gvars (&/map% parse-text gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] - (return (&/V &/$OverridenMethodSyntax (&/T =class-decl ?name =anns =gvars =exceptions =inputs =output body)))) + (return (&/V &/$OverridenMethodSyntax (&/T =class-decl =name =anns =gvars =exceptions =inputs =output body)))) _ - (fail (str "[Analyser Error] Invalid method definition: " (&/show-ast ast))))) + (fail ""))) + +(defn parse-method-def [ast] + (&/try-all% (&/|list #((parse-method-init-def ast) %) + #((parse-method-virtual-def ast) %) + #((parse-method-override-def ast) %) + (fn [state] + (fail* (str "[Analyser Error] Invalid method definition: " (&/show-ast ast))))))) (defn parse-field [ast] (|case ast diff --git a/src/lux/base.clj b/src/lux/base.clj index ba1489726..1a8cde61b 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -148,7 +148,15 @@ (def product-tag (str (char 0) "product" (char 0))) (defn T [& elems] - (to-array elems)) + (case (count elems) + 0 + nil + + 1 + (first elems) + + ;; else + (to-array [product-tag (int 0) (to-array elems)]))) (defn V [^Long tag value] (to-array [sum-tag tag value])) @@ -163,13 +171,11 @@ (def empty-cursor (T "" -1 -1)) (defn get$ [slot ^objects record] - (aget record slot)) + (aget ^objects (aget record 2) slot)) (defn set$ [slot value ^objects record] - (let [record* (aclone record) - size (alength record)] - (aset record* slot value) - record*)) + (to-array [product-tag (int 0) (doto (aclone ^objects (aget record 2)) + (aset slot value))])) (defmacro update$ [slot f record] `(let [record# ~record] @@ -183,7 +189,15 @@ (V $Right (T state value))) (defn transform-pattern [pattern] - (cond (vector? pattern) (mapv transform-pattern pattern) + (cond (vector? pattern) (case (count pattern) + 0 + nil + + 1 + (first pattern) + + ;; else + ['_ '_ (mapv transform-pattern pattern)]) (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] ['_ (eval (first pattern)) @@ -191,7 +205,7 @@ 0 nil 1 (first parts) ;; else - `[~@parts])]) + ['_ '_ parts])]) :else pattern )) @@ -318,6 +332,12 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + (defn |++ [xs ys] (|case xs ($Nil) @@ -326,23 +346,13 @@ ($Cons x xs*) (V $Cons (T x (|++ xs* ys))))) -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) - (defn |map [f xs] (|case xs ($Nil) xs ($Cons x xs*) - (V $Cons (T (f x) (|map f xs*))) - - _ - (assert false (prn-str '|map f (adt->text xs))) - )) + (V $Cons (T (f x) (|map f xs*))))) (defn |empty? [xs] "(All [a] (-> (List a) Bool))" @@ -812,17 +822,18 @@ (defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" - (if (= "" (aget cursor 0)) - body - (fn [state] - (let [output (body (set$ $cursor cursor state))] - (|case output - ($Right ?state ?value) - (return* (set$ $cursor (get$ $cursor state) ?state) - ?value) + (|let [[_file-name _line _column] cursor] + (if (= "" _file-name) + body + (fn [state] + (let [output (body (set$ $cursor cursor state))] + (|case output + ($Right ?state ?value) + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) - _ - output))))) + _ + output)))))) (def cursor ;; (Lux Cursor) @@ -952,7 +963,6 @@ (defn |at [idx xs] "(All [a] (-> Int (List a) (Maybe a)))" - ;; (prn '|at idx (aget idx 0)) (|case xs ($Cons x xs*) (cond (< idx 0) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 1a4006312..1f2188a2f 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -22,120 +22,125 @@ MethodVisitor))) ;; [Utils] -(let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] - (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] - (|case ?match - (&a-case/$StoreTestAC ?idx) - (if (< ?idx 0) - (doto writer - (.visitInsn Opcodes/POP) ;; Basically, a No-Op - (.visitJumpInsn Opcodes/GOTO $target)) - (doto writer - (.visitVarInsn Opcodes/ASTORE ?idx) - (.visitJumpInsn Opcodes/GOTO $target))) - - (&a-case/$BoolTestAC ?value) +(defn ^:private compile-match [^MethodVisitor writer ?match $target $else] + (|case ?match + (&a-case/$StoreTestAC ?idx) + (if (< ?idx 0) (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Boolean" "booleanValue" "()Z") - (.visitLdcInsn ?value) - (.visitJumpInsn Opcodes/IF_ICMPNE $else) - (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/POP) ;; Basically, a No-Op (.visitJumpInsn Opcodes/GOTO $target)) - - (&a-case/$IntTestAC ?value) (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J") - (.visitLdcInsn (long ?value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitJumpInsn Opcodes/GOTO $target))) - (&a-case/$RealTestAC ?value) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D") - (.visitLdcInsn (double ?value)) - (.visitInsn Opcodes/DCMPL) - (.visitJumpInsn Opcodes/IFNE $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$BoolTestAC ?value) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Boolean" "booleanValue" "()Z") + (.visitLdcInsn ?value) + (.visitJumpInsn Opcodes/IF_ICMPNE $else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$CharTestAC ?value) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Character" "charValue" "()C") - (.visitLdcInsn ?value) - (.visitJumpInsn Opcodes/IF_ICMPNE $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$IntTestAC ?value) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J") + (.visitLdcInsn (long ?value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target)) + + (&a-case/$RealTestAC ?value) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D") + (.visitLdcInsn (double ?value)) + (.visitInsn Opcodes/DCMPL) + (.visitJumpInsn Opcodes/IFNE $else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target)) + + (&a-case/$CharTestAC ?value) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Character" "charValue" "()C") + (.visitLdcInsn ?value) + (.visitJumpInsn Opcodes/IF_ICMPNE $else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$TextTestAC ?value) + (&a-case/$TextTestAC ?value) + (doto writer + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?value) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target)) + + (&a-case/$TupleTestAC ?members) + (|case ?members + (&/$Nil) (doto writer - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?value) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$TupleTestAC ?members) - (|case ?members - (&/$Nil) - (doto writer - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) - - (&/$Cons ?member (&/$Nil)) - (compile-match ?member $target $else) + (&/$Cons ?member (&/$Nil)) + (compile-match ?member $target $else) - _ - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (-> (doto (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)) - (.visitInsn Opcodes/AALOAD) - (compile-match test $next $sub-else) - (.visitLabel $sub-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $next)) - (->> (|let [[idx test] idx+member - $next (new Label) - $sub-else (new Label)]) - (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target))) - - (&a-case/$VariantTestAC ?tag ?count ?test) + _ (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (.visitLdcInsn ?tag) - (&&/wrap-long) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) - (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 2)) (.visitInsn Opcodes/AALOAD) - (-> (doto (compile-match ?test $value-then $value-else) - (.visitLabel $value-then) + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (-> (doto (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)) + (.visitInsn Opcodes/AALOAD) + (compile-match test $next $sub-else) + (.visitLabel $sub-else) (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $value-else) (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else)) - (->> (let [$value-then (new Label) - $value-else (new Label)])))) - ))) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $next)) + (->> (|let [[idx test] idx+member + $next (new Label) + $sub-else (new Label)]) + (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) + (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target))) + + (&a-case/$VariantTestAC ?tag ?count ?test) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (.visitLdcInsn ?tag) + (&&/wrap-long) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 2)) + (.visitInsn Opcodes/AALOAD) + (-> (doto (compile-match ?test $value-then $value-else) + (.visitLabel $value-then) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $value-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else)) + (->> (let [$value-then (new Label) + $value-else (new Label)])))) + )) (defn ^:private separate-bodies [patterns] (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 72f36975f..01b73014c 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -270,8 +270,9 @@ _ (doto *writer* (.visitTypeInsn Opcodes/NEW class*) (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [[class-name arg]] - (|do [ret (compile arg) + _ (&/map% (fn [class-name+arg] + (|do [:let [[class-name arg] class-name+arg] + ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) (&/zip2 ?classes ?args)) @@ -728,19 +729,24 @@ (&/$None) (|do [_ (return nil) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] (return nil))) - catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) + catch-boundaries (&/|map (fn [_catch_] + (|let [[?ex-class ?ex-idx ?catch-body] _catch_] + (&/T ?ex-class (new Label) (new Label)))) ?catches) - _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)] - (doto *writer* - (.visitTryCatchBlock $from $to $handler-start (&host-generics/->bytecode-class-name ?ex-class)) - (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))) + _ (doseq [catch-boundary (&/->seq catch-boundaries)] + (|let [[?ex-class $handler-start $handler-end] catch-boundary] + (doto *writer* + (.visitTryCatchBlock $from $to $handler-start (&host-generics/->bytecode-class-name ?ex-class)) + (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil)))) _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)] :let [_ (.visitLabel *writer* $from)] _ (compile ?body) :let [_ (.visitLabel *writer* $to)] _ compile-finally - handlers (&/map2% (fn [[?ex-class ?ex-idx ?catch-body] [_ $handler-start $handler-end]] - (|do [:let [_ (doto *writer* + handlers (&/map2% (fn [_catch_ _boundary_] + (|do [:let [[?ex-class ?ex-idx ?catch-body] _catch_ + [_ $handler-start $handler-end] _boundary_ + _ (doto *writer* (.visitLabel $handler-start) (.visitVarInsn Opcodes/ASTORE ?ex-idx))] _ (compile ?catch-body) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index cbe9cb0f3..07418ec15 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -66,6 +66,20 @@ _ (|do [:let [_ (doto *writer* + (.visitLdcInsn (int 3)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitFieldInsn Opcodes/GETSTATIC &&/lux-utils-class &&/product-tag-field "Ljava/lang/String;") + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitLdcInsn (int 0)) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 2)))] + :let [_ (doto *writer* (.visitLdcInsn (int num-elems)) (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] _ (&/map2% (fn [idx elem] @@ -75,7 +89,8 @@ ret (compile elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return ret))) - (&/|range num-elems) ?elems)] + (&/|range num-elems) ?elems) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))))) (defn compile-variant [compile ?tag ?value] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index b4b041049..7149e1370 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -20,6 +20,9 @@ (return (&/|map (fn [pair] (|case pair [name [tags _]] - (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&/T name (&/|map (fn [tag] + (|let [[t-prefix t-name] tag] + t-name)) + tags)))) (&/get$ &module/$types module))) )) |