From e65d1f96a807c4cc88f9e082562bdf963949479e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 17 Jan 2016 00:30:06 -0400 Subject: - Now using the new utility methods in LuxUtils for working with variants/sums. --- src/lux/analyser.clj | 12 ++++++----- src/lux/analyser/host.clj | 2 +- src/lux/analyser/lux.clj | 17 +++++++++------ src/lux/analyser/parser.clj | 2 +- src/lux/base.clj | 25 ++++++++++------------ src/lux/compiler.clj | 4 ++-- src/lux/compiler/base.clj | 1 + src/lux/compiler/case.clj | 43 +++++++++++++++++++------------------ src/lux/compiler/host.clj | 52 ++++++++++++++++++++++++++++++++++++++++++++- src/lux/compiler/lux.clj | 16 ++++++++------ src/lux/compiler/type.clj | 4 ++-- src/lux/lexer.clj | 2 +- src/lux/type.clj | 4 ++-- src/lux/type/host.clj | 4 ++-- 14 files changed, 123 insertions(+), 65 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index f143e2a12..e261420c3 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -21,19 +21,21 @@ ;; [Utils] (defn analyse-variant+ [analyser exo-type ident values] (|do [[module tag-name] (&/normalize ident) - idx (&&module/tag-index module tag-name)] + idx (&&module/tag-index module tag-name) + group (&&module/tag-group module tag-name) + :let [is-last? (= idx (dec (&/|length group)))]] (|case exo-type (&/$VarT id) (|do [? (&type/bound? id)] (if (or ? (&&/type-tag? module tag-name)) - (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx is-last? values) (|do [wanted-type (&&module/tag-type module tag-name) - [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx is-last? values)) _ (&type/check exo-type variant-type)] (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis)))))) _ - (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx is-last? values) ))) (defn ^:private add-loc [meta ^String msg] @@ -661,7 +663,7 @@ (&/with-expected-type exo-type (|case token [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx ?values) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx nil ?values) [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] (analyse-variant+ (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 86e73723d..24a67be87 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -341,7 +341,7 @@ _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor - (&/V &&/$jvm-null nil)))))) + (&/V &&/$jvm-null &/unit-tag)))))) (defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] (|case gtype-vars diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 68e329af2..7adc32b22 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -158,7 +158,7 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) -(defn analyse-variant [analyse ?exo-type idx ?values] +(defn analyse-variant [analyse ?exo-type idx is-last? ?values] (|case ?exo-type (&/$Left exo-type) (|do [exo-type* (&type/actual-type exo-type)] @@ -167,7 +167,7 @@ (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx is-last? ?values)) =var (&type/resolve-type $var) inferred-type (|case =var (&/$VarT iid) @@ -182,7 +182,7 @@ variant-analysis)))))) _ - (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) + (analyse-variant analyse (&/V &/$Right exo-type*) idx is-last? ?values))) (&/$Right exo-type) (|do [exo-type* (|case exo-type @@ -198,6 +198,9 @@ (|case exo-type* (&/$SumT _) (|do [vtype (&type/sum-at idx exo-type*) + :let [is-last?* (if (nil? is-last?) + (= idx (dec (&/|length (&type/flatten-sum exo-type*)))) + is-last?)] =value (&/with-attempt (analyse-variant-body analyse vtype ?values) (fn [err] @@ -208,23 +211,23 @@ _ (return exo-type))] (fail (str err "\n" - 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) + 'analyse-variant " " idx " " is-last? " " is-last?* " " (&type/show-type exo-type) " " (&type/show-type _exo-type) " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$variant (&/T [idx =value])) + (&/V &&/$variant (&/T [idx is-last?* =value])) )))) (&/$UnivQ _) (|do [$var &type/existential exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse (&/V &/$Right exo-type**) idx ?values)) + (analyse-variant analyse (&/V &/$Right exo-type**) idx is-last? ?values)) (&/$ExQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse (&/V &/$Right exo-type**) idx ?values)))) + (analyse-variant analyse (&/V &/$Right exo-type**) idx is-last? ?values)))) _ (fail (str "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type*)))) diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj index 611d65a83..f30b73692 100644 --- a/src/lux/analyser/parser.clj +++ b/src/lux/analyser/parser.clj @@ -38,7 +38,7 @@ (defn parse-gclass [ast] (|case ast [_ (&/$TextS "*")] - (return (&/V &/$GenericWildcard nil)) + (return (&/V &/$GenericWildcard &/unit-tag)) [_ (&/$TextS var-name)] (return (&/V &/$GenericTypeVar var-name)) diff --git a/src/lux/base.clj b/src/lux/base.clj index d74b02402..044f22df6 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -144,13 +144,14 @@ (def tags-field "_tags") (def module-class-name "_") (def +name-separator+ ";") +(def unit-tag (.intern (str (char 0) "unit" (char 0)))) (def sum-tag (.intern (str (char 0) "sum" (char 0)))) (def product-tag (.intern (str (char 0) "product" (char 0)))) (defn T [elems] (case (count elems) 0 - nil + unit-tag 1 (first elems) @@ -159,13 +160,13 @@ (to-array (conj elems product-tag)))) (defn V [^Long tag value] - (to-array [sum-tag tag value])) + (to-array [sum-tag (int tag) false value])) ;; Constructors -(def None$ (V $None nil)) +(def None$ (V $None unit-tag)) (defn Some$ [x] (V $Some x)) -(def Nil$ (V $Nil nil)) +(def Nil$ (V $Nil unit-tag)) (defn Cons$ [h t] (V $Cons (T [h t]))) (def empty-cursor (T ["" -1 -1])) @@ -191,21 +192,17 @@ (defn transform-pattern [pattern] (cond (vector? pattern) (case (count pattern) 0 - nil + unit-tag 1 - (first pattern) + (transform-pattern (first pattern)) ;; else (conj (mapv transform-pattern pattern) '_)) - (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] - ['_ - (eval (first pattern)) - (case (count parts) - 0 nil - 1 (first parts) - ;; else - (conj parts '_))]) + (seq? pattern) ['_ + (eval (first pattern)) + '_ + (transform-pattern (vec (rest pattern)))] :else pattern )) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 8d748df53..31e0ca3a2 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -79,8 +79,8 @@ (&o/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?fn ?args) - (&o/$variant ?tag ?members) - (&&lux/compile-variant compile-expression ?tag ?members) + (&o/$variant ?tag ?tail ?members) + (&&lux/compile-variant compile-expression ?tag ?tail ?members) (&o/$case ?value ?match) (&&case/compile-case compile-expression ?value ?match) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 6ad21aef7..b046b237f 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -31,6 +31,7 @@ (def ^String output-package (str output-dir "/" "program.jar")) (def ^String function-class "lux/Function") (def ^String lux-utils-class "lux/LuxUtils") +(def ^String unit-tag-field "unit_tag") (def ^String sum-tag-field "sum_tag") (def ^String product-tag-field "product_tag") diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 314e7a6d3..1b0e023eb 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -23,6 +23,7 @@ ;; [Utils] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] + "(-> [MethodVisitor CaseAnalysis Label Label] Unit)" (|case ?match (&a-case/$StoreTestAC ?idx) (if (< ?idx 0) @@ -115,27 +116,27 @@ (.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)])))) + (let [$variant-else (new Label)] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int ?tag)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "sum_get" "([Ljava/lang/Object;I)Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/ACONST_NULL) + (.visitJumpInsn Opcodes/IF_ACMPEQ $variant-else) + (-> (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)]))) + (.visitLabel $variant-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else))) )) (defn ^:private separate-bodies [patterns] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index f4e7ab740..e7982a8ca 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -699,6 +699,8 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) full-name nil super-class (into-array String []))) + =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) + (.visitEnd)) =sum-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/sum-tag-field tag-sig nil &/sum-tag) (.visitEnd)) =product-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/product-tag-field tag-sig nil &/product-tag) @@ -768,7 +770,55 @@ (.visitInsn Opcodes/AALOAD) ;; elem (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) - (.visitEnd)))]] + (.visitEnd))) + =sum-get-method (let [$begin (new Label) + $then (new Label) + $further (new Label) + $not-right (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ILOAD 1) ;; tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum + (.visitLdcInsn (int 1)) ;; tag, sum, sum-tag-idx + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' + &&/unwrap-int ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $then) ;; tag, sum-tag + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitInsn Opcodes/POP2) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 3)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $further) ;; tag, sum-tag + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum + (.visitLdcInsn (int 2)) ;; tag, sum-tag, sum, last-index? + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last?' + &&/unwrap-boolean ;; tag, sum-tag, last? + (.visitJumpInsn Opcodes/IFEQ $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/ISUB) ;; sub-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum + (.visitLdcInsn (int 3)) ;; sub-tag, sum, sub-sum-idx + (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-right) ;; tag, sum-tag + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 31f2fdb8c..3c09f6362 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -58,7 +58,7 @@ :let [num-elems (&/|length ?elems)]] (|case num-elems 0 - (|do [:let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]] (return nil)) 1 @@ -83,10 +83,10 @@ (.visitInsn Opcodes/AASTORE))]] (return nil))))) -(defn compile-variant [compile ?tag ?value] +(defn compile-variant [compile ?tag tail? ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitLdcInsn (int 3)) + (.visitLdcInsn (int 4)) (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) @@ -94,11 +94,15 @@ (.visitInsn Opcodes/AASTORE) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)) - (.visitLdcInsn ?tag) - (&&/wrap-long) + (.visitLdcInsn (int ?tag)) + (&&/wrap-int) (.visitInsn Opcodes/AASTORE) (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 2)))] + (.visitLdcInsn (int 2)) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" (if tail? "TRUE" "FALSE") "Ljava/lang/Boolean;") + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 3)))] _ (compile ?value) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 1bfca2c1f..8a63aaa17 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -13,9 +13,9 @@ ;; [Utils] (defn ^:private variant$ [tag body] - "(-> Text Analysis Analysis)" + "(-> Int Analysis Analysis)" (&a/|meta &type/$Void &/empty-cursor - (&/V &a/$variant (&/T [tag body])))) + (&/V &a/$variant (&/T [tag false body])))) (defn ^:private tuple$ [members] "(-> (List Analysis) Analysis)" diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index b6de8091b..59f49d6a1 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -172,7 +172,7 @@ (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/T [meta (&/V nil)])))) + (return (&/T [meta (&/V &/unit-tag)])))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/type.clj b/src/lux/type.clj index 33c012806..cae91e588 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -47,8 +47,8 @@ (defn Named$ [name type] (&/V &/$NamedT (&/T [name type]))) -(def $Void (&/V &/$VoidT nil)) -(def Unit (&/V &/$UnitT nil)) +(def $Void (&/V &/$VoidT &/unit-tag)) +(def Unit (&/V &/$UnitT &/unit-tag)) (def Bool (Named$ (&/T ["lux" "Bool"]) (Data$ "java.lang.Boolean" &/Nil$))) (def Int (Named$ (&/T ["lux" "Int"]) (Data$ "java.lang.Long" &/Nil$))) (def Real (Named$ (&/T ["lux" "Real"]) (Data$ "java.lang.Double" &/Nil$))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index b06895945..ae225db1f 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -64,7 +64,7 @@ ;; [Exports] (let [class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+)|(\[+)([ZBSIJFDC]))" - Unit (&/V &/$UnitT nil) + Unit (&/V &/$UnitT &/unit-tag) jprim->lprim (fn [prim] (case prim "Z" "boolean" @@ -272,4 +272,4 @@ (instance? WildcardType gtype) (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] (gtype->gclass bound) - (&/V &/$GenericWildcard nil)))) + (&/V &/$GenericWildcard &/unit-tag)))) -- cgit v1.2.3