From 66ceed37b71921e14cae8a091df7738d9e587c2d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 7 Feb 2017 19:38:58 -0400 Subject: - Reorganized the code related to _lux_proc a bit. - Implemented some of the low-level machinery for 64-bit integers. --- luxc/src/lux/analyser.clj | 13 +- luxc/src/lux/analyser/jvm.clj | 1432 ------------------------------ luxc/src/lux/analyser/proc.clj | 285 ------ luxc/src/lux/analyser/proc/common.clj | 288 ++++++ luxc/src/lux/analyser/proc/jvm.clj | 1144 ++++++++++++++++++++++++ luxc/src/lux/base.clj | 10 +- luxc/src/lux/compiler/js.clj | 14 +- luxc/src/lux/compiler/js/base.clj | 56 +- luxc/src/lux/compiler/js/lux.clj | 6 +- luxc/src/lux/compiler/js/proc.clj | 364 -------- luxc/src/lux/compiler/js/proc/common.clj | 373 ++++++++ luxc/src/lux/compiler/js/rt.clj | 173 +++- luxc/src/lux/type.clj | 16 +- 13 files changed, 2016 insertions(+), 2158 deletions(-) delete mode 100644 luxc/src/lux/analyser/jvm.clj delete mode 100644 luxc/src/lux/analyser/proc.clj create mode 100644 luxc/src/lux/analyser/proc/common.clj create mode 100644 luxc/src/lux/analyser/proc/jvm.clj delete mode 100644 luxc/src/lux/compiler/js/proc.clj create mode 100644 luxc/src/lux/compiler/js/proc/common.clj diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 977911c28..f5a200cad 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -9,10 +9,10 @@ [host :as &host]) (lux.analyser [base :as &&] [lux :as &&lux] - [jvm :as &&jvm] - [proc :as &&proc] [module :as &&module] - [parser :as &&a-parser]))) + [parser :as &&a-parser]) + (lux.analyser.proc [common :as &&common] + [jvm :as &&jvm]))) ;; [Utils] (defn analyse-variant+ [analyse exo-type ident values] @@ -133,8 +133,11 @@ (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type - (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) - ;; (&&proc/analyse-proc analyse exo-type ?category ?proc ?args) + (case ?category + "jvm" (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) + ;; "js" + ;; common + (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) )) "_lux_:" diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj deleted file mode 100644 index 6146551ef..000000000 --- a/luxc/src/lux/analyser/jvm.clj +++ /dev/null @@ -1,1432 +0,0 @@ -(ns lux.analyser.jvm - (:require (clojure [template :refer [do-template]] - [string :as string]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type] - [host :as &host] - [lexer :as &lexer] - [parser :as &parser] - [reader :as &reader]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &&] - [lambda :as &&lambda] - [env :as &&env] - [parser :as &&a-parser]) - [lux.compiler.jvm.base :as &c!base]) - (:import (java.lang.reflect Type TypeVariable))) - -;; [Utils] -(defn ^:private ensure-catching [exceptions*] - "(-> (List Text) (Lux Null))" - (|do [class-loader &/loader] - (fn [state] - (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) - catching (->> state - (&/get$ &/$catching) - (&/|map #(Class/forName % true class-loader)))] - (if-let [missing-ex (&/fold (fn [prev ^Class now] - (or prev - (cond (or (.isAssignableFrom java.lang.RuntimeException now) - (.isAssignableFrom java.lang.Error now)) - nil - - (&/fold (fn [found? ^Class ex-catch] - (or found? - (.isAssignableFrom ex-catch now))) - false - catching) - nil - - :else - now))) - nil - exceptions)] - ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) - state) - (&/return* state nil))) - ))) - -(defn ^:private with-catches [catches body] - "(All [a] (-> (List Text) (Lux a) (Lux a)))" - (fn [state] - (let [old-catches (&/get$ &/$catching state) - state* (&/update$ &/$catching (partial &/|++ catches) state)] - (|case (&/run-state body state*) - (&/$Left msg) - (&/$Left msg) - - (&/$Right state** output) - (&/$Right (&/T [(&/set$ &/$catching old-catches state**) - output])))) - )) - -(defn ^:private ensure-object [type] - "(-> Type (Lux (, Text (List Type))))" - (|case type - (&/$HostT payload) - (return payload) - - (&/$VarT id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$ExT id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$NamedT _ type*) - (ensure-object type*) - - (&/$UnivQ _ type*) - (ensure-object type*) - - (&/$ExQ _ type*) - (ensure-object type*) - - (&/$AppT F A) - (|do [type* (&type/apply-type F A)] - (ensure-object type*)) - - _ - (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) - -(defn ^:private as-object [type] - "(-> Type Type)" - (|case type - (&/$HostT class params) - (&/$HostT (&host-type/as-obj class) params) - - _ - type)) - -(defn ^:private as-otype [tname] - (case tname - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - tname - )) - -(defn ^:private as-otype+ [type] - "(-> Type Type)" - (|case type - (&/$HostT name params) - (&/$HostT (as-otype name) params) - - _ - type)) - -(defn ^:private clean-gtype-var [idx gtype-var] - (|let [(&/$VarT id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T [idx real-type]))) - (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) - -(defn ^:private clean-gtype-vars [gtype-vars] - (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] - (|do [:let [[idx types] idx+types] - [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T [idx* (&/$Cons real-type types)])))) - (&/T [1 &/$Nil]) - gtype-vars)] - (return clean-types))) - -(defn ^:private make-gtype [class-name type-args] - "(-> Text (List Type) Type)" - (&/fold (fn [base-type type-arg] - (|case type-arg - (&/$BoundT _) - (&/$UnivQ &type/empty-env base-type) - - _ - base-type)) - (&/$HostT class-name type-args) - type-args)) - -;; [Resources] -(defn ^:private analyse-field-access-helper [obj-type gvars gtype] - "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" - (|case obj-type - (&/$HostT class targs) - (if (= (&/|length targs) (&/|length gvars)) - (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - gvars - targs)] - (&host-type/instance-param &type/existential gtype-env gtype)) - (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) - - _ - (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) - -(defn generic-class->simple-class [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar var-name) - "java.lang.Object" - - (&/$GenericWildcard _) - "java.lang.Object" - - (&/$GenericClass name params) - name - - (&/$GenericArray param) - (|case param - (&/$GenericArray _) - (str "[" (generic-class->simple-class param)) - - (&/$GenericClass "boolean" _) - "[Z" - - (&/$GenericClass "byte" _) - "[B" - - (&/$GenericClass "short" _) - "[S" - - (&/$GenericClass "int" _) - "[I" - - (&/$GenericClass "long" _) - "[J" - - (&/$GenericClass "float" _) - "[F" - - (&/$GenericClass "double" _) - "[D" - - (&/$GenericClass "char" _) - "[C" - - (&/$GenericClass name params) - (str "[L" name ";") - - (&/$GenericTypeVar var-name) - "[Ljava.lang.Object;" - - (&/$GenericWildcard _) - "[Ljava.lang.Object;") - )) - -(defn generic-class->type [env gclass] - "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" - (|case gclass - (&/$GenericTypeVar var-name) - (if-let [ex (&/|get var-name env)] - (return ex) - (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) - - (&/$GenericClass name params) - (case name - "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) - "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) - "short" (return (&/$HostT "java.lang.Short" &/$Nil)) - "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) - "long" (return (&/$HostT "java.lang.Long" &/$Nil)) - "float" (return (&/$HostT "java.lang.Float" &/$Nil)) - "double" (return (&/$HostT "java.lang.Double" &/$Nil)) - "char" (return (&/$HostT "java.lang.Character" &/$Nil)) - "void" (return &/$UnitT) - ;; else - (|do [=params (&/map% (partial generic-class->type env) params)] - (return (&/$HostT name =params)))) - - (&/$GenericArray param) - (|do [=param (generic-class->type env param)] - (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) - - (&/$GenericWildcard _) - (return (&/$ExQ &/$Nil (&/$BoundT 1))) - )) - -(defn gen-super-env [class-env supers class-decl] - "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" - (|let [[class-name class-vars] class-decl] - (|case (&/|some (fn [super] - (|let [[super-name super-params] super] - (if (= class-name super-name) - (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) - &/$None))) - supers) - (&/$None) - (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) - - (&/$Some vars+gtypes) - (&/map% (fn [var+gtype] - (|do [:let [[var gtype] var+gtype] - =gtype (generic-class->type class-env gtype)] - (return (&/T [var =gtype])))) - vars+gtypes) - ))) - -(defn ^:private make-type-env [type-params] - "(-> (List TypeParam) (Lux (List [Text Type])))" - (&/map% (fn [gvar] - (|do [:let [[gvar-name _] gvar] - ex &type/existential] - (return (&/T [gvar-name ex])))) - type-params)) - -(defn ^:private double-register-gclass? [gclass] - (|case gclass - (&/$GenericClass name _) - (|case name - "long" true - "double" true - _ false) - - _ - false)) - -(defn ^:private method-input-folder [full-env] - (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (if (double-register-gclass? itype*) - (&&env/with-local iname itype - (&&env/with-local "" &/$VoidT - body*)) - (&&env/with-local iname itype - body*))))) - -(defn ^:private analyse-method [analyse class-decl class-env all-supers method] - "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" - (|let [[?cname ?cparams] class-decl - class-type (&/$HostT ?cname (&/|map &/|second class-env))] - (|case method - (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - :let [output-type &/$UnitT] - =ctor-args (&/map% (fn [ctor-arg] - (|do [:let [[ca-type ca-term] ctor-arg] - =ca-type (generic-class->type full-env ca-type) - =ca-term (&&/analyse-1 analyse =ca-type ca-term)] - (return (&/T [ca-type =ca-term])))) - ?ctor-args) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) - - (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [super-env (gen-super-env class-env all-supers ?class-decl) - method-env (make-type-env ?gvars) - :let [full-env (&/|++ super-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env method-env] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs)))))] - (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - - (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - ))) - -(defn ^:private mandatory-methods [supers] - (|do [class-loader &/loader] - (&/flat-map% (partial &host/abstract-methods class-loader) supers))) - -(defn ^:private check-method-completion [supers methods] - "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" - (|do [abstract-methods (mandatory-methods supers) - :let [methods-map (&/fold (fn [mmap mentry] - (|case mentry - (&/$ConstructorMethodAnalysis _) - mmap - - (&/$VirtualMethodAnalysis _) - mmap - - (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) - - (&/$StaticMethodAnalysis _) - mmap - - (&/$AbstractMethodSyntax _) - mmap - - (&/$NativeMethodSyntax _) - mmap - )) - {} - methods) - missing-method (&/fold (fn [missing abs-meth] - (or missing - (|let [[am-name am-inputs] abs-meth] - (if-let [meth-struct (get methods-map am-name)] - (if (some (fn [=inputs] - (and (= (&/|length =inputs) (&/|length am-inputs)) - (&/fold2 (fn [prev mi ai] - (|let [[iname itype] mi] - (and prev (= (generic-class->simple-class itype) ai)))) - true - =inputs am-inputs))) - meth-struct) - nil - abs-meth) - abs-meth)))) - nil - abstract-methods)]] - (if (nil? missing-method) - (return nil) - (|let [[am-name am-inputs] missing-method] - (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) - -(defn ^:private analyse-field [analyse gtype-env field] - "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) - =value (&&/analyse-1 analyse =gtype ?value)] - (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) - - (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) - (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) - )) - -(do-template [ ] - (let [output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type _?value] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - =value (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) - - ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" - ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" - ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" - - ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" - ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" - ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" - - ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" - ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" - ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" - ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" - ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" - - ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" - ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" - ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" - ^:private analyse-jvm-l2s "l2s" "java.lang.Long" "java.lang.Short" - ^:private analyse-jvm-l2b "l2b" "java.lang.Long" "java.lang.Byte" - - ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" - ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" - ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" - ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" - - ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" - - ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" - ) - -(do-template [ ] - (let [output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] - =value1 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value1) - =value2 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value2) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) - - ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - - ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ) - -(do-template [ ] - (let [input-type (&/$HostT &/$Nil) - output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse input-type x) - =y (&&/analyse-1 analyse input-type y) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) - - ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" - ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" - ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" - - ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" - ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" - ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" - - ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" - ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" - ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" - - ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" - ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" - ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" - - ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" - ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" - ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" - ) - -(let [length-type &type/Nat - idx-type &type/Nat] - (do-template [ ] - (let [elem-type (&/$HostT &/$Nil) - array-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) - - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type elem-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) - - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) - ) - - "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" - "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" - "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" - "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" - "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" - "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" - "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" - "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" - )) - -(defn ^:private array-class? [class-name] - (or (= &host-type/array-data-tag class-name) - (case class-name - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true - ;; else - false))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] - gclass (&reader/with-source "jvm-anewarray" _gclass - &&a-parser/parse-gclass) - gtype-env &/get-type-env - =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) - :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type inner-arr-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse inner-arr-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Nil)) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) - ))))) - -(defn ^:private analyse-jvm-null? [analyse exo-type ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) - -(defn ^:private analyse-jvm-null [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) - -(defn analyse-jvm-synchronized [analyse exo-type ?values] - (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] - =monitor (&&/analyse-1+ analyse ?monitor) - _ (ensure-object (&&/expr-type* =monitor)) - =expr (&&/analyse-1 analyse exo-type ?expr) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) - -(defn ^:private analyse-jvm-throw [analyse exo-type ?values] - (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] - =ex (&&/analyse-1+ analyse ?ex) - _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) - [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) - _ (ensure-catching (&/|list throw-class)) - _cursor &/cursor - _ (&type/check exo-type &type/Bottom)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) - -(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Nil) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - =type (&host-type/instance-param &type/existential &/$Nil gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) - -(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object (&/$Nil)) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - [gvars gtype] (&host/lookup-field class-loader !class! field) - =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) - -(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons value (&/$Nil)) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (&host-type/instance-param &type/existential &/$Nil gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) - -(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - :let [obj-type (&&/expr-type* =object)] - _ (ensure-object obj-type) - [gvars gtype] (&host/lookup-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (analyse-field-access-helper obj-type gvars gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) - -(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =arg-types (&/map% &type/show-type+ arg-types) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - =gret (&host-type/instance-param &type/existential gtype-env gret) - _ (&type/check exo-type (as-otype+ =gret))] - (return (&/T [=gret =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [(&/$VarT _id) $var - gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] - (do-template [ ] - (defn [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object args) ?values] - class-loader &/loader - _ (try (assert! (let [=class (Class/forName !class! true class-loader)] - (= (.isInterface =class))) - (if - (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") - (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) - [gret exceptions parent-gvars gvars gargs] (if (= "" method) - (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) - (&host/lookup-virtual-method class-loader !class! method classes)) - _ (ensure-catching exceptions) - =object (&&/analyse-1+ analyse object) - [sub-class sub-params] (ensure-object (&&/expr-type* =object)) - (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) - !class! - sub-class) - sub-params) - :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - parent-gvars - super-params*)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) - - ^:private analyse-jvm-invokevirtual "invokevirtual" false - ^:private analyse-jvm-invokespecial "invokespecial" false - ^:private analyse-jvm-invokeinterface "invokeinterface" true - )) - -(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) - _ (ensure-catching exceptions) - :let [gtype-env (&/|table)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) - -(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] - (return (&/T [(make-gtype gtype gtype-vars*) - =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) - _ (ensure-catching exceptions) - [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) - -(defn ^:private analyse-jvm-try [analyse exo-type ?values] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] - =body (with-catches (&/|list "java.lang.Exception") - (&&/analyse-1 analyse exo-type ?body)) - =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) - -(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) - -(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] - ^ClassLoader class-loader &/loader - _ (try (do (.loadClass class-loader _class-name) - (return nil)) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) - :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-array-new [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) - array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] - gtype-env &/get-type-env - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-array-get [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-array-remove [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _cursor &/cursor - :let [=elem (&&/|meta inner-arr-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] - _ (&type/check exo-type array-type)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] - (|do [module &/get-module-name - _ (compile-interface interface-decl supers =anns =methods) - :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] - _cursor &/cursor] - (return (&/|list (&&/|meta &/$UnitT _cursor - (&&/$tuple (&/|list))))))) - -(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] - (&/with-closure - (|do [module &/get-module-name - :let [[?name ?params] class-decl - full-name (str (string/replace module "/" ".") "." ?name) - class-decl* (&/T [full-name ?params]) - all-supers (&/$Cons super-class interfaces)] - class-env (make-type-env ?params) - =fields (&/map% (partial analyse-field analyse class-env) ?fields) - _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) - =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) - _ &/pop-dummy-name - :let [_ (println 'CLASS full-name)] - _cursor &/cursor] - (return (&/|list (&&/|meta &/$UnitT _cursor - (&&/$tuple (&/|list)))))))) - -(defn ^:private captured-source [env-entry] - (|case env-entry - [name [_ (&&/$captured _ _ source)]] - source)) - -(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM - false - &/$Nil - &/$Nil - &/$Nil - &/$Nil - &/$Nil - (&/$TupleS &/$Nil)])) - captured-slot-class "java.lang.Object" - captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] - (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] - (&/with-closure - (|do [module &/get-module-name - scope &/get-scope-name - :let [name (->> scope &/|reverse &/|tail &host/location) - class-decl (&/T [name &/$Nil]) - anon-class (str (string/replace module "/" ".") "." name) - anon-class-type (&/$HostT anon-class &/$Nil)] - =ctor-args (&/map% (fn [ctor-arg] - (|let [[arg-type arg-term] ctor-arg] - (|do [=arg-term (&&/analyse-1+ analyse arg-term)] - (return (&/T [arg-type =arg-term]))))) - ctor-args) - _ (->> methods - (&/$Cons default-) - (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) - :let [all-supers (&/$Cons super-class interfaces) - class-env &/$Nil] - =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - =captured &&env/captured-vars - :let [=fields (&/|map (fn [^objects idx+capt] - (|let [[idx _] idx+capt] - (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) - &/$PublicPM - &/$FinalSM - &/$Nil - captured-slot-type))) - (&/enumerate =captured))] - :let [sources (&/|map captured-source =captured)] - _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) - _ &/pop-dummy-name - _cursor &/cursor] - (return (&/|list (&&/|meta anon-class-type _cursor - (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) - ))) - )))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] - =mask (&&/analyse-1 analyse &type/Nat mask) - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) - - ^:private analyse-bit-and "and" - ^:private analyse-bit-or "or" - ^:private analyse-bit-xor "xor" - ) - -(defn ^:private analyse-bit-count [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Nil)) ?values] - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] - =shift (&&/analyse-1 analyse &type/Nat shift) - =input (&&/analyse-1 analyse input) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) - - ^:private analyse-bit-shift-left "shift-left" &type/Nat - ^:private analyse-bit-shift-right "shift-right" &type/Int - ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat - ) - -(defn ^:private analyse-lux-== [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] - =left (&&/analyse-1 analyse $var left) - =right (&&/analyse-1 analyse $var right) - _ (&type/check exo-type &type/Bool) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat - ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat - ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat - ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat - ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat - ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool - ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool - - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-int-add ["int" "+"] &type/Int &type/Int - ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int - ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int - ^:private analyse-int-div ["int" "/"] &type/Int &type/Int - ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int - ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool - ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool - - ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg - ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg - ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg - ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg - ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg - ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool - ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool - - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-real-add ["real" "+"] &type/Real &type/Real - ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real - ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real - ^:private analyse-real-div ["real" "/"] &type/Real &type/Real - ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real - ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool - ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool - ) - -(defn ^:private analyse-deg-scale [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse &type/Deg x) - =y (&&/analyse-1 analyse &type/Nat y) - _ (&type/check exo-type &type/Deg) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Deg _cursor - (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) - -(do-template [ ] - (do (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type &type/Text) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - (let [decode-type (&/$AppT &type/Maybe )] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse &type/Text x) - _ (&type/check exo-type decode-type) - _cursor &/cursor] - (return (&/|list (&&/|meta decode-type _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) - - ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int - ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list) (&/|list))))))) - - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] - - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-int-min-value &type/Int ["int" "min-value"] - ^:private analyse-int-max-value &type/Int ["int" "max-value"] - - ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] - ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] - - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-real-min-value &type/Real ["real" "min-value"] - ^:private analyse-real-max-value &type/Real ["real" "max-value"] - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] - - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ) - -;; TODO: USE COMMON PROC ANALYSIS -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool - ^:private analyse-text-append ["text" "append"] &type/Text &type/Text - ) -;; TODO: USE COMMON PROC ANALYSIS - -(defn analyse-host [analyse exo-type compilers category proc ?values] - (|let [[_ _ _ compile-class compile-interface] compilers] - (case category - "lux" - (case proc - "==" (analyse-lux-== analyse exo-type ?values)) - - "text" - (case proc - "=" (analyse-text-eq analyse exo-type ?values) - "append" (analyse-text-append analyse exo-type ?values)) - - "bit" - (case proc - "count" (analyse-bit-count analyse exo-type ?values) - "and" (analyse-bit-and analyse exo-type ?values) - "or" (analyse-bit-or analyse exo-type ?values) - "xor" (analyse-bit-xor analyse exo-type ?values) - "shift-left" (analyse-bit-shift-left analyse exo-type ?values) - "shift-right" (analyse-bit-shift-right analyse exo-type ?values) - "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) - - "array" - (case proc - "new" (analyse-array-new analyse exo-type ?values) - "get" (analyse-array-get analyse exo-type ?values) - "put" (analyse-jvm-aastore analyse exo-type ?values) - "remove" (analyse-array-remove analyse exo-type ?values) - "size" (analyse-jvm-arraylength analyse exo-type ?values)) - - "nat" - (case proc - "+" (analyse-nat-add analyse exo-type ?values) - "-" (analyse-nat-sub analyse exo-type ?values) - "*" (analyse-nat-mul analyse exo-type ?values) - "/" (analyse-nat-div analyse exo-type ?values) - "%" (analyse-nat-rem analyse exo-type ?values) - "=" (analyse-nat-eq analyse exo-type ?values) - "<" (analyse-nat-lt analyse exo-type ?values) - "encode" (analyse-nat-encode analyse exo-type ?values) - "decode" (analyse-nat-decode analyse exo-type ?values) - "min-value" (analyse-nat-min-value analyse exo-type ?values) - "max-value" (analyse-nat-max-value analyse exo-type ?values) - "to-int" (analyse-nat-to-int analyse exo-type ?values) - "to-char" (analyse-nat-to-char analyse exo-type ?values) - ) - - "deg" - (case proc - "+" (analyse-deg-add analyse exo-type ?values) - "-" (analyse-deg-sub analyse exo-type ?values) - "*" (analyse-deg-mul analyse exo-type ?values) - "/" (analyse-deg-div analyse exo-type ?values) - "%" (analyse-deg-rem analyse exo-type ?values) - "=" (analyse-deg-eq analyse exo-type ?values) - "<" (analyse-deg-lt analyse exo-type ?values) - "encode" (analyse-deg-encode analyse exo-type ?values) - "decode" (analyse-deg-decode analyse exo-type ?values) - "min-value" (analyse-deg-min-value analyse exo-type ?values) - "max-value" (analyse-deg-max-value analyse exo-type ?values) - "to-real" (analyse-deg-to-real analyse exo-type ?values) - "scale" (analyse-deg-scale analyse exo-type ?values) - ) - - "int" - (case proc - "+" (analyse-int-add analyse exo-type ?values) - "-" (analyse-int-sub analyse exo-type ?values) - "*" (analyse-int-mul analyse exo-type ?values) - "/" (analyse-int-div analyse exo-type ?values) - "%" (analyse-int-rem analyse exo-type ?values) - "=" (analyse-int-eq analyse exo-type ?values) - "<" (analyse-int-lt analyse exo-type ?values) - "encode" (analyse-int-encode analyse exo-type ?values) - "decode" (analyse-int-decode analyse exo-type ?values) - "min-value" (analyse-int-min-value analyse exo-type ?values) - "max-value" (analyse-int-max-value analyse exo-type ?values) - "to-nat" (analyse-int-to-nat analyse exo-type ?values) - ) - - "real" - (case proc - "+" (analyse-real-add analyse exo-type ?values) - "-" (analyse-real-sub analyse exo-type ?values) - "*" (analyse-real-mul analyse exo-type ?values) - "/" (analyse-real-div analyse exo-type ?values) - "%" (analyse-real-rem analyse exo-type ?values) - "=" (analyse-real-eq analyse exo-type ?values) - "<" (analyse-real-lt analyse exo-type ?values) - "encode" (analyse-real-encode analyse exo-type ?values) - "decode" (analyse-real-decode analyse exo-type ?values) - "min-value" (analyse-real-min-value analyse exo-type ?values) - "max-value" (analyse-real-max-value analyse exo-type ?values) - "to-deg" (analyse-real-to-deg analyse exo-type ?values) - ) - - "char" - (case proc - "to-nat" (analyse-char-to-nat analyse exo-type ?values) - ) - - "jvm" - (case proc - "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) - "load-class" (analyse-jvm-load-class analyse exo-type ?values) - "try" (analyse-jvm-try analyse exo-type ?values) - "throw" (analyse-jvm-throw analyse exo-type ?values) - "null?" (analyse-jvm-null? analyse exo-type ?values) - "null" (analyse-jvm-null analyse exo-type ?values) - "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) - "aaload" (analyse-jvm-aaload analyse exo-type ?values) - "aastore" (analyse-jvm-aastore analyse exo-type ?values) - "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) - "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) - "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) - "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) - "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) - "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) - "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) - "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) - "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) - "iadd" (analyse-jvm-iadd analyse exo-type ?values) - "isub" (analyse-jvm-isub analyse exo-type ?values) - "imul" (analyse-jvm-imul analyse exo-type ?values) - "idiv" (analyse-jvm-idiv analyse exo-type ?values) - "irem" (analyse-jvm-irem analyse exo-type ?values) - "ieq" (analyse-jvm-ieq analyse exo-type ?values) - "ilt" (analyse-jvm-ilt analyse exo-type ?values) - "igt" (analyse-jvm-igt analyse exo-type ?values) - "ceq" (analyse-jvm-ceq analyse exo-type ?values) - "clt" (analyse-jvm-clt analyse exo-type ?values) - "cgt" (analyse-jvm-cgt analyse exo-type ?values) - "ladd" (analyse-jvm-ladd analyse exo-type ?values) - "lsub" (analyse-jvm-lsub analyse exo-type ?values) - "lmul" (analyse-jvm-lmul analyse exo-type ?values) - "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) - "lrem" (analyse-jvm-lrem analyse exo-type ?values) - "leq" (analyse-jvm-leq analyse exo-type ?values) - "llt" (analyse-jvm-llt analyse exo-type ?values) - "lgt" (analyse-jvm-lgt analyse exo-type ?values) - "fadd" (analyse-jvm-fadd analyse exo-type ?values) - "fsub" (analyse-jvm-fsub analyse exo-type ?values) - "fmul" (analyse-jvm-fmul analyse exo-type ?values) - "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) - "frem" (analyse-jvm-frem analyse exo-type ?values) - "feq" (analyse-jvm-feq analyse exo-type ?values) - "flt" (analyse-jvm-flt analyse exo-type ?values) - "fgt" (analyse-jvm-fgt analyse exo-type ?values) - "dadd" (analyse-jvm-dadd analyse exo-type ?values) - "dsub" (analyse-jvm-dsub analyse exo-type ?values) - "dmul" (analyse-jvm-dmul analyse exo-type ?values) - "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) - "drem" (analyse-jvm-drem analyse exo-type ?values) - "deq" (analyse-jvm-deq analyse exo-type ?values) - "dlt" (analyse-jvm-dlt analyse exo-type ?values) - "dgt" (analyse-jvm-dgt analyse exo-type ?values) - "iand" (analyse-jvm-iand analyse exo-type ?values) - "ior" (analyse-jvm-ior analyse exo-type ?values) - "ixor" (analyse-jvm-ixor analyse exo-type ?values) - "ishl" (analyse-jvm-ishl analyse exo-type ?values) - "ishr" (analyse-jvm-ishr analyse exo-type ?values) - "iushr" (analyse-jvm-iushr analyse exo-type ?values) - "land" (analyse-jvm-land analyse exo-type ?values) - "lor" (analyse-jvm-lor analyse exo-type ?values) - "lxor" (analyse-jvm-lxor analyse exo-type ?values) - "lshl" (analyse-jvm-lshl analyse exo-type ?values) - "lshr" (analyse-jvm-lshr analyse exo-type ?values) - "lushr" (analyse-jvm-lushr analyse exo-type ?values) - "d2f" (analyse-jvm-d2f analyse exo-type ?values) - "d2i" (analyse-jvm-d2i analyse exo-type ?values) - "d2l" (analyse-jvm-d2l analyse exo-type ?values) - "f2d" (analyse-jvm-f2d analyse exo-type ?values) - "f2i" (analyse-jvm-f2i analyse exo-type ?values) - "f2l" (analyse-jvm-f2l analyse exo-type ?values) - "i2b" (analyse-jvm-i2b analyse exo-type ?values) - "i2c" (analyse-jvm-i2c analyse exo-type ?values) - "i2d" (analyse-jvm-i2d analyse exo-type ?values) - "i2f" (analyse-jvm-i2f analyse exo-type ?values) - "i2l" (analyse-jvm-i2l analyse exo-type ?values) - "i2s" (analyse-jvm-i2s analyse exo-type ?values) - "l2d" (analyse-jvm-l2d analyse exo-type ?values) - "l2f" (analyse-jvm-l2f analyse exo-type ?values) - "l2i" (analyse-jvm-l2i analyse exo-type ?values) - "l2s" (analyse-jvm-l2s analyse exo-type ?values) - "l2b" (analyse-jvm-l2b analyse exo-type ?values) - "c2b" (analyse-jvm-c2b analyse exo-type ?values) - "c2s" (analyse-jvm-c2s analyse exo-type ?values) - "c2i" (analyse-jvm-c2i analyse exo-type ?values) - "c2l" (analyse-jvm-c2l analyse exo-type ?values) - "b2l" (analyse-jvm-b2l analyse exo-type ?values) - "s2l" (analyse-jvm-s2l analyse exo-type ?values) - ;; else - (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) - (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] - (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) - - (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] - (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) - - (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] - (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) - - (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] - (analyse-jvm-instanceof analyse exo-type _class ?values)) - - (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] - (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getfield analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putfield analyse exo-type _class _field ?values)))) - - ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/luxc/src/lux/analyser/proc.clj b/luxc/src/lux/analyser/proc.clj deleted file mode 100644 index a71a1a9e5..000000000 --- a/luxc/src/lux/analyser/proc.clj +++ /dev/null @@ -1,285 +0,0 @@ -(ns lux.analyser.proc - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type]) - (lux.analyser [base :as &&]))) - -(defn ^:private analyse-lux-== [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] - =left (&&/analyse-1 analyse $var left) - =right (&&/analyse-1 analyse $var right) - _ (&type/check exo-type &type/Bool) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool - ^:private analyse-text-append ["text" "append"] &type/Text &type/Text - ) - -;; (do-template [ ] -;; (defn [analyse exo-type ?values] -;; (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] -;; =mask (&&/analyse-1 analyse &type/Nat mask) -;; =input (&&/analyse-1 analyse &type/Nat input) -;; _ (&type/check exo-type &type/Nat) -;; _cursor &/cursor] -;; (return (&/|list (&&/|meta exo-type _cursor -;; (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) - -;; ^:private analyse-bit-and "and" -;; ^:private analyse-bit-or "or" -;; ^:private analyse-bit-xor "xor" -;; ) - -;; (defn ^:private analyse-bit-count [analyse exo-type ?values] -;; (|do [:let [(&/$Cons input (&/$Nil)) ?values] -;; =input (&&/analyse-1 analyse &type/Nat input) -;; _ (&type/check exo-type &type/Nat) -;; _cursor &/cursor] -;; (return (&/|list (&&/|meta exo-type _cursor -;; (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) - -;; (do-template [ ] -;; (defn [analyse exo-type ?values] -;; (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] -;; =shift (&&/analyse-1 analyse &type/Nat shift) -;; =input (&&/analyse-1 analyse input) -;; _ (&type/check exo-type ) -;; _cursor &/cursor] -;; (return (&/|list (&&/|meta exo-type _cursor -;; (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) - -;; ^:private analyse-bit-shift-left "shift-left" &type/Nat -;; ^:private analyse-bit-shift-right "shift-right" &type/Int -;; ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat -;; ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat - ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat - ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat - ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat - ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat - ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool - ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool - - ^:private analyse-int-add ["int" "+"] &type/Int &type/Int - ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int - ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int - ^:private analyse-int-div ["int" "/"] &type/Int &type/Int - ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int - ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool - ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool - - ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg - ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg - ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg - ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg - ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg - ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool - ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool - - ^:private analyse-real-add ["real" "+"] &type/Real &type/Real - ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real - ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real - ^:private analyse-real-div ["real" "/"] &type/Real &type/Real - ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real - ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool - ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool - ) - -(defn ^:private analyse-deg-scale [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse &type/Deg x) - =y (&&/analyse-1 analyse &type/Nat y) - _ (&type/check exo-type &type/Deg) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Deg _cursor - (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) - -(do-template [ ] - (do (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type &type/Text) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - (let [decode-type (&/$AppT &type/Maybe )] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse &type/Text x) - _ (&type/check exo-type decode-type) - _cursor &/cursor] - (return (&/|list (&&/|meta decode-type _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) - - ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat - ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int - ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg - ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list) (&/|list))))))) - - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] - - ^:private analyse-int-min-value &type/Int ["int" "min-value"] - ^:private analyse-int-max-value &type/Int ["int" "max-value"] - - ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] - ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] - - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ) - -(defn analyse-proc [analyse exo-type category proc ?values] - (case category - ;; "lux" - ;; (case proc - ;; "==" (analyse-lux-== analyse exo-type ?values)) - - "text" - (case proc - "=" (analyse-text-eq analyse exo-type ?values) - "append" (analyse-text-append analyse exo-type ?values)) - - ;; "bit" - ;; (case proc - ;; "count" (analyse-bit-count analyse exo-type ?values) - ;; "and" (analyse-bit-and analyse exo-type ?values) - ;; "or" (analyse-bit-or analyse exo-type ?values) - ;; "xor" (analyse-bit-xor analyse exo-type ?values) - ;; "shift-left" (analyse-bit-shift-left analyse exo-type ?values) - ;; "shift-right" (analyse-bit-shift-right analyse exo-type ?values) - ;; "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) - - ;; "array" - ;; (case proc - ;; "new" (analyse-array-new analyse exo-type ?values) - ;; "get" (analyse-array-get analyse exo-type ?values) - ;; "put" (analyse-jvm-aastore analyse exo-type ?values) - ;; "remove" (analyse-array-remove analyse exo-type ?values) - ;; "size" (analyse-jvm-arraylength analyse exo-type ?values)) - - "nat" - (case proc - "+" (analyse-nat-add analyse exo-type ?values) - "-" (analyse-nat-sub analyse exo-type ?values) - "*" (analyse-nat-mul analyse exo-type ?values) - "/" (analyse-nat-div analyse exo-type ?values) - "%" (analyse-nat-rem analyse exo-type ?values) - "=" (analyse-nat-eq analyse exo-type ?values) - "<" (analyse-nat-lt analyse exo-type ?values) - "encode" (analyse-nat-encode analyse exo-type ?values) - "decode" (analyse-nat-decode analyse exo-type ?values) - "min-value" (analyse-nat-min-value analyse exo-type ?values) - "max-value" (analyse-nat-max-value analyse exo-type ?values) - "to-int" (analyse-nat-to-int analyse exo-type ?values) - "to-char" (analyse-nat-to-char analyse exo-type ?values) - ) - - "int" - (case proc - "+" (analyse-int-add analyse exo-type ?values) - "-" (analyse-int-sub analyse exo-type ?values) - "*" (analyse-int-mul analyse exo-type ?values) - "/" (analyse-int-div analyse exo-type ?values) - "%" (analyse-int-rem analyse exo-type ?values) - "=" (analyse-int-eq analyse exo-type ?values) - "<" (analyse-int-lt analyse exo-type ?values) - "encode" (analyse-int-encode analyse exo-type ?values) - "decode" (analyse-int-decode analyse exo-type ?values) - "min-value" (analyse-int-min-value analyse exo-type ?values) - "max-value" (analyse-int-max-value analyse exo-type ?values) - "to-nat" (analyse-int-to-nat analyse exo-type ?values) - ) - - "deg" - (case proc - "+" (analyse-deg-add analyse exo-type ?values) - "-" (analyse-deg-sub analyse exo-type ?values) - "*" (analyse-deg-mul analyse exo-type ?values) - "/" (analyse-deg-div analyse exo-type ?values) - "%" (analyse-deg-rem analyse exo-type ?values) - "=" (analyse-deg-eq analyse exo-type ?values) - "<" (analyse-deg-lt analyse exo-type ?values) - ;; "encode" (analyse-deg-encode analyse exo-type ?values) - ;; "decode" (analyse-deg-decode analyse exo-type ?values) - ;; "min-value" (analyse-deg-min-value analyse exo-type ?values) - ;; "max-value" (analyse-deg-max-value analyse exo-type ?values) - ;; "to-real" (analyse-deg-to-real analyse exo-type ?values) - ;; "scale" (analyse-deg-scale analyse exo-type ?values) - ) - - "real" - (case proc - "+" (analyse-real-add analyse exo-type ?values) - "-" (analyse-real-sub analyse exo-type ?values) - "*" (analyse-real-mul analyse exo-type ?values) - "/" (analyse-real-div analyse exo-type ?values) - "%" (analyse-real-rem analyse exo-type ?values) - "=" (analyse-real-eq analyse exo-type ?values) - "<" (analyse-real-lt analyse exo-type ?values) - "encode" (analyse-real-encode analyse exo-type ?values) - ;; "decode" (analyse-real-decode analyse exo-type ?values) - ;; "min-value" (analyse-real-min-value analyse exo-type ?values) - ;; "max-value" (analyse-real-max-value analyse exo-type ?values) - ;; "to-deg" (analyse-real-to-real analyse exo-type ?values) - ) - - ;; "char" - ;; (case proc - ;; "to-nat" (analyse-char-to-nat analyse exo-type ?values) - ;; ) - - ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj new file mode 100644 index 000000000..f6d1eef8e --- /dev/null +++ b/luxc/src/lux/analyser/proc/common.clj @@ -0,0 +1,288 @@ +(ns lux.analyser.proc.common + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type]) + (lux.analyser [base :as &&]))) + +(defn ^:private analyse-lux-== [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] + =left (&&/analyse-1 analyse $var left) + =right (&&/analyse-1 analyse $var right) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-append ["text" "append"] &type/Text &type/Text + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] + =mask (&&/analyse-1 analyse &type/Nat mask) + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) + + ^:private analyse-bit-and "and" + ^:private analyse-bit-or "or" + ^:private analyse-bit-xor "xor" + ) + +(defn ^:private analyse-bit-count [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] + =shift (&&/analyse-1 analyse &type/Nat shift) + =input (&&/analyse-1 analyse input) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) + + ^:private analyse-bit-shift-left "shift-left" &type/Nat + ^:private analyse-bit-shift-right "shift-right" &type/Int + ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat + ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat + ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat + ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat + ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat + ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool + ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + + ^:private analyse-int-add ["int" "+"] &type/Int &type/Int + ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int + ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int + ^:private analyse-int-div ["int" "/"] &type/Int &type/Int + ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int + ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool + ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool + + ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg + ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg + ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg + ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg + ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg + ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool + ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool + + ^:private analyse-real-add ["real" "+"] &type/Real &type/Real + ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real + ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real + ^:private analyse-real-div ["real" "/"] &type/Real &type/Real + ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real + ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool + ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool + ) + +(defn ^:private analyse-deg-scale [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse &type/Deg x) + =y (&&/analyse-1 analyse &type/Nat y) + _ (&type/check exo-type &type/Deg) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Deg _cursor + (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) + +(do-template [ ] + (do (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe )] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _cursor &/cursor] + (return (&/|list (&&/|meta decode-type _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) + + ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int + ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg + ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list) (&/|list))))))) + + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + + ^:private analyse-int-min-value &type/Int ["int" "min-value"] + ^:private analyse-int-max-value &type/Int ["int" "max-value"] + + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] + ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + + ^:private analyse-real-min-value &type/Real ["real" "min-value"] + ^:private analyse-real-max-value &type/Real ["real" "max-value"] + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ) + +(defn analyse-proc [analyse exo-type category proc ?values] + (case category + "lux" + (case proc + "==" (analyse-lux-== analyse exo-type ?values)) + + "text" + (case proc + "=" (analyse-text-eq analyse exo-type ?values) + "append" (analyse-text-append analyse exo-type ?values)) + + "bit" + (case proc + "count" (analyse-bit-count analyse exo-type ?values) + "and" (analyse-bit-and analyse exo-type ?values) + "or" (analyse-bit-or analyse exo-type ?values) + "xor" (analyse-bit-xor analyse exo-type ?values) + "shift-left" (analyse-bit-shift-left analyse exo-type ?values) + "shift-right" (analyse-bit-shift-right analyse exo-type ?values) + "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) + + ;; "array" + ;; (case proc + ;; "new" (analyse-array-new analyse exo-type ?values) + ;; "get" (analyse-array-get analyse exo-type ?values) + ;; "put" (analyse-jvm-aastore analyse exo-type ?values) + ;; "remove" (analyse-array-remove analyse exo-type ?values) + ;; "size" (analyse-array-size analyse exo-type ?values)) + + "nat" + (case proc + "+" (analyse-nat-add analyse exo-type ?values) + "-" (analyse-nat-sub analyse exo-type ?values) + "*" (analyse-nat-mul analyse exo-type ?values) + "/" (analyse-nat-div analyse exo-type ?values) + "%" (analyse-nat-rem analyse exo-type ?values) + "=" (analyse-nat-eq analyse exo-type ?values) + "<" (analyse-nat-lt analyse exo-type ?values) + "encode" (analyse-nat-encode analyse exo-type ?values) + "decode" (analyse-nat-decode analyse exo-type ?values) + "min-value" (analyse-nat-min-value analyse exo-type ?values) + "max-value" (analyse-nat-max-value analyse exo-type ?values) + "to-int" (analyse-nat-to-int analyse exo-type ?values) + "to-char" (analyse-nat-to-char analyse exo-type ?values) + ) + + "int" + (case proc + "+" (analyse-int-add analyse exo-type ?values) + "-" (analyse-int-sub analyse exo-type ?values) + "*" (analyse-int-mul analyse exo-type ?values) + "/" (analyse-int-div analyse exo-type ?values) + "%" (analyse-int-rem analyse exo-type ?values) + "=" (analyse-int-eq analyse exo-type ?values) + "<" (analyse-int-lt analyse exo-type ?values) + "encode" (analyse-int-encode analyse exo-type ?values) + "decode" (analyse-int-decode analyse exo-type ?values) + "min-value" (analyse-int-min-value analyse exo-type ?values) + "max-value" (analyse-int-max-value analyse exo-type ?values) + "to-nat" (analyse-int-to-nat analyse exo-type ?values) + ) + + "deg" + (case proc + "+" (analyse-deg-add analyse exo-type ?values) + "-" (analyse-deg-sub analyse exo-type ?values) + "*" (analyse-deg-mul analyse exo-type ?values) + "/" (analyse-deg-div analyse exo-type ?values) + "%" (analyse-deg-rem analyse exo-type ?values) + "=" (analyse-deg-eq analyse exo-type ?values) + "<" (analyse-deg-lt analyse exo-type ?values) + "encode" (analyse-deg-encode analyse exo-type ?values) + "decode" (analyse-deg-decode analyse exo-type ?values) + "min-value" (analyse-deg-min-value analyse exo-type ?values) + "max-value" (analyse-deg-max-value analyse exo-type ?values) + "to-real" (analyse-deg-to-real analyse exo-type ?values) + "scale" (analyse-deg-scale analyse exo-type ?values) + ) + + "real" + (case proc + "+" (analyse-real-add analyse exo-type ?values) + "-" (analyse-real-sub analyse exo-type ?values) + "*" (analyse-real-mul analyse exo-type ?values) + "/" (analyse-real-div analyse exo-type ?values) + "%" (analyse-real-rem analyse exo-type ?values) + "=" (analyse-real-eq analyse exo-type ?values) + "<" (analyse-real-lt analyse exo-type ?values) + "encode" (analyse-real-encode analyse exo-type ?values) + "decode" (analyse-real-decode analyse exo-type ?values) + "min-value" (analyse-real-min-value analyse exo-type ?values) + "max-value" (analyse-real-max-value analyse exo-type ?values) + "to-deg" (analyse-real-to-deg analyse exo-type ?values) + ) + + "char" + (case proc + "to-nat" (analyse-char-to-nat analyse exo-type ?values) + ) + + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/analyser/proc/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj new file mode 100644 index 000000000..480cb341a --- /dev/null +++ b/luxc/src/lux/analyser/proc/jvm.clj @@ -0,0 +1,1144 @@ +(ns lux.analyser.proc.jvm + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type] + [host :as &host] + [lexer :as &lexer] + [parser :as &parser] + [reader :as &reader]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &&] + [lambda :as &&lambda] + [env :as &&env] + [parser :as &&a-parser]) + [lux.compiler.jvm.base :as &c!base]) + (:import (java.lang.reflect Type TypeVariable))) + +;; [Utils] +(defn ^:private ensure-catching [exceptions*] + "(-> (List Text) (Lux Null))" + (|do [class-loader &/loader] + (fn [state] + (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) + catching (->> state + (&/get$ &/$catching) + (&/|map #(Class/forName % true class-loader)))] + (if-let [missing-ex (&/fold (fn [prev ^Class now] + (or prev + (cond (or (.isAssignableFrom java.lang.RuntimeException now) + (.isAssignableFrom java.lang.Error now)) + nil + + (&/fold (fn [found? ^Class ex-catch] + (or found? + (.isAssignableFrom ex-catch now))) + false + catching) + nil + + :else + now))) + nil + exceptions)] + ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) + state) + (&/return* state nil))) + ))) + +(defn ^:private with-catches [catches body] + "(All [a] (-> (List Text) (Lux a) (Lux a)))" + (fn [state] + (let [old-catches (&/get$ &/$catching state) + state* (&/update$ &/$catching (partial &/|++ catches) state)] + (|case (&/run-state body state*) + (&/$Left msg) + (&/$Left msg) + + (&/$Right state** output) + (&/$Right (&/T [(&/set$ &/$catching old-catches state**) + output])))) + )) + +(defn ^:private ensure-object [type] + "(-> Type (Lux (, Text (List Type))))" + (|case type + (&/$HostT payload) + (return payload) + + (&/$VarT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$ExT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$NamedT _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) + + (&/$AppT F A) + (|do [type* (&type/apply-type F A)] + (ensure-object type*)) + + _ + (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) + +(defn ^:private as-object [type] + "(-> Type Type)" + (|case type + (&/$HostT class params) + (&/$HostT (&host-type/as-obj class) params) + + _ + type)) + +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn ^:private as-otype+ [type] + "(-> Type Type)" + (|case type + (&/$HostT name params) + (&/$HostT (as-otype name) params) + + _ + type)) + +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T [idx real-type]))) + (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T [idx* (&/$Cons real-type types)])))) + (&/T [1 &/$Nil]) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&/$UnivQ &type/empty-env base-type) + + _ + base-type)) + (&/$HostT class-name type-args) + type-args)) + +;; [Resources] +(defn ^:private analyse-field-access-helper [obj-type gvars gtype] + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + (|case obj-type + (&/$HostT class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + + _ + (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + +(defn generic-class->simple-class [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar var-name) + "java.lang.Object" + + (&/$GenericWildcard _) + "java.lang.Object" + + (&/$GenericClass name params) + name + + (&/$GenericArray param) + (|case param + (&/$GenericArray _) + (str "[" (generic-class->simple-class param)) + + (&/$GenericClass "boolean" _) + "[Z" + + (&/$GenericClass "byte" _) + "[B" + + (&/$GenericClass "short" _) + "[S" + + (&/$GenericClass "int" _) + "[I" + + (&/$GenericClass "long" _) + "[J" + + (&/$GenericClass "float" _) + "[F" + + (&/$GenericClass "double" _) + "[D" + + (&/$GenericClass "char" _) + "[C" + + (&/$GenericClass name params) + (str "[L" name ";") + + (&/$GenericTypeVar var-name) + "[Ljava.lang.Object;" + + (&/$GenericWildcard _) + "[Ljava.lang.Object;") + )) + +(defn generic-class->type [env gclass] + "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" + (|case gclass + (&/$GenericTypeVar var-name) + (if-let [ex (&/|get var-name env)] + (return ex) + (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) + + (&/$GenericClass name params) + (case name + "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) + "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) + "short" (return (&/$HostT "java.lang.Short" &/$Nil)) + "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) + "long" (return (&/$HostT "java.lang.Long" &/$Nil)) + "float" (return (&/$HostT "java.lang.Float" &/$Nil)) + "double" (return (&/$HostT "java.lang.Double" &/$Nil)) + "char" (return (&/$HostT "java.lang.Character" &/$Nil)) + "void" (return &/$UnitT) + ;; else + (|do [=params (&/map% (partial generic-class->type env) params)] + (return (&/$HostT name =params)))) + + (&/$GenericArray param) + (|do [=param (generic-class->type env param)] + (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) + + (&/$GenericWildcard _) + (return (&/$ExQ &/$Nil (&/$BoundT 1))) + )) + +(defn gen-super-env [class-env supers class-decl] + "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" + (|let [[class-name class-vars] class-decl] + (|case (&/|some (fn [super] + (|let [[super-name super-params] super] + (if (= class-name super-name) + (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) + &/$None))) + supers) + (&/$None) + (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) + + (&/$Some vars+gtypes) + (&/map% (fn [var+gtype] + (|do [:let [[var gtype] var+gtype] + =gtype (generic-class->type class-env gtype)] + (return (&/T [var =gtype])))) + vars+gtypes) + ))) + +(defn ^:private make-type-env [type-params] + "(-> (List TypeParam) (Lux (List [Text Type])))" + (&/map% (fn [gvar] + (|do [:let [[gvar-name _] gvar] + ex &type/existential] + (return (&/T [gvar-name ex])))) + type-params)) + +(defn ^:private double-register-gclass? [gclass] + (|case gclass + (&/$GenericClass name _) + (|case name + "long" true + "double" true + _ false) + + _ + false)) + +(defn ^:private method-input-folder [full-env] + (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type full-env itype*)] + (if (double-register-gclass? itype*) + (&&env/with-local iname itype + (&&env/with-local "" &/$VoidT + body*)) + (&&env/with-local iname itype + body*))))) + +(defn ^:private analyse-method [analyse class-decl class-env all-supers method] + "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" + (|let [[?cname ?cparams] class-decl + class-type (&/$HostT ?cname (&/|map &/|second class-env))] + (|case method + (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + :let [output-type &/$UnitT] + =ctor-args (&/map% (fn [ctor-arg] + (|do [:let [[ca-type ca-term] ctor-arg] + =ca-type (generic-class->type full-env ca-type) + =ca-term (&&/analyse-1 analyse =ca-type ca-term)] + (return (&/T [ca-type =ca-term])))) + ?ctor-args) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) + + (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [super-env (gen-super-env class-env all-supers ?class-decl) + method-env (make-type-env ?gvars) + :let [full-env (&/|++ super-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env method-env] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs)))))] + (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + + (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + ))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" + (|do [abstract-methods (mandatory-methods supers) + :let [methods-map (&/fold (fn [mmap mentry] + (|case mentry + (&/$ConstructorMethodAnalysis _) + mmap + + (&/$VirtualMethodAnalysis _) + mmap + + (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) + + (&/$StaticMethodAnalysis _) + mmap + + (&/$AbstractMethodSyntax _) + mmap + + (&/$NativeMethodSyntax _) + mmap + )) + {} + methods) + missing-method (&/fold (fn [missing abs-meth] + (or missing + (|let [[am-name am-inputs] abs-meth] + (if-let [meth-struct (get methods-map am-name)] + (if (some (fn [=inputs] + (and (= (&/|length =inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] + (|let [[iname itype] mi] + (and prev (= (generic-class->simple-class itype) ai)))) + true + =inputs am-inputs))) + meth-struct) + nil + abs-meth) + abs-meth)))) + nil + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (|let [[am-name am-inputs] missing-method] + (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) + +(defn ^:private analyse-field [analyse gtype-env field] + "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) + =value (&&/analyse-1 analyse =gtype ?value)] + (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) + + (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) + (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) + )) + +(do-template [ ] + (let [output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type _?value] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + =value (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) + + ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" + ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" + ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" + + ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" + ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" + ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" + + ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" + ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" + ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" + ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" + ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" + + ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" + ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" + ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" + ^:private analyse-jvm-l2s "l2s" "java.lang.Long" "java.lang.Short" + ^:private analyse-jvm-l2b "l2b" "java.lang.Long" "java.lang.Byte" + + ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" + ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" + ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" + ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" + + ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" + + ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" + ) + +(do-template [ ] + (let [output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] + =value1 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value1) + =value2 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value2) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) + + ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + + ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ) + +(do-template [ ] + (let [input-type (&/$HostT &/$Nil) + output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) + + ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" + + ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" + + ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" + + ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" + + ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" + ) + +(let [length-type &type/Nat + idx-type &type/Nat] + (do-template [ ] + (let [elem-type (&/$HostT &/$Nil) + array-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) + + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) + + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) + ) + + "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" + "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" + "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" + "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" + "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" + "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" + "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" + "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" + )) + +(defn ^:private array-class? [class-name] + (or (= &host-type/array-data-tag class-name) + (case class-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true + ;; else + false))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] + gclass (&reader/with-source "jvm-anewarray" _gclass + &&a-parser/parse-gclass) + gtype-env &/get-type-env + =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) + :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Nil)) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) + ))))) + +(defn ^:private analyse-jvm-null? [analyse exo-type ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) + +(defn ^:private analyse-jvm-null [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) + +(defn analyse-jvm-synchronized [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + =expr (&&/analyse-1 analyse exo-type ?expr) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) + +(defn ^:private analyse-jvm-throw [analyse exo-type ?values] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] + =ex (&&/analyse-1+ analyse ?ex) + _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) + [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) + _ (ensure-catching (&/|list throw-class)) + _cursor &/cursor + _ (&type/check exo-type &type/Bottom)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) + +(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Nil) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + =type (&host-type/instance-param &type/existential &/$Nil gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Nil)) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader !class! field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons value (&/$Nil)) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (&host-type/instance-param &type/existential &/$Nil gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) + +(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + :let [obj-type (&&/expr-type* =object)] + _ (ensure-object obj-type) + [gvars gtype] (&host/lookup-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (analyse-field-access-helper obj-type gvars gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) + +(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =arg-types (&/map% &type/show-type+ arg-types) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret) + _ (&type/check exo-type (as-otype+ =gret))] + (return (&/T [=gret =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [(&/$VarT _id) $var + gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] + (do-template [ ] + (defn [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object args) ?values] + class-loader &/loader + _ (try (assert! (let [=class (Class/forName !class! true class-loader)] + (= (.isInterface =class))) + (if + (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") + (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) + [gret exceptions parent-gvars gvars gargs] (if (= "" method) + (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) + (&host/lookup-virtual-method class-loader !class! method classes)) + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) + !class! + sub-class) + sub-params) + :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) + + ^:private analyse-jvm-invokevirtual "invokevirtual" false + ^:private analyse-jvm-invokespecial "invokespecial" false + ^:private analyse-jvm-invokeinterface "invokeinterface" true + )) + +(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) + _ (ensure-catching exceptions) + :let [gtype-env (&/|table)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T [(make-gtype gtype gtype-vars*) + =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) + _ (ensure-catching exceptions) + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) + +(defn ^:private analyse-jvm-try [analyse exo-type ?values] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] + =body (with-catches (&/|list "java.lang.Exception") + (&&/analyse-1 analyse exo-type ?body)) + =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) + +(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) + +(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] + ^ClassLoader class-loader &/loader + _ (try (do (.loadClass class-loader _class-name) + (return nil)) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) + :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-array-new [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) + array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] + gtype-env &/get-type-env + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-array-get [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-array-remove [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor + :let [=elem (&&/|meta inner-arr-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] + _ (&type/check exo-type array-type)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] + (|do [module &/get-module-name + _ (compile-interface interface-decl supers =anns =methods) + :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list))))))) + +(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] + (&/with-closure + (|do [module &/get-module-name + :let [[?name ?params] class-decl + full-name (str (string/replace module "/" ".") "." ?name) + class-decl* (&/T [full-name ?params]) + all-supers (&/$Cons super-class interfaces)] + class-env (make-type-env ?params) + =fields (&/map% (partial analyse-field analyse class-env) ?fields) + _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) + =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) + _ &/pop-dummy-name + :let [_ (println 'CLASS full-name)] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list)))))))) + +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [_ (&&/$captured _ _ source)]] + source)) + +(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM + false + &/$Nil + &/$Nil + &/$Nil + &/$Nil + &/$Nil + (&/$TupleS &/$Nil)])) + captured-slot-class "java.lang.Object" + captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] + (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] + (&/with-closure + (|do [module &/get-module-name + scope &/get-scope-name + :let [name (->> scope &/|reverse &/|tail &host/location) + class-decl (&/T [name &/$Nil]) + anon-class (str (string/replace module "/" ".") "." name) + anon-class-type (&/$HostT anon-class &/$Nil)] + =ctor-args (&/map% (fn [ctor-arg] + (|let [[arg-type arg-term] ctor-arg] + (|do [=arg-term (&&/analyse-1+ analyse arg-term)] + (return (&/T [arg-type =arg-term]))))) + ctor-args) + _ (->> methods + (&/$Cons default-) + (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) + :let [all-supers (&/$Cons super-class interfaces) + class-env &/$Nil] + =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + =captured &&env/captured-vars + :let [=fields (&/|map (fn [^objects idx+capt] + (|let [[idx _] idx+capt] + (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) + &/$PublicPM + &/$FinalSM + &/$Nil + captured-slot-type))) + (&/enumerate =captured))] + :let [sources (&/|map captured-source =captured)] + _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) + _ &/pop-dummy-name + _cursor &/cursor] + (return (&/|list (&&/|meta anon-class-type _cursor + (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) + ))) + )))) + +(defn analyse-host [analyse exo-type compilers proc ?values] + (|let [[_ _ _ compile-class compile-interface] compilers] + (case proc + "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) + "load-class" (analyse-jvm-load-class analyse exo-type ?values) + "try" (analyse-jvm-try analyse exo-type ?values) + "throw" (analyse-jvm-throw analyse exo-type ?values) + "null?" (analyse-jvm-null? analyse exo-type ?values) + "null" (analyse-jvm-null analyse exo-type ?values) + "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) + "aaload" (analyse-jvm-aaload analyse exo-type ?values) + "aastore" (analyse-jvm-aastore analyse exo-type ?values) + "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) + "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) + "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) + "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) + "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) + "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) + "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) + "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) + "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) + "iadd" (analyse-jvm-iadd analyse exo-type ?values) + "isub" (analyse-jvm-isub analyse exo-type ?values) + "imul" (analyse-jvm-imul analyse exo-type ?values) + "idiv" (analyse-jvm-idiv analyse exo-type ?values) + "irem" (analyse-jvm-irem analyse exo-type ?values) + "ieq" (analyse-jvm-ieq analyse exo-type ?values) + "ilt" (analyse-jvm-ilt analyse exo-type ?values) + "igt" (analyse-jvm-igt analyse exo-type ?values) + "ceq" (analyse-jvm-ceq analyse exo-type ?values) + "clt" (analyse-jvm-clt analyse exo-type ?values) + "cgt" (analyse-jvm-cgt analyse exo-type ?values) + "ladd" (analyse-jvm-ladd analyse exo-type ?values) + "lsub" (analyse-jvm-lsub analyse exo-type ?values) + "lmul" (analyse-jvm-lmul analyse exo-type ?values) + "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) + "lrem" (analyse-jvm-lrem analyse exo-type ?values) + "leq" (analyse-jvm-leq analyse exo-type ?values) + "llt" (analyse-jvm-llt analyse exo-type ?values) + "lgt" (analyse-jvm-lgt analyse exo-type ?values) + "fadd" (analyse-jvm-fadd analyse exo-type ?values) + "fsub" (analyse-jvm-fsub analyse exo-type ?values) + "fmul" (analyse-jvm-fmul analyse exo-type ?values) + "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) + "frem" (analyse-jvm-frem analyse exo-type ?values) + "feq" (analyse-jvm-feq analyse exo-type ?values) + "flt" (analyse-jvm-flt analyse exo-type ?values) + "fgt" (analyse-jvm-fgt analyse exo-type ?values) + "dadd" (analyse-jvm-dadd analyse exo-type ?values) + "dsub" (analyse-jvm-dsub analyse exo-type ?values) + "dmul" (analyse-jvm-dmul analyse exo-type ?values) + "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) + "drem" (analyse-jvm-drem analyse exo-type ?values) + "deq" (analyse-jvm-deq analyse exo-type ?values) + "dlt" (analyse-jvm-dlt analyse exo-type ?values) + "dgt" (analyse-jvm-dgt analyse exo-type ?values) + "iand" (analyse-jvm-iand analyse exo-type ?values) + "ior" (analyse-jvm-ior analyse exo-type ?values) + "ixor" (analyse-jvm-ixor analyse exo-type ?values) + "ishl" (analyse-jvm-ishl analyse exo-type ?values) + "ishr" (analyse-jvm-ishr analyse exo-type ?values) + "iushr" (analyse-jvm-iushr analyse exo-type ?values) + "land" (analyse-jvm-land analyse exo-type ?values) + "lor" (analyse-jvm-lor analyse exo-type ?values) + "lxor" (analyse-jvm-lxor analyse exo-type ?values) + "lshl" (analyse-jvm-lshl analyse exo-type ?values) + "lshr" (analyse-jvm-lshr analyse exo-type ?values) + "lushr" (analyse-jvm-lushr analyse exo-type ?values) + "d2f" (analyse-jvm-d2f analyse exo-type ?values) + "d2i" (analyse-jvm-d2i analyse exo-type ?values) + "d2l" (analyse-jvm-d2l analyse exo-type ?values) + "f2d" (analyse-jvm-f2d analyse exo-type ?values) + "f2i" (analyse-jvm-f2i analyse exo-type ?values) + "f2l" (analyse-jvm-f2l analyse exo-type ?values) + "i2b" (analyse-jvm-i2b analyse exo-type ?values) + "i2c" (analyse-jvm-i2c analyse exo-type ?values) + "i2d" (analyse-jvm-i2d analyse exo-type ?values) + "i2f" (analyse-jvm-i2f analyse exo-type ?values) + "i2l" (analyse-jvm-i2l analyse exo-type ?values) + "i2s" (analyse-jvm-i2s analyse exo-type ?values) + "l2d" (analyse-jvm-l2d analyse exo-type ?values) + "l2f" (analyse-jvm-l2f analyse exo-type ?values) + "l2i" (analyse-jvm-l2i analyse exo-type ?values) + "l2s" (analyse-jvm-l2s analyse exo-type ?values) + "l2b" (analyse-jvm-l2b analyse exo-type ?values) + "c2b" (analyse-jvm-c2b analyse exo-type ?values) + "c2s" (analyse-jvm-c2s analyse exo-type ?values) + "c2i" (analyse-jvm-c2i analyse exo-type ?values) + "c2l" (analyse-jvm-c2l analyse exo-type ?values) + "b2l" (analyse-jvm-b2l analyse exo-type ?values) + "s2l" (analyse-jvm-s2l analyse exo-type ?values) + ;; else + (->> (&/fail-with-loc (str "[Analyser Error] Unknown JVM procedure: " proc)) + (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] + (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) + + (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] + (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) + + (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] + (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) + + (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] + (analyse-jvm-instanceof analyse exo-type _class ?values)) + + (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getfield analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putfield analyse exo-type _class _field ?values)))) + )) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 1c34926aa..f449a7b3c 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -308,7 +308,7 @@ nil ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) v (recur slot table*)))) @@ -318,7 +318,7 @@ ($Cons (T [slot value]) $Nil) ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) ($Cons (T [slot value]) table*) ($Cons (T [k v]) (|put slot value table*))) )) @@ -329,7 +329,7 @@ table ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) table* ($Cons (T [k v]) (|remove slot table*))))) @@ -339,7 +339,7 @@ table ($Cons [k* v] table*) - (if (.equals ^Object k k*) + (if (= k k*) ($Cons (T [k* (f v)]) table*) ($Cons (T [k* v]) (|update k f table*))))) @@ -465,7 +465,7 @@ false ($Cons [k* _] table*) - (or (.equals ^Object k k*) + (or (= k k*) (|contains? k table*)))) (defn |member? [x xs] diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 6aa5d5915..a60afbc23 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -22,8 +22,8 @@ ;; [cache :as &&cache] [lux :as &&lux] [rt :as &&rt] - [proc :as &&proc] ) + (lux.compiler.js.proc [common :as &&common]) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory NashornScriptEngine @@ -99,7 +99,10 @@ (compile-expression ?value-ex) (&o/$proc [?proc-category ?proc-name] ?args special-args) - (&&proc/compile-proc compile-expression ?proc-category ?proc-name ?args special-args) + (case ?proc-category + ;; "js" ... + ;; common + (&&common/compile-proc compile-expression ?proc-category ?proc-name ?args special-args)) _ (assert false (prn-str 'JS=compile-expression (&/adt->text syntax)))) @@ -174,6 +177,7 @@ (&/$Left ?message) (binding [*out* !err!] (do (println (str "Compilation failed:\n" ?message)) - ;; (flush) - ;; (System/exit 1) - ))))))) + (flush) + (System/exit 1) + )) + ))))) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index b88d4dc00..62d440d6d 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -40,12 +40,6 @@ (def ^:private lux-obj-class (Class/forName "[Ljava.lang.Object;")) -(defn ^:private _valueOf_ [value] - (reify JSObject - (isFunction [self] true) - (call [self this args] - value))) - (defn ^:private _slice_ [wrap-lux-obj value] (reify JSObject (isFunction [self] true) @@ -58,25 +52,43 @@ (isFunction [self] true) (call [self this args] (&/adt->text obj) - ;; (pr-str this) ))) +(def ^:private i64-mask (dec (bit-shift-left 1 32))) +(defn ^:private to-i64 [value] + (reify JSObject + (getMember [self member] + (condp = member + "H" (-> value (unsigned-bit-shift-right 32) (bit-and i64-mask) int) + "L" (-> value (bit-and i64-mask) int) + ;; else + (assert false (str "to-i64#getMember = " member)))))) + (deftype LuxJsObject [obj] JSObject (isFunction [self] false) (getSlot [self idx] (let [value (aget obj idx)] - (if (instance? lux-obj-class value) - (new LuxJsObject value) - value))) + (cond (instance? lux-obj-class value) + (new LuxJsObject value) + + (instance? java.lang.Long value) + (to-i64 value) + + :else + value))) (getMember [self member] (condp = member - ;; "valueOf" (_valueOf_ obj) "toString" (_toString_ obj) "length" (alength obj) - "slice" (let [wrap-lux-obj #(if (instance? lux-obj-class %) - (new LuxJsObject %) - %)] + "slice" (let [wrap-lux-obj #(cond (instance? lux-obj-class %) + (new LuxJsObject %) + + (instance? java.lang.Long %) + (to-i64 %) + + :else + %)] (_slice_ wrap-lux-obj obj)) ;; else (assert false (str "wrap-lux-obj#getMember = " member))))) @@ -86,6 +98,17 @@ (new LuxJsObject obj) obj)) +(defn ^:private int64? [^ScriptObjectMirror js-object] + (and (.hasMember js-object "H") + (.hasMember js-object "L"))) + +(defn ^:private parse-int64 [^ScriptObjectMirror js-object] + (+ (-> (.getMember js-object "H") + long + (bit-shift-left 32)) + (-> (.getMember js-object "L") + long))) + (defn js-to-lux [js-object] (cond (or (nil? js-object) (instance? java.lang.Boolean js-object) @@ -94,7 +117,7 @@ js-object (instance? java.lang.Number js-object) - (long js-object) + (double js-object) (instance? LuxJsObject js-object) (.-obj ^LuxJsObject js-object) @@ -123,6 +146,9 @@ (.isFunction js-object) js-object + (int64? js-object) + (parse-int64 js-object) + :else (assert false (str "Unknown kind of JS object: " js-object)))) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 578eb74f8..a7b1217f0 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -32,9 +32,13 @@ (defn compile-bool [?value] (return (str ?value))) +(def mask-4b (dec (bit-shift-left 1 32))) + (do-template [] (defn [value] - (return (str "(" value "|0)"))) + (let [high (-> value (unsigned-bit-shift-right 32) (bit-and mask-4b)) + low (-> value (bit-and mask-4b))] + (return (str &&rt/LuxRT "." "makeI64" "(" high "," low ")")))) compile-nat compile-int diff --git a/luxc/src/lux/compiler/js/proc.clj b/luxc/src/lux/compiler/js/proc.clj deleted file mode 100644 index 95e6950da..000000000 --- a/luxc/src/lux/compiler/js/proc.clj +++ /dev/null @@ -1,364 +0,0 @@ -(ns lux.compiler.js.proc - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [analyser :as &analyser] - [optimizer :as &o]) - [lux.analyser.base :as &a] - [lux.compiler.js.base :as &&])) - -;; [Resources] -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; _ (compile ?mask) -;; :let [_ (&&/unwrap-long *writer*)] -;; :let [_ (doto *writer* -;; (.visitInsn ) -;; &&/wrap-long)]] -;; (return nil))) - -;; ^:private compile-bit-and Opcodes/LAND -;; ^:private compile-bit-or Opcodes/LOR -;; ^:private compile-bit-xor Opcodes/LXOR -;; ) - -;; (defn ^:private compile-bit-count [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; :let [_ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") -;; (.visitInsn Opcodes/I2L) -;; &&/wrap-long)]] -;; (return nil))) - -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; _ (compile ?shift) -;; :let [_ (doto *writer* -;; &&/unwrap-long -;; (.visitInsn Opcodes/L2I))] -;; :let [_ (doto *writer* -;; (.visitInsn ) -;; &&/wrap-long)]] -;; (return nil))) - -;; ^:private compile-bit-shift-left Opcodes/LSHL -;; ^:private compile-bit-shift-right Opcodes/LSHR -;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR -;; ) - -;; (defn ^:private compile-lux-== [compile ?values special-args] -;; (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?left) -;; _ (compile ?right) -;; :let [$then (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; (.visitJumpInsn Opcodes/IF_ACMPEQ $then) -;; ;; else -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") -;; (.visitJumpInsn Opcodes/GOTO $end) -;; (.visitLabel $then) -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") -;; (.visitLabel $end))]] -;; (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x " " " " =y ")")))) - - ^:private compile-nat-add "+" - ^:private compile-nat-sub "-" - ^:private compile-nat-mul "*" - ^:private compile-nat-div "/" - ^:private compile-nat-rem "%" - ^:private compile-nat-eq "===" - ^:private compile-nat-lt "<" - - ^:private compile-int-add "+" - ^:private compile-int-sub "-" - ^:private compile-int-mul "*" - ^:private compile-int-div "/" - ^:private compile-int-rem "%" - ^:private compile-int-eq "===" - ^:private compile-int-lt "<" - - ^:private compile-deg-add "+" - ^:private compile-deg-sub "-" - ^:private compile-deg-mul "*" - ^:private compile-deg-div "/" - ^:private compile-deg-rem "%" - ^:private compile-deg-eq "===" - ^:private compile-deg-lt "<" - ^:private compile-deg-scale "*" - - ^:private compile-real-add "+" - ^:private compile-real-sub "-" - ^:private compile-real-mul "*" - ^:private compile-real-div "/" - ^:private compile-real-rem "%" - ^:private compile-real-eq "===" - ^:private compile-real-lt "<" - ) - -;; (defn ^:private compile-nat-lt [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; _ (compile ?y) -;; :let [_ (doto *writer* -;; &&/unwrap-long) -;; $then (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") -;; (.visitLdcInsn (int -1)) -;; (.visitJumpInsn Opcodes/IF_ICMPEQ $then) -;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) -;; (.visitJumpInsn Opcodes/GOTO $end) -;; (.visitLabel $then) -;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) -;; (.visitLabel $end))]] -;; (return nil))) - -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Nil) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; :let [_ (doto *writer* -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long -;; ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long - -;; ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long -;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long -;; ) - -;; (do-template [ ] -;; (do (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] -;; (return nil))) - -;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] -;; (return nil))))) - -;; ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" -;; ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" -;; ) - -(defn compile-int-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "(" =x ").toString()")))) - -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; _ (compile ?y) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; :let [_ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") -;; &&/wrap-long)]] -;; (return nil))) - -;; ^:private compile-deg-mul "mul_deg" -;; ^:private compile-deg-div "div_deg" -;; ) - -;; (do-template [ ] -;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) -;; )]] -;; (return nil)))) - -;; ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double -;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long -;; ) - -;; (let [widen (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/I2L))) -;; shrink (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/L2I) -;; (.visitInsn Opcodes/I2C)))] -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink -;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen -;; )) - -(do-template [] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] - (compile ?x))) - - ^:private compile-nat-to-int - ^:private compile-int-to-nat - ) - -(defn compile-text-eq [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x "===" =y ")")))) - -(defn compile-text-append [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str =x ".concat(" =y ")")))) - -(defn compile-proc [compile proc-category proc-name ?values special-args] - (case proc-category - ;; "lux" - ;; (case proc-name - ;; "==" (compile-lux-== compile ?values special-args)) - - "text" - (case proc-name - "=" (compile-text-eq compile ?values special-args) - "append" (compile-text-append compile ?values special-args)) - - ;; "bit" - ;; (case proc-name - ;; "count" (compile-bit-count compile ?values special-args) - ;; "and" (compile-bit-and compile ?values special-args) - ;; "or" (compile-bit-or compile ?values special-args) - ;; "xor" (compile-bit-xor compile ?values special-args) - ;; "shift-left" (compile-bit-shift-left compile ?values special-args) - ;; "shift-right" (compile-bit-shift-right compile ?values special-args) - ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) - - ;; "array" - ;; (case proc-name - ;; "get" (compile-array-get compile ?values special-args)) - - "nat" - (case proc-name - "+" (compile-nat-add compile ?values special-args) - "-" (compile-nat-sub compile ?values special-args) - "*" (compile-nat-mul compile ?values special-args) - "/" (compile-nat-div compile ?values special-args) - "%" (compile-nat-rem compile ?values special-args) - "=" (compile-nat-eq compile ?values special-args) - "<" (compile-nat-lt compile ?values special-args) - ;; "encode" (compile-nat-encode compile ?values special-args) - ;; "decode" (compile-nat-decode compile ?values special-args) - ;; "max-value" (compile-nat-max-value compile ?values special-args) - ;; "min-value" (compile-nat-min-value compile ?values special-args) - "to-int" (compile-nat-to-int compile ?values special-args) - ;; "to-char" (compile-nat-to-char compile ?values special-args) - ) - - "int" - (case proc-name - "+" (compile-int-add compile ?values special-args) - "-" (compile-int-sub compile ?values special-args) - "*" (compile-int-mul compile ?values special-args) - "/" (compile-int-div compile ?values special-args) - "%" (compile-int-rem compile ?values special-args) - "=" (compile-int-eq compile ?values special-args) - "<" (compile-int-lt compile ?values special-args) - "encode" (compile-int-encode compile ?values special-args) - ;; "decode" (compile-int-decode compile ?values special-args) - ;; "max-value" (compile-int-max-value compile ?values special-args) - ;; "min-value" (compile-int-min-value compile ?values special-args) - "to-nat" (compile-int-to-nat compile ?values special-args) - ) - - "deg" - (case proc-name - "+" (compile-deg-add compile ?values special-args) - "-" (compile-deg-sub compile ?values special-args) - "*" (compile-deg-mul compile ?values special-args) - "/" (compile-deg-div compile ?values special-args) - "%" (compile-deg-rem compile ?values special-args) - "=" (compile-deg-eq compile ?values special-args) - "<" (compile-deg-lt compile ?values special-args) - ;; "encode" (compile-deg-encode compile ?values special-args) - ;; "decode" (compile-deg-decode compile ?values special-args) - ;; "max-value" (compile-deg-max-value compile ?values special-args) - ;; "min-value" (compile-deg-min-value compile ?values special-args) - ;; "to-real" (compile-deg-to-real compile ?values special-args) - "scale" (compile-deg-scale compile ?values special-args) - ) - - "real" - (case proc-name - "+" (compile-real-add compile ?values special-args) - "-" (compile-real-sub compile ?values special-args) - "*" (compile-real-mul compile ?values special-args) - "/" (compile-real-div compile ?values special-args) - "%" (compile-real-rem compile ?values special-args) - "=" (compile-real-eq compile ?values special-args) - "<" (compile-real-lt compile ?values special-args) - ;; "encode" (compile-real-encode compile ?values special-args) - ;; "decode" (compile-real-decode compile ?values special-args) - ;; "max-value" (compile-real-max-value compile ?values special-args) - ;; "min-value" (compile-real-min-value compile ?values special-args) - ;; "to-deg" (compile-real-to-deg compile ?values special-args) - ) - - ;; "char" - ;; (case proc-name - ;; "to-nat" (compile-char-to-nat compile ?values special-args) - ;; ) - - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj new file mode 100644 index 000000000..7e052892b --- /dev/null +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -0,0 +1,373 @@ +(ns lux.compiler.js.proc.common + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [analyser :as &analyser] + [optimizer :as &o]) + [lux.analyser.base :as &a] + (lux.compiler.js [base :as &&] + [rt :as &&rt]))) + +;; [Resources] +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; _ (compile ?mask) +;; :let [_ (&&/unwrap-long *writer*)] +;; :let [_ (doto *writer* +;; (.visitInsn ) +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-bit-and Opcodes/LAND +;; ^:private compile-bit-or Opcodes/LOR +;; ^:private compile-bit-xor Opcodes/LXOR +;; ) + +;; (defn ^:private compile-bit-count [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; :let [_ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") +;; (.visitInsn Opcodes/I2L) +;; &&/wrap-long)]] +;; (return nil))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; _ (compile ?shift) +;; :let [_ (doto *writer* +;; &&/unwrap-long +;; (.visitInsn Opcodes/L2I))] +;; :let [_ (doto *writer* +;; (.visitInsn ) +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-bit-shift-left Opcodes/LSHL +;; ^:private compile-bit-shift-right Opcodes/LSHR +;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR +;; ) + +;; (defn ^:private compile-lux-== [compile ?values special-args] +;; (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?left) +;; _ (compile ?right) +;; :let [$then (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; (.visitJumpInsn Opcodes/IF_ACMPEQ $then) +;; ;; else +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") +;; (.visitJumpInsn Opcodes/GOTO $end) +;; (.visitLabel $then) +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") +;; (.visitLabel $end))]] +;; (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str &&rt/LuxRT "." "(" =x "," =y ")")))) + + ^:private compile-nat-add "addI64" + ^:private compile-nat-sub "subI64" + ^:private compile-nat-mul "mulI64" + ;; ^:private compile-nat-div "/" + ;; ^:private compile-nat-rem "%" + ^:private compile-nat-eq "eqI64" + ;; ^:private compile-nat-lt "<" + + ^:private compile-int-add "addI64" + ^:private compile-int-sub "subI64" + ^:private compile-int-mul "mulI64" + ;; ^:private compile-int-div "/" + ;; ^:private compile-int-rem "%" + ^:private compile-int-eq "eqI64" + ;; ^:private compile-int-lt "<" + + ^:private compile-deg-add "addI64" + ^:private compile-deg-sub "subI64" + ;; ^:private compile-deg-mul "*" + ;; ^:private compile-deg-div "/" + ^:private compile-deg-rem "subI64" + ^:private compile-deg-eq "eqI64" + ;; ^:private compile-deg-lt "<" + ^:private compile-deg-scale "mulI64" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x " " " " =y ")")))) + + ^:private compile-real-add "+" + ^:private compile-real-sub "-" + ^:private compile-real-mul "*" + ^:private compile-real-div "/" + ^:private compile-real-rem "%" + ^:private compile-real-eq "===" + ^:private compile-real-lt "<" + ) + +;; (defn ^:private compile-nat-lt [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; _ (compile ?y) +;; :let [_ (doto *writer* +;; &&/unwrap-long) +;; $then (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") +;; (.visitLdcInsn (int -1)) +;; (.visitJumpInsn Opcodes/IF_ICMPEQ $then) +;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) +;; (.visitJumpInsn Opcodes/GOTO $end) +;; (.visitLabel $then) +;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) +;; (.visitLabel $end))]] +;; (return nil))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Nil) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; :let [_ (doto *writer* +;; +;; )]] +;; (return nil))) + +;; ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long +;; ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + +;; ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long +;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long +;; ) + +;; (do-template [ ] +;; (do (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] +;; (return nil))) + +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] +;; (return nil))))) + +;; ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" +;; ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" +;; ) + +(defn compile-int-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "(" =x ").toString()")))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; _ (compile ?y) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; :let [_ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-deg-mul "mul_deg" +;; ^:private compile-deg-div "div_deg" +;; ) + +;; (do-template [ ] +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) +;; )]] +;; (return nil)))) + +;; ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double +;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long +;; ) + +;; (let [widen (fn [^MethodVisitor *writer*] +;; (doto *writer* +;; (.visitInsn Opcodes/I2L))) +;; shrink (fn [^MethodVisitor *writer*] +;; (doto *writer* +;; (.visitInsn Opcodes/L2I) +;; (.visitInsn Opcodes/I2C)))] +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; +;; +;; )]] +;; (return nil))) + +;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink +;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen +;; )) + +(do-template [] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] + (compile ?x))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + +(defn compile-text-eq [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x "===" =y ")")))) + +(defn compile-text-append [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str =x ".concat(" =y ")")))) + +(defn compile-proc [compile proc-category proc-name ?values special-args] + (case proc-category + ;; "lux" + ;; (case proc-name + ;; "==" (compile-lux-== compile ?values special-args)) + + "text" + (case proc-name + "=" (compile-text-eq compile ?values special-args) + "append" (compile-text-append compile ?values special-args)) + + ;; "bit" + ;; (case proc-name + ;; "count" (compile-bit-count compile ?values special-args) + ;; "and" (compile-bit-and compile ?values special-args) + ;; "or" (compile-bit-or compile ?values special-args) + ;; "xor" (compile-bit-xor compile ?values special-args) + ;; "shift-left" (compile-bit-shift-left compile ?values special-args) + ;; "shift-right" (compile-bit-shift-right compile ?values special-args) + ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + + ;; "array" + ;; (case proc-name + ;; "get" (compile-array-get compile ?values special-args)) + + "nat" + (case proc-name + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + ;; "/" (compile-nat-div compile ?values special-args) + ;; "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + ;; "<" (compile-nat-lt compile ?values special-args) + ;; "encode" (compile-nat-encode compile ?values special-args) + ;; "decode" (compile-nat-decode compile ?values special-args) + ;; "max-value" (compile-nat-max-value compile ?values special-args) + ;; "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + ;; "to-char" (compile-nat-to-char compile ?values special-args) + ) + + "int" + (case proc-name + "+" (compile-int-add compile ?values special-args) + "-" (compile-int-sub compile ?values special-args) + "*" (compile-int-mul compile ?values special-args) + ;; "/" (compile-int-div compile ?values special-args) + ;; "%" (compile-int-rem compile ?values special-args) + "=" (compile-int-eq compile ?values special-args) + ;; "<" (compile-int-lt compile ?values special-args) + ;; "encode" (compile-int-encode compile ?values special-args) + ;; "decode" (compile-int-decode compile ?values special-args) + ;; "max-value" (compile-int-max-value compile ?values special-args) + ;; "min-value" (compile-int-min-value compile ?values special-args) + "to-nat" (compile-int-to-nat compile ?values special-args) + ) + + "deg" + (case proc-name + "+" (compile-deg-add compile ?values special-args) + "-" (compile-deg-sub compile ?values special-args) + ;; "*" (compile-deg-mul compile ?values special-args) + ;; "/" (compile-deg-div compile ?values special-args) + "%" (compile-deg-rem compile ?values special-args) + "=" (compile-deg-eq compile ?values special-args) + ;; "<" (compile-deg-lt compile ?values special-args) + ;; "encode" (compile-deg-encode compile ?values special-args) + ;; "decode" (compile-deg-decode compile ?values special-args) + ;; "max-value" (compile-deg-max-value compile ?values special-args) + ;; "min-value" (compile-deg-min-value compile ?values special-args) + ;; "to-real" (compile-deg-to-real compile ?values special-args) + "scale" (compile-deg-scale compile ?values special-args) + ) + + "real" + (case proc-name + "+" (compile-real-add compile ?values special-args) + "-" (compile-real-sub compile ?values special-args) + "*" (compile-real-mul compile ?values special-args) + "/" (compile-real-div compile ?values special-args) + "%" (compile-real-rem compile ?values special-args) + "=" (compile-real-eq compile ?values special-args) + "<" (compile-real-lt compile ?values special-args) + ;; "encode" (compile-real-encode compile ?values special-args) + ;; "decode" (compile-real-decode compile ?values special-args) + ;; "max-value" (compile-real-max-value compile ?values special-args) + ;; "min-value" (compile-real-min-value compile ?values special-args) + ;; "to-deg" (compile-real-to-deg compile ?values special-args) + ) + + ;; "char" + ;; (case proc-name + ;; "to-nat" (compile-char-to-nat compile ?values special-args) + ;; ) + + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 3c9186a1e..194248f10 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -936,58 +936,155 @@ ;; (.visitEnd)))] ;; nil))) +(def ^:private i64-methods + {"makeI64" (str "(function makeI64(high,low) {" + "return { H: (high|0), L: (low|0)};" + "})") + "notI64" (str "(function notI64(i64) {" + "return LuxRT.makeI64(~i64.H,~i64.L);" + "})") + "negateI64" (str "(function negateI64(i64) {" + "return LuxRT.addI64(LuxRT.notI64(i64),LuxRT.makeI64(0,1));" + "})") + "eqI64" (str "(function eqI64(l,r) {" + "return (l.H === r.H) && (l.L === r.L);" + "})") + "addI64" (str "(function addI64(l,r) {" + "var l48 = l.H >>> 16;" + "var l32 = l.H & 0xFFFF;" + "var l16 = l.L >>> 16;" + "var l00 = l.L & 0xFFFF;" + + "var r48 = r.H >>> 16;" + "var r32 = r.H & 0xFFFF;" + "var r16 = r.L >>> 16;" + "var r00 = r.L & 0xFFFF;" + + "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" + "x00 += l00 + r00;" + "x16 += x00 >>> 16;" + "x00 &= 0xFFFF;" + "x16 += l16 + r16;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x32 += l32 + r32;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x48 += l48 + r48;" + "x48 &= 0xFFFF;" + + "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" + "})") + "subI64" (str "(function subI64(l,r) {" + "return LuxRT.addI64(l,LuxRT.negateI64(r));" + "})") + "mulI64" (str "(function mulI64(l,r) {" + "if (l.H < 0) {" + (str "if (r.H < 0) {" + ;; Both are negative + "return mulI64(LuxRT.negateI64(l),LuxRT.negateI64(r));" + "}" + "else {" + ;; Left is negative + "return LuxRT.negateI64(mulI64(LuxRT.negateI64(l),r));" + "}") + "}" + "else if (r.H < 0) {" + ;; Right is negative + "return LuxRT.negateI64(mulI64(l,LuxRT.negateI64(r)));" + "}" + ;; Both are positive + "else {" + "var l48 = l.H >>> 16;" + "var l32 = l.H & 0xFFFF;" + "var l16 = l.L >>> 16;" + "var l00 = l.L & 0xFFFF;" + + "var r48 = r.H >>> 16;" + "var r32 = r.H & 0xFFFF;" + "var r16 = r.L >>> 16;" + "var r00 = r.L & 0xFFFF;" + + "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" + "x00 += l00 * r00;" + "x16 += x00 >>> 16;" + "x00 &= 0xFFFF;" + "x16 += l16 * r00;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x16 += l00 * r16;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x32 += l32 * r00;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x32 += l16 * r16;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x32 += l00 * r32;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x48 += (l48 * r00) + (l32 * r16) + (l16 * r32) + (l00 * r48);" + "x48 &= 0xFFFF;" + + "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" + "}" + "})") + }) + (def ^:private adt-methods - {:product_getLeft (str "(function product_getLeft(product,index) {" - "var index_min_length = (index+1);" - "if(product.length > index_min_length) {" - ;; No need for recursion - "return product[index];" - "}" - "else {" - ;; Needs recursion - "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" - "}" - "})") - :product_getRight (str "(function product_getRight(product,index) {" + {"product_getLeft" (str "(function product_getLeft(product,index) {" "var index_min_length = (index+1);" - "if(product.length === index_min_length) {" - ;; Last element. + "if(product.length > index_min_length) {" + ;; No need for recursion "return product[index];" "}" - "else if(product.length < index_min_length) {" - ;; Needs recursion - "return product_getRight(product[product.length - 1], (index_min_length - product.length));" - "}" "else {" - ;; Must slice - "return product.slice(index);" + ;; Needs recursion + "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" "}" "})") - :sum_get (str "(function sum_get(sum,wantedTag,wantsLast) {" - "if(sum[0] === wantedTag && sum[1] === wantsLast) {" - ;; Exact match. - "return sum[2];" - "}" - "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" - "if(sum[1]) {" - ;; Must recurse. - "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" - "}" - ;; No match. - "else { return null; }" - "}" - ;; No match. - "else { return null; }" - "})") + "product_getRight" (str "(function product_getRight(product,index) {" + "var index_min_length = (index+1);" + "if(product.length === index_min_length) {" + ;; Last element. + "return product[index];" + "}" + "else if(product.length < index_min_length) {" + ;; Needs recursion + "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + "}" + "else {" + ;; Must slice + "return product.slice(index);" + "}" + "})") + "sum_get" (str "(function sum_get(sum,wantedTag,wantsLast) {" + "if(sum[0] === wantedTag && sum[1] === wantsLast) {" + ;; Exact match. + "return sum[2];" + "}" + "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" + "if(sum[1]) {" + ;; Must recurse. + "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" + "}" + ;; No match. + "else { return null; }" + "}" + ;; No match. + "else { return null; }" + "})") }) (def LuxRT "LuxRT") (def compile-LuxRT (|do [_ (return nil) - :let [rt-object (str "{" (->> adt-methods + :let [rt-object (str "{" (->> (merge adt-methods + i64-methods) (map (fn [[key val]] - (str (name key) ":" val))) + (str key ":" val))) (interpose ",") (reduce str "")) "}")]] diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index cebe60d9c..d37a061f8 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -254,7 +254,7 @@ (fn [state] ((|do [mappings* (&/map% (fn [binding] (|let [[?id ?type] binding] - (if (.equals ^Object id ?id) + (if (= id ?id) (return binding) (|case ?type (&/$None) @@ -263,7 +263,7 @@ (&/$Some ?type*) (|case ?type* (&/$VarT ?id*) - (if (.equals ^Object id ?id*) + (if (= id ?id*) (return (&/T [?id &/$None])) (return binding)) @@ -287,7 +287,7 @@ (defn clean* [?tid type] (|case type (&/$VarT ?id) - (if (.equals ^Object ?tid ?id) + (if (= ?tid ?id) (|do [? (bound? ?id)] (if ? (deref ?id) @@ -298,7 +298,7 @@ ==type (clean* ?tid =type)] (|case ==type (&/$VarT =id) - (if (.equals ^Object ?tid =id) + (if (= ?tid =id) (|do [_ (unset-var ?id)] (return type)) (|do [_ (reset-var ?id ==type)] @@ -503,13 +503,13 @@ (type= xoutput youtput)) [(&/$VarT xid) (&/$VarT yid)] - (.equals ^Object xid yid) + (= xid yid) [(&/$BoundT xidx) (&/$BoundT yidx)] (= xidx yidx) [(&/$ExT xid) (&/$ExT yid)] - (.equals ^Object xid yid) + (= xid yid) [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) @@ -652,7 +652,7 @@ (&/with-attempt (|case [expected actual] [(&/$VarT ?eid) (&/$VarT ?aid)] - (if (.equals ^Object ?eid ?aid) + (if (= ?eid ?aid) (return fixpoints) (|do [ebound (fn [state] (|case ((deref ?eid) state) @@ -834,7 +834,7 @@ (check* class-loader fixpoints* invariant?? eR aR)) [(&/$ExT e!id) (&/$ExT a!id)] - (if (.equals ^Object e!id a!id) + (if (= e!id a!id) (return fixpoints) (check-error "" expected actual)) -- cgit v1.2.3