lux.compiler.host.clj Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of luxc-jvm Show documentation
Show all versions of luxc-jvm Show documentation
The JVM compiler for the Lux programming language.
The newest version!
;; Copyright (c) Eduardo Julian. All rights reserved.
;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
;; If a copy of the MPL was not distributed with this file,
;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.host
(: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 fail fail* |let |case]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
[analyser :as &analyser]
[optimizer :as &o]
[host :as &host])
[lux.type.host :as &host-type]
[lux.host.generics :as &host-generics]
[lux.analyser.base :as &a]
[lux.compiler.base :as &&])
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
MethodVisitor
AnnotationVisitor)))
;; [Utils]
(def init-method "")
(let [class+method+sig {"boolean" [(&host-generics/->bytecode-class-name "java.lang.Boolean") "booleanValue" "()Z"]
"byte" [(&host-generics/->bytecode-class-name "java.lang.Byte") "byteValue" "()B"]
"short" [(&host-generics/->bytecode-class-name "java.lang.Short") "shortValue" "()S"]
"int" [(&host-generics/->bytecode-class-name "java.lang.Integer") "intValue" "()I"]
"long" [(&host-generics/->bytecode-class-name "java.lang.Long") "longValue" "()J"]
"float" [(&host-generics/->bytecode-class-name "java.lang.Float") "floatValue" "()F"]
"double" [(&host-generics/->bytecode-class-name "java.lang.Double") "doubleValue" "()D"]
"char" [(&host-generics/->bytecode-class-name "java.lang.Character") "charValue" "()C"]}]
(defn ^:private prepare-arg! [^MethodVisitor *writer* class-name]
(if-let [[class method sig] (get class+method+sig class-name)]
(doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST class)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig))
(.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name)))))
(let [boolean-class "java.lang.Boolean"
byte-class "java.lang.Byte"
short-class "java.lang.Short"
int-class "java.lang.Integer"
long-class "java.lang.Long"
float-class "java.lang.Float"
double-class "java.lang.Double"
char-class "java.lang.Character"]
(defn prepare-return! [^MethodVisitor *writer* *type*]
(|case *type*
(&/$UnitT)
(.visitLdcInsn *writer* &/unit-tag)
(&/$HostT "boolean" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class)))
(&/$HostT "byte" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class)))
(&/$HostT "short" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class)))
(&/$HostT "int" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class)))
(&/$HostT "long" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class)))
(&/$HostT "float" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class)))
(&/$HostT "double" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class)))
(&/$HostT "char" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class)))
(&/$HostT _ _)
nil
(&/$NamedT ?name ?type)
(prepare-return! *writer* ?type)
(&/$ExT _)
nil
_
(assert false (str 'prepare-return! " " (&type/show-type *type*))))
*writer*))
;; [Resources]
(defn ^:private compile-annotation [writer ann]
(doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true)
(-> (.visit param-name param-value)
(->> (|let [[param-name param-value] param])
(doseq [param (&/->seq (:params ann))])))
(.visitEnd))
nil)
(defn ^:private compile-field [^ClassWriter writer field]
(|case field
(&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
(|let [=field (.visitField writer
(+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL)
?name
(&host-generics/gclass->simple-signature ?gclass)
(&host-generics/gclass->signature ?gclass) nil)]
(do (&/|map (partial compile-annotation =field) ?anns)
(.visitEnd =field)
nil))
(&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type)
(|let [=field (.visitField writer
(+ (&host/privacy-modifier->flag =privacy-modifier)
(&host/state-modifier->flag =state-modifier))
=name
(&host-generics/gclass->simple-signature =type)
(&host-generics/gclass->signature =type) nil)]
(do (&/|map (partial compile-annotation =field) =anns)
(.visitEnd =field)
nil))
))
(defn ^:private compile-method-return [^MethodVisitor writer output]
(|case output
(&/$GenericClass "void" (&/$Nil))
(.visitInsn writer Opcodes/RETURN)
(&/$GenericClass "boolean" (&/$Nil))
(doto writer
&&/unwrap-boolean
(.visitInsn Opcodes/IRETURN))
(&/$GenericClass "byte" (&/$Nil))
(doto writer
&&/unwrap-byte
(.visitInsn Opcodes/IRETURN))
(&/$GenericClass "short" (&/$Nil))
(doto writer
&&/unwrap-short
(.visitInsn Opcodes/IRETURN))
(&/$GenericClass "int" (&/$Nil))
(doto writer
&&/unwrap-int
(.visitInsn Opcodes/IRETURN))
(&/$GenericClass "long" (&/$Nil))
(doto writer
&&/unwrap-long
(.visitInsn Opcodes/LRETURN))
(&/$GenericClass "float" (&/$Nil))
(doto writer
&&/unwrap-float
(.visitInsn Opcodes/FRETURN))
(&/$GenericClass "double" (&/$Nil))
(doto writer
&&/unwrap-double
(.visitInsn Opcodes/DRETURN))
(&/$GenericClass "char" (&/$Nil))
(doto writer
&&/unwrap-char
(.visitInsn Opcodes/IRETURN))
(&/$GenericClass _class-name (&/$Nil))
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name))
(.visitInsn Opcodes/ARETURN))
_
(.visitInsn writer Opcodes/ARETURN)))
(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor]
"(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))"
(|case input
[_ (&/$GenericClass name params)]
(case name
"boolean" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-boolean
(.visitVarInsn Opcodes/ASTORE idx))
(return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))])))
"byte" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-byte
(.visitVarInsn Opcodes/ASTORE idx))
(return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))])))
"short" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-short
(.visitVarInsn Opcodes/ASTORE idx))
(return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))])))
"int" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-int
(.visitVarInsn Opcodes/ASTORE idx))
(return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))])))
"long" (do (doto method-visitor
(.visitVarInsn Opcodes/LLOAD idx)
&&/wrap-long
(.visitVarInsn Opcodes/ASTORE idx))
(return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)])))
"float" (do (doto method-visitor
(.visitVarInsn Opcodes/FLOAD idx)
&&/wrap-float
(.visitVarInsn Opcodes/ASTORE idx))
(return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))])))
"double" (do (doto method-visitor
(.visitVarInsn Opcodes/DLOAD idx)
&&/wrap-double
(.visitVarInsn Opcodes/ASTORE idx))
(return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)])))
"char" (do (doto method-visitor
(.visitVarInsn Opcodes/ILOAD idx)
&&/wrap-char
(.visitVarInsn Opcodes/ASTORE idx))
(return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))])))
;; else
(return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))])))
[_ gclass]
(return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))]))
))
(defn ^:private prepare-method-inputs [idx inputs method-visitor]
"(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))"
(|case inputs
(&/$Nil)
(return &/$Nil)
(&/$Cons input inputs*)
(|do [[_ outputs*] (&/fold% (fn [idx+outputs input]
(|do [:let [[_idx _outputs] idx+outputs]
[idx* output] (prepare-method-input _idx input method-visitor)]
(return (&/T [idx* (&/$Cons output _outputs)]))))
(&/T [idx &/$Nil])
inputs)]
(return (&/list-join (&/|reverse outputs*))))
))
(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def]
(|case method-def
(&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body)
(|let [?output (&/$GenericClass "void" (&/|list))
=method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
[simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
(&/with-writer (.visitMethod class-writer
(+ (&host/privacy-modifier->flag ?privacy-modifier)
(if ?strict Opcodes/ACC_STRICT 0))
init-method
simple-signature
generic-signature
(->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [[super-class-name super-class-params] ?super-class
init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str ""))
init-sig (str "(" init-types ")" "V")
_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 1 ?inputs =method)
:let [_ (.visitVarInsn =method Opcodes/ALOAD 0)]
_ (->> ?ctor-args (&/|map &/|second) (&/map% compile))
:let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)]
_ (compile (&o/optimize ?body))
:let [_ (doto =method
(compile-method-return ?output)
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil))))
(&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
(|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
[simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
(&/with-writer (.visitMethod class-writer
(+ (&host/privacy-modifier->flag ?privacy-modifier)
(if =final? Opcodes/ACC_FINAL 0)
(if ?strict Opcodes/ACC_STRICT 0))
?name
simple-signature
generic-signature
(->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 1 ?inputs =method)
_ (compile (&o/optimize ?body))
:let [_ (doto =method
(compile-method-return ?output)
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil))))
(&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
(|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
[simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
(&/with-writer (.visitMethod class-writer
(+ Opcodes/ACC_PUBLIC
(if ?strict Opcodes/ACC_STRICT 0))
?name
simple-signature
generic-signature
(->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 1 ?inputs =method)
_ (compile (&o/optimize ?body))
:let [_ (doto =method
(compile-method-return ?output)
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil))))
(&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
(|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
[simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
(&/with-writer (.visitMethod class-writer
(+ (&host/privacy-modifier->flag ?privacy-modifier)
(if ?strict Opcodes/ACC_STRICT 0)
Opcodes/ACC_STATIC)
?name
simple-signature
generic-signature
(->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 0 ?inputs =method)
_ (compile (&o/optimize ?body))
:let [_ (doto =method
(compile-method-return ?output)
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil))))
(&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
(|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
[simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
(&/with-writer (.visitMethod class-writer
(+ Opcodes/ACC_ABSTRACT
(&host/privacy-modifier->flag ?privacy-modifier))
?name
simple-signature
generic-signature
(->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitEnd =method)]]
(return nil))))
(&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
(|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
[simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
(&/with-writer (.visitMethod class-writer
(+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE
(&host/privacy-modifier->flag ?privacy-modifier))
?name
simple-signature
generic-signature
(->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
:let [_ (&/|map (partial compile-annotation =method) ?anns)
_ (.visitEnd =method)]]
(return nil))))
))
(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl]
(|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl
[simple-signature generic-signature] (&host-generics/method-signatures =method-decl)
=method (.visitMethod class-writer
(+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
=name
simple-signature
generic-signature
(->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
_ (&/|map (partial compile-annotation =method) =anns)
_ (.visitEnd =method)]
nil))
(defn ^:private prepare-ctor-arg [^MethodVisitor writer type]
(case type
"boolean" (doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Boolean"))
&&/unwrap-boolean)
"byte" (doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Byte"))
&&/unwrap-byte)
"short" (doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Short"))
&&/unwrap-short)
"int" (doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Integer"))
&&/unwrap-int)
"long" (doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Long"))
&&/unwrap-long)
"float" (doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Float"))
&&/unwrap-float)
"double" (doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Double"))
&&/unwrap-double)
"char" (doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Character"))
&&/unwrap-char)
;; else
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type)))))
(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object")
-return "V"]
(defn ^:private anon-class--signature [env]
(str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")"
-return))
(defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args]
(|let [[super-class-name super-class-params] super-class
init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))]
(&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil)
(|do [^MethodVisitor =method &/get-writer
:let [_ (doto =method
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0))]
_ (&/map% (fn [type+term]
(|let [[type term] type+term]
(|do [_ (compile term)
:let [_ (prepare-ctor-arg =method type)]]
(return nil))))
ctor-args)
:let [_ (doto =method
(.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" -return))
(-> (doto (.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
(.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
(->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(|case ?name+?captured
[?name [_ (&o/$captured _ ?captured-id ?source)]])
(doseq [?name+?captured (&/->seq env)])))
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil)))))
)
(defn ^:private constant-inits [fields]
"(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))"
(&/fold &/|++
&/$Nil
(&/|map (fn [field]
(|case field
(&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
(&/|list (&/T [?name ?gclass ?value]))
(&/$VariableFieldSyntax _)
(&/|list)
))
fields)))
(declare compile-jvm-putstatic)
(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args]
(|do [module &/get-module-name
[file-name line column] &/cursor
:let [[?name ?params] class-decl
class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces))
full-name (str module "/" ?name)
super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class))
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER
(&host/inheritance-modifier->flag ?inheritance-modifier))
full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))
(.visitSource file-name nil))
_ (&/|map (partial compile-annotation =class) ?anns)
_ (&/|map (partial compile-field =class)
?fields)]
_ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods)
_ (|case ??ctor-args
(&/$Some ctor-args)
(add-anon-class- =class compile full-name ?super-class env ctor-args)
_
(return nil))
_ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil)
(|do [^MethodVisitor =method &/get-writer
:let [_ (doto =method
(.visitCode))]
_ (&/map% (fn [ftriple]
(|let [[fname fgclass fvalue] ftriple]
(compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass))))
(constant-inits ?fields))
:let [_ (doto =method
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil)))]
(&&/save-class! ?name (.toByteArray (doto =class .visitEnd)))))
(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods]
(|do [:let [[interface-name interface-vars] interface-decl]
module &/get-module-name
[file-name _ _] &/cursor
:let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers)
=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE)
(str module "/" interface-name)
(if (= "" interface-signature) nil interface-signature)
"java/lang/Object"
(->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))
(.visitSource file-name nil))
_ (&/|map (partial compile-annotation =interface) ?anns)
_ (do (&/|map (partial compile-method-decl =interface) ?methods)
(.visitEnd =interface))]]
(&&/save-class! interface-name (.toByteArray =interface))))
(def compile-Function-class
(|do [_ (return nil)
:let [super-class "java/lang/Object"
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER
Opcodes/ACC_ABSTRACT
;; Opcodes/ACC_INTERFACE
)
&&/function-class nil super-class (into-array String []))
(-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil)
(doto (.visitEnd))))
=init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil)
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I")
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (dotimes [arity* &&/num-apply-variants]
(let [arity (inc arity*)]
(if (= 1 arity)
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil)
(.visitEnd))
(doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil)
(.visitCode)
(-> (.visitVarInsn Opcodes/ALOAD idx)
(->> (dotimes [idx arity])))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity)))
(.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
(.visitVarInsn Opcodes/ALOAD arity)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))))]]
(&&/save-class! (second (string/split &&/function-class #"/"))
(.toByteArray (doto =class .visitEnd)))))
(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class]
(|let [_ (let [$begin (new Label)
$not-rec (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitLabel $begin)
(.visitVarInsn Opcodes/ALOAD 0) ;; tuple
(.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size
(.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index
(.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem
(.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem
(.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem
(.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem
(.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size
(.visitInsn Opcodes/ISUB) ;; sub-index
(.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple
(.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple
(.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size
(.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem
(.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem
(.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitVarInsn Opcodes/ASTORE 0) ;; sub-index
(.visitVarInsn Opcodes/ISTORE 1) ;;
(.visitJumpInsn Opcodes/GOTO $begin)
(.visitLabel $not-rec) ;; tuple-size, index-last-elem
(.visitInsn Opcodes/POP2) ;;
(.visitVarInsn Opcodes/ALOAD 0) ;; tuple
(.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index
(.visitInsn Opcodes/AALOAD) ;; elem
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$begin (new Label)
$is-last (new Label)
$must-copy (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitLabel $begin)
(.visitVarInsn Opcodes/ALOAD 0) ;; tuple
(.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size
(.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index
(.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem
(.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem
(.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem
(.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem
(.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;;
;; Must recurse
(.visitVarInsn Opcodes/ALOAD 0) ;; tuple
(.visitInsn Opcodes/DUP) ;; tuple, tuple
(.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size
(.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem
(.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem
(.visitInsn Opcodes/AALOAD) ;; tuple-tail
(.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index
(.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple
(.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size
(.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1
(.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size*
(.visitInsn Opcodes/ISUB) ;; tuple-tail, index*
(.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail
(.visitVarInsn Opcodes/ASTORE 0) ;;
(.visitJumpInsn Opcodes/GOTO $begin)
(.visitLabel $must-copy)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitInsn Opcodes/ARRAYLENGTH)
(.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitLabel $is-last) ;; tuple-size, index-last-elem
(.visitInsn Opcodes/POP2) ;;
(.visitVarInsn Opcodes/ALOAD 0) ;; tuple
(.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index
(.visitInsn Opcodes/AALOAD) ;; elem
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$begin (new Label)
$just-return (new Label)
$then (new Label)
$further (new Label)
$not-right (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitLabel $begin)
(.visitVarInsn Opcodes/ILOAD 1) ;; tag
(.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum
(.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx
(.visitInsn Opcodes/AALOAD) ;; tag, sum-tag'
&&/unwrap-int ;; tag, sum-tag
(.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag
(.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag
(.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag
(.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag
(.visitInsn Opcodes/POP2)
(.visitInsn Opcodes/ACONST_NULL)
(.visitInsn Opcodes/ARETURN)
(.visitLabel $then) ;; tag, sum-tag
(.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last?
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last?
(.visitJumpInsn Opcodes/IF_ACMPEQ $just-return)
(.visitJumpInsn Opcodes/GOTO $further)
(.visitLabel $just-return)
(.visitInsn Opcodes/POP2)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn (int 2))
(.visitInsn Opcodes/AALOAD)
(.visitInsn Opcodes/ARETURN)
(.visitLabel $further) ;; tag, sum-tag
(.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum
(.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index?
(.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last?
(.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag
(.visitInsn Opcodes/ISUB) ;; sub-tag
(.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum
(.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx
(.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag
(.visitVarInsn Opcodes/ISTORE 1) ;;
(.visitJumpInsn Opcodes/GOTO $begin)
(.visitLabel $not-right) ;; tag, sum-tag
(.visitInsn Opcodes/POP2)
(.visitInsn Opcodes/ACONST_NULL)
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
;; I commented-out some parts because a null-check was
;; done to ensure variants were never created with null
;; values (this would interfere later with
;; pattern-matching).
;; Since Lux itself doesn't have null values as part of
;; the language, the burden of ensuring non-nulls was
;; shifted to library code dealing with host-interop, to
;; ensure variant-making was as fast as possible.
;; The null-checking code was left as comments in case I
;; ever change my mind.
_ (let [;; $is-null (new Label)
]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
(.visitCode)
;; (.visitVarInsn Opcodes/ALOAD 2)
;; (.visitJumpInsn Opcodes/IFNULL $is-null)
(.visitLdcInsn (int 3))
(.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
(.visitVarInsn Opcodes/ILOAD 0)
(&&/wrap-int)
(.visitInsn Opcodes/AASTORE)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1))
(.visitVarInsn Opcodes/ALOAD 1)
(.visitInsn Opcodes/AASTORE)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 2))
(.visitVarInsn Opcodes/ALOAD 2)
(.visitInsn Opcodes/AASTORE)
(.visitInsn Opcodes/ARETURN)
;; (.visitLabel $is-null)
;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
;; (.visitInsn Opcodes/DUP)
;; (.visitLdcInsn "Can't create variant for null pointer")
;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V")
;; (.visitInsn Opcodes/ATHROW)
(.visitMaxs 0 0)
(.visitEnd)))]
nil))
(defn ^:private low-4b [^MethodVisitor =method]
(doto =method
;; Assume there is a long at the top of the stack...
;; Add mask corresponding to -1 (FFFF...), on the low 32 bits.
(.visitLdcInsn (int -1))
(.visitInsn Opcodes/I2L)
;; Then do a bitwise and.
(.visitInsn Opcodes/LAND)
))
(defn ^:private high-4b [^MethodVisitor =method]
(doto =method
;; Assume there is a long at the top of the stack...
(.visitLdcInsn (int 32))
(.visitInsn Opcodes/LUSHR)
))
(defn ^:private swap2 [^MethodVisitor =method]
(doto =method
;; X2, Y2
(.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2
(.visitInsn Opcodes/POP2) ;; Y2, X2
))
(defn ^:private swap2x1 [^MethodVisitor =method]
(doto =method
;; X1, Y2
(.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2
(.visitInsn Opcodes/POP2) ;; Y2, X1
))
(defn ^:private bit-set-64? [^MethodVisitor =method]
(doto =method
;; L, I
(.visitLdcInsn (long 1)) ;; L, I, L
(.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L
(.visitInsn Opcodes/POP2) ;; L, L, I
(.visitInsn Opcodes/LSHL) ;; L, L
(.visitInsn Opcodes/LAND) ;; L
(.visitLdcInsn (long 0)) ;; L, L
(.visitInsn Opcodes/LCMP) ;; I
))
(defn ^:private compile-LuxRT-frac-methods [^ClassWriter =class]
(|let [frac-bits 64
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_frac" "(JJ)J" nil nil)
;; Based on: http://stackoverflow.com/a/31629280/6823464
(.visitCode)
;; Bottom part
(.visitVarInsn Opcodes/LLOAD 0) low-4b
(.visitVarInsn Opcodes/LLOAD 2) low-4b
(.visitInsn Opcodes/LMUL)
(.visitLdcInsn (int 32))
(.visitInsn Opcodes/LUSHR)
;; Middle part
(.visitVarInsn Opcodes/LLOAD 0) high-4b
(.visitVarInsn Opcodes/LLOAD 2) low-4b
(.visitInsn Opcodes/LMUL)
(.visitVarInsn Opcodes/LLOAD 0) low-4b
(.visitVarInsn Opcodes/LLOAD 2) high-4b
(.visitInsn Opcodes/LMUL)
(.visitInsn Opcodes/LADD)
;; Join middle and bottom
(.visitInsn Opcodes/LADD)
(.visitLdcInsn (int 32))
(.visitInsn Opcodes/LUSHR)
;; Top part
(.visitVarInsn Opcodes/LLOAD 0) high-4b
(.visitVarInsn Opcodes/LLOAD 2) high-4b
(.visitInsn Opcodes/LMUL)
;; Join top with rest
(.visitInsn Opcodes/LADD)
;; Return
(.visitInsn Opcodes/LRETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_frac" "(JJ)J" nil nil)
(.visitCode)
;; Based on: http://stackoverflow.com/a/8510587/6823464
(.visitVarInsn Opcodes/LLOAD 0)
(.visitVarInsn Opcodes/LLOAD 2) high-4b
(.visitInsn Opcodes/LDIV)
(.visitLdcInsn (int 32))
(.visitInsn Opcodes/LSHL)
(.visitInsn Opcodes/LRETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac-to-real" "(J)D" nil nil)
(.visitCode)
;; Translate high bytes
(.visitVarInsn Opcodes/LLOAD 0) high-4b
(.visitInsn Opcodes/L2D)
(.visitLdcInsn (double (Math/pow 2 32)))
(.visitInsn Opcodes/DDIV)
;; Translate low bytes
(.visitVarInsn Opcodes/LLOAD 0) low-4b
(.visitInsn Opcodes/L2D)
(.visitLdcInsn (double (Math/pow 2 32)))
(.visitInsn Opcodes/DDIV)
(.visitLdcInsn (double (Math/pow 2 32)))
(.visitInsn Opcodes/DDIV)
;; Combine and return
(.visitInsn Opcodes/DADD)
(.visitInsn Opcodes/DRETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-frac" "(D)J" nil nil)
(.visitCode)
;; Drop any excess
(.visitVarInsn Opcodes/DLOAD 0)
(.visitLdcInsn (double 1.0))
(.visitInsn Opcodes/DREM)
;; Shift upper half, but retain remaining decimals
(.visitLdcInsn (double (Math/pow 2 32)))
(.visitInsn Opcodes/DMUL)
;; Make a copy, so the lower half can be extracted
(.visitInsn Opcodes/DUP2)
;; Get that lower half
(.visitLdcInsn (double 1.0))
(.visitInsn Opcodes/DREM)
(.visitLdcInsn (double (Math/pow 2 32)))
(.visitInsn Opcodes/DMUL)
;; Turn it into a frac
(.visitInsn Opcodes/D2L)
;; Turn the upper half into frac too
swap2
(.visitInsn Opcodes/D2L)
;; Combine both pieces
(.visitInsn Opcodes/LADD)
;; FINISH
(.visitInsn Opcodes/LRETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (let [$loop-start (new Label)
$do-a-round (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil)
(.visitCode)
(.visitLdcInsn (int 0)) ;; {carry}
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ILOAD 0)
(.visitJumpInsn Opcodes/IFGE $do-a-round)
(.visitVarInsn Opcodes/ALOAD 1)
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; {carry}
(.visitLabel $do-a-round)
(.visitVarInsn Opcodes/ALOAD 1)
(.visitVarInsn Opcodes/ILOAD 0)
(.visitInsn Opcodes/BALOAD) ;; {carry, current-digit}
(.visitLdcInsn (int 5))
(.visitInsn Opcodes/IMUL)
(.visitInsn Opcodes/IADD) ;; {next-raw-digit}
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 10))
(.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit}
(.visitVarInsn Opcodes/ALOAD 1)
(.visitVarInsn Opcodes/ILOAD 0)
swap2x1
(.visitInsn Opcodes/BASTORE) ;; {next-raw-digit}
(.visitLdcInsn (int 10))
(.visitInsn Opcodes/IDIV) ;; {next-carry}
;; Decrement index
(.visitVarInsn Opcodes/ILOAD 0)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ISTORE 0)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$loop-start (new Label)
$do-a-round (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac_digit_power" "(I)[B" nil nil)
(.visitCode)
;; Initialize digits array.
(.visitLdcInsn (int frac-bits))
(.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits}
(.visitInsn Opcodes/DUP)
(.visitVarInsn Opcodes/ILOAD 0)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/BASTORE) ;; digits = 5^0
(.visitVarInsn Opcodes/ASTORE 1)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitVarInsn Opcodes/ILOAD 0) ;; {times}
(.visitLabel $loop-start)
(.visitInsn Opcodes/DUP)
(.visitJumpInsn Opcodes/IFGE $do-a-round)
(.visitVarInsn Opcodes/ALOAD 1)
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $do-a-round)
;; {times}
(.visitVarInsn Opcodes/ILOAD 0)
(.visitVarInsn Opcodes/ALOAD 1)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times}
(.visitVarInsn Opcodes/ASTORE 1) ;; {times}
;; Decrement index
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
;; {times-1}
(.visitJumpInsn Opcodes/GOTO $loop-start)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$loop-start (new Label)
$do-a-round (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_frac_digit_powers" "([B[B)[B" nil nil)
(.visitCode)
(.visitLdcInsn (int (dec frac-bits)))
(.visitVarInsn Opcodes/ISTORE 2) ;; Index
(.visitLdcInsn (int frac-bits))
(.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
(.visitVarInsn Opcodes/ASTORE 3) ;; added_digits
(.visitLdcInsn (int 0)) ;; {carry}
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; {carry}
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitJumpInsn Opcodes/IFGE $do-a-round)
;; {carry}
(.visitVarInsn Opcodes/ALOAD 3)
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; {carry}
(.visitLabel $do-a-round)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitInsn Opcodes/BALOAD) ;; {carry, dL}
(.visitVarInsn Opcodes/ALOAD 1)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR}
(.visitInsn Opcodes/IADD)
(.visitInsn Opcodes/IADD) ;; {raw-next-digit}
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 10))
(.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit}
(.visitVarInsn Opcodes/ALOAD 3)
(.visitVarInsn Opcodes/ILOAD 2)
swap2x1
(.visitInsn Opcodes/BASTORE) ;; {raw-next-digit}
(.visitLdcInsn (int 10))
(.visitInsn Opcodes/IDIV) ;; {next-carry}
;; Decrement index
(.visitVarInsn Opcodes/ILOAD 2)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ISTORE 2)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$loop-start (new Label)
$do-a-round (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac_digits_to_text" "([B)Ljava/lang/String;" nil nil)
(.visitCode)
(.visitLdcInsn (int (dec frac-bits)))
(.visitVarInsn Opcodes/ISTORE 1) ;; Index
(.visitLdcInsn "") ;; {text}
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitJumpInsn Opcodes/IFGE $do-a-round)
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $do-a-round)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitInsn Opcodes/BALOAD) ;; {text, digit}
(.visitLdcInsn (int 10)) ;; {text, digit, radix}
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char}
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text}
(.visitInsn Opcodes/SWAP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
;; Decrement index
(.visitVarInsn Opcodes/ILOAD 1)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ISTORE 1)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$loop-start (new Label)
$do-a-round (new Label)
$not-set (new Label)
$next-iteration (new Label)
$normal-path (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_frac" "(J)Ljava/lang/String;" nil nil)
(.visitCode)
;; A quick corner-case to handle.
(.visitVarInsn Opcodes/LLOAD 0)
(.visitLdcInsn (long 0))
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFNE $normal-path)
(.visitLdcInsn ".0")
(.visitInsn Opcodes/ARETURN)
(.visitLabel $normal-path)
;; Normal case
(.visitLdcInsn (int (dec frac-bits)))
(.visitVarInsn Opcodes/ISTORE 2) ;; Index
(.visitLdcInsn (int frac-bits))
(.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
(.visitVarInsn Opcodes/ASTORE 3) ;; digits
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitJumpInsn Opcodes/IFGE $do-a-round)
;; Prepare text to return.
(.visitVarInsn Opcodes/ALOAD 3)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "frac_digits_to_text" "([B)Ljava/lang/String;")
(.visitLdcInsn ".")
(.visitInsn Opcodes/SWAP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
;; Trim unnecessary 0s at the end...
(.visitLdcInsn "0*$")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;")
(.visitLdcInsn (int 0))
(.visitInsn Opcodes/AALOAD)
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $do-a-round)
(.visitVarInsn Opcodes/LLOAD 0)
(.visitVarInsn Opcodes/ILOAD 2)
bit-set-64?
(.visitJumpInsn Opcodes/IFEQ $next-iteration)
(.visitLdcInsn (int (dec frac-bits)))
(.visitVarInsn Opcodes/ILOAD 2)
(.visitInsn Opcodes/ISUB)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "frac_digit_power" "(I)[B")
(.visitVarInsn Opcodes/ALOAD 3)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_frac_digit_powers" "([B[B)[B")
(.visitVarInsn Opcodes/ASTORE 3)
(.visitJumpInsn Opcodes/GOTO $next-iteration)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $next-iteration)
;; Decrement index
(.visitVarInsn Opcodes/ILOAD 2)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ISTORE 2)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$loop-start (new Label)
$do-a-round (new Label)
$not-set (new Label)
$next-iteration (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac_text_to_digits" "(Ljava/lang/String;)[B" nil nil)
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ISTORE 1) ;; Index
(.visitLdcInsn (int frac-bits))
(.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
(.visitVarInsn Opcodes/ASTORE 2) ;; digits
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitJumpInsn Opcodes/IFGE $do-a-round)
(.visitVarInsn Opcodes/ALOAD 2)
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $do-a-round)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/IADD)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B")
;; Set digit
(.visitVarInsn Opcodes/ALOAD 2)
(.visitVarInsn Opcodes/ILOAD 1)
swap2x1
(.visitInsn Opcodes/BASTORE)
;; Decrement index
(.visitVarInsn Opcodes/ILOAD 1)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ISTORE 1)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$loop-start (new Label)
$do-a-round (new Label)
$is-less-than (new Label)
$is-equal (new Label)]
;; [B0 <= [B1
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac_digits_lt" "([B[B)Z" nil nil)
(.visitCode)
(.visitLdcInsn (int 0))
(.visitVarInsn Opcodes/ISTORE 2) ;; Index
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitLdcInsn (int frac-bits))
(.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round)
(.visitLdcInsn false)
(.visitInsn Opcodes/IRETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $do-a-round)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitInsn Opcodes/BALOAD) ;; {D0}
(.visitVarInsn Opcodes/ALOAD 1)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitInsn Opcodes/BALOAD) ;; {D0, D1}
(.visitInsn Opcodes/DUP2)
(.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than)
(.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal)
;; Is greater than...
(.visitLdcInsn false)
(.visitInsn Opcodes/IRETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $is-less-than)
(.visitInsn Opcodes/POP2)
(.visitLdcInsn true)
(.visitInsn Opcodes/IRETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $is-equal)
;; Increment index
(.visitVarInsn Opcodes/ILOAD 2)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/IADD)
(.visitVarInsn Opcodes/ISTORE 2)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$loop-start (new Label)
$do-a-round (new Label)
$simple-sub (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac_digits_sub_once" "([BBI)[B" nil nil)
(.visitCode)
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit}
(.visitInsn Opcodes/BALOAD)
(.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit}
(.visitInsn Opcodes/DUP2)
(.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Since $0 < $1
(.visitInsn Opcodes/SWAP)
(.visitInsn Opcodes/ISUB) ;; $1 - $0
(.visitLdcInsn (byte 10))
(.visitInsn Opcodes/SWAP)
(.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 2)
swap2x1
(.visitInsn Opcodes/BASTORE)
;; Prepare to iterate...
;; Decrement index
(.visitVarInsn Opcodes/ILOAD 2)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ISTORE 2)
;; Subtract 1 from next digit
(.visitLdcInsn (int 1))
(.visitVarInsn Opcodes/ISTORE 1)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $simple-sub)
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 2)
swap2x1
(.visitInsn Opcodes/BASTORE)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$loop-start (new Label)
$do-a-round (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac_digits_sub" "([B[B)[B" nil nil)
(.visitCode)
(.visitLdcInsn (int (dec frac-bits)))
(.visitVarInsn Opcodes/ISTORE 2) ;; Index
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitJumpInsn Opcodes/IFGE $do-a-round)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $do-a-round)
(.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits}
(.visitVarInsn Opcodes/ALOAD 1)
(.visitVarInsn Opcodes/ILOAD 2)
(.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit}
(.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx}
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "frac_digits_sub_once" "([BBI)[B")
(.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits
;; Decrement index
(.visitVarInsn Opcodes/ILOAD 2)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitVarInsn Opcodes/ISTORE 2)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
(.visitMaxs 0 0)
(.visitEnd)))
_ (let [$from (new Label)
$to (new Label)
$handler (new Label)
$loop-start (new Label)
$do-a-round (new Label)
$skip-power (new Label)
$iterate (new Label)
$bad-format (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_frac" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
(.visitCode)
;; Check prefix
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn ".")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z")
(.visitJumpInsn Opcodes/IFEQ $bad-format)
;; Check if size is valid
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
(.visitLdcInsn (int (inc frac-bits))) ;; It's increased, to account for the prefix .
(.visitJumpInsn Opcodes/IF_ICMPGT $bad-format)
;; Initialization
(.visitTryCatchBlock $from $to $handler "java/lang/Exception")
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn (int 1))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;")
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;")
(.visitLabel $from)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "frac_text_to_digits" "(Ljava/lang/String;)[B")
(.visitLabel $to)
(.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits...
(.visitLdcInsn (int 0))
(.visitVarInsn Opcodes/ISTORE 1) ;; Index
(.visitLdcInsn (long 0))
(.visitVarInsn Opcodes/LSTORE 2) ;; Output
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $loop-start)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitLdcInsn (int frac-bits))
(.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round)
(.visitVarInsn Opcodes/LLOAD 2)
&&/wrap-long
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $do-a-round)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "frac_digit_power" "(I)[B")
(.visitInsn Opcodes/DUP2)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "frac_digits_lt" "([B[B)Z")
(.visitJumpInsn Opcodes/IFNE $skip-power)
;; Subtract power
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "frac_digits_sub" "([B[B)[B")
(.visitVarInsn Opcodes/ASTORE 0)
;; Set bit on output
(.visitVarInsn Opcodes/LLOAD 2)
(.visitLdcInsn (long 1))
(.visitVarInsn Opcodes/ILOAD 1)
(.visitLdcInsn (int (dec frac-bits)))
(.visitInsn Opcodes/SWAP)
(.visitInsn Opcodes/ISUB)
(.visitInsn Opcodes/LSHL)
(.visitInsn Opcodes/LOR)
(.visitVarInsn Opcodes/LSTORE 2)
(.visitJumpInsn Opcodes/GOTO $iterate)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $skip-power)
(.visitInsn Opcodes/POP2)
;; (.visitJumpInsn Opcodes/GOTO $iterate)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $iterate)
(.visitVarInsn Opcodes/ILOAD 1)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/IADD)
(.visitVarInsn Opcodes/ISTORE 1)
;; Iterate
(.visitJumpInsn Opcodes/GOTO $loop-start)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $handler)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitLabel $bad-format)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))]
nil))
(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
(defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class]
(|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677
_ (let [$from (new Label)
$to (new Label)
$handler (new Label)
$good-start (new Label)
$short-enough (new Label)
$bad-digit (new Label)
$out-of-bounds (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitTryCatchBlock $from $to $handler "java/lang/Exception")
(.visitLabel $from)
;; Remove the + at the beginning...
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn (int 0))
(.visitLdcInsn (int 1))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
(.visitLdcInsn "+")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
(.visitJumpInsn Opcodes/IFNE $good-start)
;; Doesn't start with +
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
;; Starts with +
(.visitLabel $good-start)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn (int 1))
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
(.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix...
;; Begin parsing processs
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
(.visitLdcInsn (int 18))
(.visitJumpInsn Opcodes/IF_ICMPLE $short-enough)
;; Too long
;; Get prefix...
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn (int 0))
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J")
(.visitInsn Opcodes/DUP2) ;; Clone prefix, for later...
;; Get last digit...
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/ISUB)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C")
(.visitLdcInsn (int 10))
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I")
;; Test last digit...
(.visitInsn Opcodes/DUP)
(.visitJumpInsn Opcodes/IFLT $bad-digit)
;; Good digit...
;; Stack: prefix::L, prefix::L, last-digit::I
(.visitInsn Opcodes/I2L)
;; Build the result...
swap2
(.visitLdcInsn (long 10))
(.visitInsn Opcodes/LMUL)
(.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L
(.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L
swap2 ;; Stack: result::L, result::L, prefix::L
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
(.visitJumpInsn Opcodes/IFLT $out-of-bounds)
;; Within bounds
;; Stack: result::L
&&/wrap-long
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
;; Out of bounds
(.visitLabel $out-of-bounds)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
;; Bad digit...
(.visitLabel $bad-digit)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
;; 18 chars or less
(.visitLabel $short-enough)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J")
&&/wrap-long
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitLabel $to)
(.visitLabel $handler)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172
_ (let [$too-big (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil)
(.visitCode)
(.visitLdcInsn "+")
(.visitVarInsn Opcodes/LLOAD 0)
(.visitLdcInsn (long 0))
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFLT $too-big)
;; then
(.visitVarInsn Opcodes/LLOAD 0)
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
(.visitInsn Opcodes/ARETURN)
;; else
(.visitLabel $too-big)
;; Set up parts of the number string...
;; First digits
(.visitVarInsn Opcodes/LLOAD 0)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/LUSHR)
(.visitLdcInsn (long 5))
(.visitInsn Opcodes/LDIV) ;; quot
;; Last digit
(.visitInsn Opcodes/DUP2)
(.visitLdcInsn (long 10))
(.visitInsn Opcodes/LMUL)
(.visitVarInsn Opcodes/LLOAD 0)
swap2
(.visitInsn Opcodes/LSUB) ;; quot, rem
;; Conversion to string...
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem*
(.visitInsn Opcodes/DUP_X2);; rem*, quot, rem*
(.visitInsn Opcodes/POP) ;; rem*, quot
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot*
(.visitInsn Opcodes/SWAP) ;; quot*, rem*
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215
_ (let [$simple-case (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil)
(.visitCode)
(.visitVarInsn Opcodes/LLOAD 0)
(.visitLdcInsn (long 0))
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFGE $simple-case)
;; else
(.visitVarInsn Opcodes/LLOAD 0)
(.visitLdcInsn (int 32))
(.visitInsn Opcodes/LUSHR)
(.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
(.visitLdcInsn (int 32))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;")
(.visitVarInsn Opcodes/LLOAD 0)
(.visitLdcInsn (int 32))
(.visitInsn Opcodes/LSHL)
(.visitLdcInsn (int 32))
(.visitInsn Opcodes/LUSHR)
(.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
(.visitInsn Opcodes/ARETURN)
;; then
(.visitLabel $simple-case)
(.visitVarInsn Opcodes/LLOAD 0)
(.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil)
(.visitCode)
(.visitVarInsn Opcodes/LLOAD 0)
(.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J")
(.visitInsn Opcodes/LADD)
(.visitVarInsn Opcodes/LLOAD 2)
(.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J")
(.visitInsn Opcodes/LADD)
(.visitInsn Opcodes/LCMP)
(.visitInsn Opcodes/IRETURN)
(.visitMaxs 0 0)
(.visitEnd))
;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290
_ (let [$case-1 (new Label)
$0 (new Label)
$case-2 (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil)
(.visitCode)
;; Test #1
(.visitVarInsn Opcodes/LLOAD 2)
(.visitLdcInsn (long 0))
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFLT $case-1)
;; Test #2
(.visitVarInsn Opcodes/LLOAD 0)
(.visitLdcInsn (long 0))
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFGT $case-2)
;; Case #3
(.visitVarInsn Opcodes/LLOAD 0)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
(.visitVarInsn Opcodes/LLOAD 2)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J")
(.visitInsn Opcodes/LRETURN)
;; Case #2
(.visitLabel $case-2)
(.visitVarInsn Opcodes/LLOAD 0)
(.visitVarInsn Opcodes/LLOAD 2)
(.visitInsn Opcodes/LDIV)
(.visitInsn Opcodes/LRETURN)
;; Case #1
(.visitLabel $case-1)
(.visitVarInsn Opcodes/LLOAD 0)
(.visitVarInsn Opcodes/LLOAD 2)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
(.visitJumpInsn Opcodes/IFLT $0)
;; 1
(.visitLdcInsn (long 1))
(.visitInsn Opcodes/LRETURN)
;; 0
(.visitLabel $0)
(.visitLdcInsn (long 0))
(.visitInsn Opcodes/LRETURN)
(.visitMaxs 0 0)
(.visitEnd)))
;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323
_ (let [$test-2 (new Label)
$case-2 (new Label)]
(doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil)
(.visitCode)
;; Test #1
(.visitVarInsn Opcodes/LLOAD 0)
(.visitLdcInsn (long 0))
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFLE $test-2)
(.visitVarInsn Opcodes/LLOAD 2)
(.visitLdcInsn (long 0))
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFLE $test-2)
;; Case #1
(.visitVarInsn Opcodes/LLOAD 0)
(.visitVarInsn Opcodes/LLOAD 2)
(.visitInsn Opcodes/LREM)
(.visitInsn Opcodes/LRETURN)
;; Test #2
(.visitLabel $test-2)
(.visitVarInsn Opcodes/LLOAD 0)
(.visitVarInsn Opcodes/LLOAD 2)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
(.visitJumpInsn Opcodes/IFLT $case-2)
;; Case #3
(.visitVarInsn Opcodes/LLOAD 0)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
(.visitVarInsn Opcodes/LLOAD 2)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J")
(.visitInsn Opcodes/LRETURN)
;; Case #2
(.visitLabel $case-2)
(.visitVarInsn Opcodes/LLOAD 0)
(.visitInsn Opcodes/LRETURN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(.visitMaxs 0 0)
(.visitEnd)))]
nil)))
(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class]
(|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil)
(.visitCode)
(.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn "Invalid expression for pattern-matching.")
(.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V")
(.visitInsn Opcodes/ATHROW)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitLdcInsn (int 2))
(.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
(.visitVarInsn Opcodes/ALOAD 0)
(.visitInsn Opcodes/AASTORE)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1))
(.visitVarInsn Opcodes/ALOAD 1)
(.visitInsn Opcodes/AASTORE)
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn (int 0))
(.visitInsn Opcodes/AALOAD)
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/AALOAD)
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))]
nil))
(def compile-LuxRT-class
(|do [_ (return nil)
:let [full-name &&/lux-utils-class
super-class (&host-generics/->bytecode-class-name "java.lang.Object")
tag-sig (&host-generics/->type-signature "java.lang.String")
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
full-name nil super-class (into-array String [])))
=unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag)
(.visitEnd))
=init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil)
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
(.visitLdcInsn "LOG: ")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V")
(.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V")
(.visitVarInsn Opcodes/ALOAD 0)
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I
(.visitInsn Opcodes/ACONST_NULL) ;; I?
(.visitLdcInsn &/unit-tag) ;; I?U
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
(.visitCode)
(.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I
(.visitLdcInsn "") ;; I?
(.visitVarInsn Opcodes/ALOAD 0) ;; I?O
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil)
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitLdcInsn "_")
(.visitLdcInsn "")
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
_ (doto =class
(compile-LuxRT-pm-methods)
(compile-LuxRT-adt-methods)
(compile-LuxRT-nat-methods)
(compile-LuxRT-frac-methods))]]
(&&/save-class! (second (string/split &&/lux-utils-class #"/"))
(.toByteArray (doto =class .visitEnd)))))
(defn ^:private compile-jvm-try [compile ?values special-args]
(|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
:let [$from (new Label)
$to (new Label)
$handler (new Label)
$end (new Label)]
:let [_ (doto *writer*
(.visitTryCatchBlock $from $to $handler "java/lang/Exception")
(.visitLabel $from))]
_ (compile ?body)
:let [_ (doto *writer*
(.visitJumpInsn Opcodes/GOTO $end)
(.visitLabel $to)
(.visitLabel $handler))]
_ (compile ?catch)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
(.visitInsn Opcodes/SWAP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
:let [_ (.visitLabel *writer* $end)]]
(return nil)))
(do-template [ ]
(defn [compile _?value special-args]
(|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name ))
(.visitInsn Opcodes/DUP))]
_ (compile ?value)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name ))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) )
(.visitInsn )
(.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name ) init-method ))]]
(return nil)))
^:private compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V"
^:private compile-jvm-d2i Opcodes/D2I "java.lang.Double" "doubleValue" "()D" "java.lang.Integer" "(I)V"
^:private compile-jvm-d2l Opcodes/D2L "java.lang.Double" "doubleValue" "()D" "java.lang.Long" "(J)V"
^:private compile-jvm-f2d Opcodes/F2D "java.lang.Float" "floatValue" "()F" "java.lang.Double" "(D)V"
^:private compile-jvm-f2i Opcodes/F2I "java.lang.Float" "floatValue" "()F" "java.lang.Integer" "(I)V"
^:private compile-jvm-f2l Opcodes/F2L "java.lang.Float" "floatValue" "()F" "java.lang.Long" "(J)V"
^:private compile-jvm-i2b Opcodes/I2B "java.lang.Integer" "intValue" "()I" "java.lang.Byte" "(B)V"
^:private compile-jvm-i2c Opcodes/I2C "java.lang.Integer" "intValue" "()I" "java.lang.Character" "(C)V"
^:private compile-jvm-i2d Opcodes/I2D "java.lang.Integer" "intValue" "()I" "java.lang.Double" "(D)V"
^:private compile-jvm-i2f Opcodes/I2F "java.lang.Integer" "intValue" "()I" "java.lang.Float" "(F)V"
^:private compile-jvm-i2l Opcodes/I2L "java.lang.Integer" "intValue" "()I" "java.lang.Long" "(J)V"
^:private compile-jvm-i2s Opcodes/I2S "java.lang.Integer" "intValue" "()I" "java.lang.Short" "(S)V"
^:private compile-jvm-l2d Opcodes/L2D "java.lang.Long" "longValue" "()J" "java.lang.Double" "(D)V"
^:private compile-jvm-l2f Opcodes/L2F "java.lang.Long" "longValue" "()J" "java.lang.Float" "(F)V"
^:private compile-jvm-l2i Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Integer" "(I)V"
^:private compile-jvm-c2b Opcodes/I2B "java.lang.Character" "charValue" "()C" "java.lang.Byte" "(B)V"
^:private compile-jvm-c2s Opcodes/I2S "java.lang.Character" "charValue" "()C" "java.lang.Short" "(S)V"
^:private compile-jvm-c2i Opcodes/NOP "java.lang.Character" "charValue" "()C" "java.lang.Integer" "(I)V"
^:private compile-jvm-c2l Opcodes/I2L "java.lang.Character" "charValue" "()C" "java.lang.Long" "(J)V"
^:private compile-jvm-s2l Opcodes/I2L "java.lang.Short" "shortValue" "()S" "java.lang.Long" "(J)V"
^:private compile-jvm-b2l Opcodes/I2L "java.lang.Byte" "byteValue" "()B" "java.lang.Long" "(J)V"
)
(do-template [ ]
(defn [compile _?value special-args]
(|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name ))
(.visitInsn Opcodes/DUP))]
_ (compile ?value)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name ))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) )
(.visitInsn Opcodes/L2I)
(.visitInsn )
(.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name ) init-method ))]]
(return nil)))
^:private compile-jvm-l2s Opcodes/I2S "java.lang.Long" "longValue" "()J" "java.lang.Short" "(S)V"
^:private compile-jvm-l2b Opcodes/I2B "java.lang.Long" "longValue" "()J" "java.lang.Byte" "(B)V"
)
(do-template [ ]
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name ))
(.visitInsn Opcodes/DUP))]
_ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name ))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) ))]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name ))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name ) ))]
:let [_ (doto *writer*
(.visitInsn )
(.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name ) init-method ))]]
(return nil)))
^:private compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
^:private compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
^:private compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
^:private compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
^:private compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
^:private compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
^:private compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
^:private compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
^:private compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
^:private compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
^:private compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
^:private compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
)
(do-template [ ]
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name )]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))
_ (doto *writer*
(.visitInsn )
())]]
(return nil)))
^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int
^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int
^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int
^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int
^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int
^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float
^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float
^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float
^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float
^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float
^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double
^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double
^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double
^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double
^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double
)
(do-template [ ]
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name )]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))
$then (new Label)
$end (new Label)
_ (doto *writer*
(.visitJumpInsn $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)))
^:private compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I"
^:private compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I"
^:private compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I"
^:private compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C"
^:private compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C"
^:private compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C"
)
(do-template [ ]
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name )]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))
$then (new Label)
$end (new Label)
_ (doto *writer*
(.visitInsn )
(.visitLdcInsn (int ))
(.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)))
^:private compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J"
^:private compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J"
^:private compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J"
^:private compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F"
^:private compile-jvm-flt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F"
^:private compile-jvm-fgt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F"
^:private compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D"
^:private compile-jvm-dlt Opcodes/DCMPG -1 "java.lang.Double" "doubleValue" "()D"
^:private compile-jvm-dgt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D"
)
(do-template [ ]
(do (defn [compile ?values special-args]
(|do [:let [(&/$Cons ?length (&/$Nil)) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
_ (compile ?length)
:let [_ (doto *writer*
&&/unwrap-long
(.visitInsn Opcodes/L2I))]
:let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]]
(return nil)))
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
_ (compile ?array)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )]
_ (compile ?idx)
:let [_ (doto *writer*
&&/unwrap-long
(.visitInsn Opcodes/L2I))]
:let [_ (doto *writer*
(.visitInsn )
)]]
(return nil)))
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
_ (compile ?array)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )]
:let [_ (.visitInsn *writer* Opcodes/DUP)]
_ (compile ?idx)
:let [_ (doto *writer*
&&/unwrap-long
(.visitInsn Opcodes/L2I))]
_ (compile ?elem)
:let [_ (doto *writer*
(.visitInsn ))]]
(return nil)))
)
Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean
Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte
Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short
Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int
Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long
Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float
Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double
Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char
)
(defn ^:private compile-jvm-anewarray [compile ?values special-args]
(|do [:let [(&/$Cons ?length (&/$Nil)) ?values
(&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?length)
:let [_ (doto *writer*
&&/unwrap-long
(.visitInsn Opcodes/L2I))]
:let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]]
(return nil)))
(defn ^:private compile-jvm-aaload [compile ?values special-args]
(|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
array-type (&host/->java-sig (&a/expr-type* ?array))
_ (compile ?array)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
_ (compile ?idx)
:let [_ (doto *writer*
&&/unwrap-long
(.visitInsn Opcodes/L2I))]
:let [_ (.visitInsn *writer* Opcodes/AALOAD)]]
(return nil)))
(defn ^:private compile-jvm-aastore [compile ?values special-args]
(|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
array-type (&host/->java-sig (&a/expr-type* ?array))
_ (compile ?array)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
:let [_ (.visitInsn *writer* Opcodes/DUP)]
_ (compile ?idx)
:let [_ (doto *writer*
&&/unwrap-long
(.visitInsn Opcodes/L2I))]
_ (compile ?elem)
:let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
(return nil)))
(defn ^:private compile-jvm-arraylength [compile ?values special-args]
(|do [:let [(&/$Cons ?array (&/$Nil)) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
array-type (&host/->java-sig (&a/expr-type* ?array))
_ (compile ?array)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
:let [_ (doto *writer*
(.visitInsn Opcodes/ARRAYLENGTH)
(.visitInsn Opcodes/I2L)
&&/wrap-long)]]
(return nil)))
(defn ^:private compile-jvm-null [compile ?values special-args]
(|do [:let [;; (&/$Nil) ?values
(&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
:let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
(return nil)))
(defn ^:private compile-jvm-null? [compile ?values special-args]
(|do [:let [(&/$Cons ?object (&/$Nil)) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
_ (compile ?object)
:let [$then (new Label)
$end (new Label)
_ (doto *writer*
(.visitJumpInsn Opcodes/IFNULL $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)))
(defn compile-jvm-synchronized [compile ?values special-args]
(|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
_ (compile ?monitor)
:let [_ (doto *writer*
(.visitInsn Opcodes/DUP)
(.visitInsn Opcodes/MONITORENTER))]
_ (compile ?expr)
:let [_ (doto *writer*
(.visitInsn Opcodes/SWAP)
(.visitInsn Opcodes/MONITOREXIT))]]
(return nil)))
(defn ^:private compile-jvm-throw [compile ?values special-args]
(|do [:let [(&/$Cons ?ex (&/$Nil)) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
_ (compile ?ex)
:let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
(return nil)))
(defn ^:private compile-jvm-getstatic [compile ?values special-args]
(|do [:let [;; (&/$Nil) ?values
(&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
^MethodVisitor *writer* &/get-writer
=output-type (&host/->java-sig ?output-type)
:let [_ (doto *writer*
(.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type)
(prepare-return! ?output-type))]]
(return nil)))
(defn ^:private compile-jvm-getfield [compile ?values special-args]
(|do [:let [(&/$Cons ?object (&/$Nil)) ?values
(&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
:let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
_ (compile ?object)
=output-type (&host/->java-sig ?output-type)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST class*)
(.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type)
(prepare-return! ?output-type))]]
(return nil)))
(defn ^:private compile-jvm-putstatic [compile ?values special-args]
(|do [:let [(&/$Cons ?value (&/$Nil)) ?values
(&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?value)
:let [=input-sig (&host-type/gclass->sig input-gclass)
_ (doto *writer*
(prepare-arg! (&host-generics/gclass->class-name input-gclass))
(.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig)
(.visitInsn Opcodes/ACONST_NULL))]]
(return nil)))
(defn ^:private compile-jvm-putfield [compile ?values special-args]
(|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values
(&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args]
:let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
_ (compile ?object)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)]
_ (compile ?value)
=input-sig (&host/->java-sig ?input-type)
:let [_ (doto *writer*
(prepare-arg! (&host-generics/gclass->class-name input-gclass))
(.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig)
(.visitInsn Opcodes/ACONST_NULL))]]
(return nil)))
(defn ^:private compile-jvm-invokestatic [compile ?values special-args]
(|do [:let [?args ?values
(&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args]
^MethodVisitor *writer* &/get-writer
:let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))]
_ (&/map2% (fn [class-name arg]
(|do [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret)))
?classes ?args)
:let [_ (doto *writer*
(.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig)
(prepare-return! ?output-type))]]
(return nil)))
(do-template [ ]
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?object ?args) ?values
(&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args]
:let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
:let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))]
_ (compile ?object)
:let [_ (when (not= "" ?method)
(.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))]
_ (&/map2% (fn [class-name arg]
(|do [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret)))
?classes ?args)
:let [_ (doto *writer*
(.visitMethodInsn ?class* ?method method-sig)
(prepare-return! ?output-type))]]
(return nil)))
^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL
^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE
^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL
)
(defn ^:private compile-jvm-new [compile ?values special-args]
(|do [:let [?args ?values
(&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args]
^MethodVisitor *writer* &/get-writer
:let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V")
class* (&host-generics/->bytecode-class-name ?class)
_ (doto *writer*
(.visitTypeInsn Opcodes/NEW class*)
(.visitInsn Opcodes/DUP))]
_ (&/map% (fn [class-name+arg]
(|do [:let [[class-name arg] class-name+arg]
ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret)))
(&/zip2 ?classes ?args))
:let [_ (doto *writer*
(.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]]
(return nil)))
(defn ^:private compile-jvm-try [compile ?values special-args]
(|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
:let [$from (new Label)
$to (new Label)
$handler (new Label)
$end (new Label)]
:let [_ (doto *writer*
(.visitTryCatchBlock $from $to $handler "java/lang/Exception")
(.visitLabel $from))]
_ (compile ?body)
:let [_ (doto *writer*
(.visitJumpInsn Opcodes/GOTO $end)
(.visitLabel $to)
(.visitLabel $handler))]
_ (compile ?catch)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
(.visitInsn Opcodes/SWAP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
:let [_ (.visitLabel *writer* $end)]]
(return nil)))
(defn ^:private compile-jvm-load-class [compile ?values special-args]
(|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args]
^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitLdcInsn _class-name)
(.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;")
(prepare-return! ?output-type))]]
(return nil)))
(defn ^:private compile-jvm-instanceof [compile ?values special-args]
(|do [:let [(&/$Cons object (&/$Nil)) ?values
(&/$Cons class (&/$Nil)) special-args]
:let [class* (&host-generics/->bytecode-class-name class)]
^MethodVisitor *writer* &/get-writer
_ (compile object)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/INSTANCEOF class*)
(&&/wrap-boolean))]]
(return nil)))
(defn ^:private compile-array-get [compile ?values special-args]
(|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
;; (&/$Nil) special-args
]
^MethodVisitor *writer* &/get-writer
array-type (&host/->java-sig (&a/expr-type* ?array))
_ (compile ?array)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
_ (compile ?idx)
:let [_ (doto *writer*
&&/unwrap-long
(.visitInsn Opcodes/L2I))]
:let [_ (.visitInsn *writer* Opcodes/AALOAD)]
:let [$is-null (new Label)
$end (new Label)
_ (doto *writer*
(.visitInsn Opcodes/DUP)
(.visitJumpInsn Opcodes/IFNULL $is-null)
(.visitLdcInsn (int 1))
(.visitLdcInsn "")
(.visitInsn Opcodes/DUP2_X1) ;; I?2I?
(.visitInsn Opcodes/POP2) ;; I?2
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitJumpInsn Opcodes/GOTO $end)
(.visitLabel $is-null)
(.visitInsn Opcodes/POP)
(.visitLdcInsn (int 0))
(.visitInsn Opcodes/ACONST_NULL)
(.visitLdcInsn &/unit-tag)
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitLabel $end))]]
(return nil)))
(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]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name )]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))
_ (doto *writer*
(.visitInsn )
())]]
(return nil)))
^:private compile-nat-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-nat-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-nat-mul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-frac-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-frac-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-frac-rem Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
^:private compile-frac-scale Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long
)
(do-template [ ]
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))
_ (doto *writer*
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J")
(&&/wrap-long))]]
(return nil)))
^:private compile-nat-div "div_nat"
^:private compile-nat-rem "rem_nat"
)
(do-template [ ]
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))
$then (new Label)
$end (new Label)
_ (doto *writer*
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
(.visitLdcInsn (int ))
(.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)))
^:private compile-nat-eq 0
^:private compile-frac-eq 0
^:private compile-frac-lt -1
)
(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
(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*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))
$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-frac-min-value (.visitLdcInsn 0) &&/wrap-long
^:private compile-frac-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-frac-encode "encode_frac" ^:private compile-frac-decode "decode_frac"
)
(do-template [ ]
(defn [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
&&/unwrap-long)]
_ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
&&/unwrap-long)]
:let [_ (doto *writer*
(.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J")
&&/wrap-long)]]
(return nil)))
^:private compile-frac-mul "mul_frac"
^:private compile-frac-div "div_frac"
)
(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-frac-to-real "java.lang.Long" "frac-to-real" "(J)D" &&/unwrap-long &&/wrap-double
^:private compile-real-to-frac "java.lang.Double" "real-to-frac" "(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]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)]
(return nil)))
^:private compile-nat-to-int
^:private compile-int-to-nat
)
(defn compile-host [compile proc-category proc-name ?values special-args]
(case proc-category
"lux"
(case proc-name
"==" (compile-lux-== 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)
)
"frac"
(case proc-name
"+" (compile-frac-add compile ?values special-args)
"-" (compile-frac-sub compile ?values special-args)
"*" (compile-frac-mul compile ?values special-args)
"/" (compile-frac-div compile ?values special-args)
"%" (compile-frac-rem compile ?values special-args)
"=" (compile-frac-eq compile ?values special-args)
"<" (compile-frac-lt compile ?values special-args)
"encode" (compile-frac-encode compile ?values special-args)
"decode" (compile-frac-decode compile ?values special-args)
"max-value" (compile-frac-max-value compile ?values special-args)
"min-value" (compile-frac-min-value compile ?values special-args)
"to-real" (compile-frac-to-real compile ?values special-args)
"scale" (compile-frac-scale compile ?values special-args)
)
"int"
(case proc-name
"to-nat" (compile-int-to-nat compile ?values special-args)
)
"real"
(case proc-name
"to-frac" (compile-real-to-frac compile ?values special-args)
)
"char"
(case proc-name
"to-nat" (compile-char-to-nat compile ?values special-args)
)
"jvm"
(case proc-name
"synchronized" (compile-jvm-synchronized compile ?values special-args)
"load-class" (compile-jvm-load-class compile ?values special-args)
"instanceof" (compile-jvm-instanceof compile ?values special-args)
"try" (compile-jvm-try compile ?values special-args)
"new" (compile-jvm-new compile ?values special-args)
"invokestatic" (compile-jvm-invokestatic compile ?values special-args)
"invokeinterface" (compile-jvm-invokeinterface compile ?values special-args)
"invokevirtual" (compile-jvm-invokevirtual compile ?values special-args)
"invokespecial" (compile-jvm-invokespecial compile ?values special-args)
"getstatic" (compile-jvm-getstatic compile ?values special-args)
"getfield" (compile-jvm-getfield compile ?values special-args)
"putstatic" (compile-jvm-putstatic compile ?values special-args)
"putfield" (compile-jvm-putfield compile ?values special-args)
"throw" (compile-jvm-throw compile ?values special-args)
"null?" (compile-jvm-null? compile ?values special-args)
"null" (compile-jvm-null compile ?values special-args)
"anewarray" (compile-jvm-anewarray compile ?values special-args)
"aaload" (compile-jvm-aaload compile ?values special-args)
"aastore" (compile-jvm-aastore compile ?values special-args)
"arraylength" (compile-jvm-arraylength compile ?values special-args)
"znewarray" (compile-jvm-znewarray compile ?values special-args)
"bnewarray" (compile-jvm-bnewarray compile ?values special-args)
"snewarray" (compile-jvm-snewarray compile ?values special-args)
"inewarray" (compile-jvm-inewarray compile ?values special-args)
"lnewarray" (compile-jvm-lnewarray compile ?values special-args)
"fnewarray" (compile-jvm-fnewarray compile ?values special-args)
"dnewarray" (compile-jvm-dnewarray compile ?values special-args)
"cnewarray" (compile-jvm-cnewarray compile ?values special-args)
"iadd" (compile-jvm-iadd compile ?values special-args)
"isub" (compile-jvm-isub compile ?values special-args)
"imul" (compile-jvm-imul compile ?values special-args)
"idiv" (compile-jvm-idiv compile ?values special-args)
"irem" (compile-jvm-irem compile ?values special-args)
"ieq" (compile-jvm-ieq compile ?values special-args)
"ilt" (compile-jvm-ilt compile ?values special-args)
"igt" (compile-jvm-igt compile ?values special-args)
"ceq" (compile-jvm-ceq compile ?values special-args)
"clt" (compile-jvm-clt compile ?values special-args)
"cgt" (compile-jvm-cgt compile ?values special-args)
"ladd" (compile-jvm-ladd compile ?values special-args)
"lsub" (compile-jvm-lsub compile ?values special-args)
"lmul" (compile-jvm-lmul compile ?values special-args)
"ldiv" (compile-jvm-ldiv compile ?values special-args)
"lrem" (compile-jvm-lrem compile ?values special-args)
"leq" (compile-jvm-leq compile ?values special-args)
"llt" (compile-jvm-llt compile ?values special-args)
"lgt" (compile-jvm-lgt compile ?values special-args)
"fadd" (compile-jvm-fadd compile ?values special-args)
"fsub" (compile-jvm-fsub compile ?values special-args)
"fmul" (compile-jvm-fmul compile ?values special-args)
"fdiv" (compile-jvm-fdiv compile ?values special-args)
"frem" (compile-jvm-frem compile ?values special-args)
"feq" (compile-jvm-feq compile ?values special-args)
"flt" (compile-jvm-flt compile ?values special-args)
"fgt" (compile-jvm-fgt compile ?values special-args)
"dadd" (compile-jvm-dadd compile ?values special-args)
"dsub" (compile-jvm-dsub compile ?values special-args)
"dmul" (compile-jvm-dmul compile ?values special-args)
"ddiv" (compile-jvm-ddiv compile ?values special-args)
"drem" (compile-jvm-drem compile ?values special-args)
"deq" (compile-jvm-deq compile ?values special-args)
"dlt" (compile-jvm-dlt compile ?values special-args)
"dgt" (compile-jvm-dgt compile ?values special-args)
"iand" (compile-jvm-iand compile ?values special-args)
"ior" (compile-jvm-ior compile ?values special-args)
"ixor" (compile-jvm-ixor compile ?values special-args)
"ishl" (compile-jvm-ishl compile ?values special-args)
"ishr" (compile-jvm-ishr compile ?values special-args)
"iushr" (compile-jvm-iushr compile ?values special-args)
"land" (compile-jvm-land compile ?values special-args)
"lor" (compile-jvm-lor compile ?values special-args)
"lxor" (compile-jvm-lxor compile ?values special-args)
"lshl" (compile-jvm-lshl compile ?values special-args)
"lshr" (compile-jvm-lshr compile ?values special-args)
"lushr" (compile-jvm-lushr compile ?values special-args)
"d2f" (compile-jvm-d2f compile ?values special-args)
"d2i" (compile-jvm-d2i compile ?values special-args)
"d2l" (compile-jvm-d2l compile ?values special-args)
"f2d" (compile-jvm-f2d compile ?values special-args)
"f2i" (compile-jvm-f2i compile ?values special-args)
"f2l" (compile-jvm-f2l compile ?values special-args)
"i2b" (compile-jvm-i2b compile ?values special-args)
"i2c" (compile-jvm-i2c compile ?values special-args)
"i2d" (compile-jvm-i2d compile ?values special-args)
"i2f" (compile-jvm-i2f compile ?values special-args)
"i2l" (compile-jvm-i2l compile ?values special-args)
"i2s" (compile-jvm-i2s compile ?values special-args)
"l2d" (compile-jvm-l2d compile ?values special-args)
"l2f" (compile-jvm-l2f compile ?values special-args)
"l2i" (compile-jvm-l2i compile ?values special-args)
"l2s" (compile-jvm-l2s compile ?values special-args)
"l2b" (compile-jvm-l2b compile ?values special-args)
"c2b" (compile-jvm-c2b compile ?values special-args)
"c2s" (compile-jvm-c2s compile ?values special-args)
"c2i" (compile-jvm-c2i compile ?values special-args)
"c2l" (compile-jvm-c2l compile ?values special-args)
"s2l" (compile-jvm-s2l compile ?values special-args)
"b2l" (compile-jvm-b2l compile ?values special-args)
;; else
(fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))
;; else
(fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))))