├── .gitignore ├── project.clj ├── src └── jise │ ├── misc.clj │ ├── macroexpand.clj │ ├── insns.clj │ ├── core.clj │ ├── simplify.clj │ ├── error.clj │ ├── utils.clj │ ├── type.clj │ └── emit.clj ├── deps.edn ├── CHANGELOG.md ├── examples └── example │ ├── quicksort.clj │ ├── graph.clj │ ├── heapsort.clj │ └── aobench.clj ├── .circleci └── config.yml ├── README.md ├── test └── jise │ ├── core_test.clj │ └── type_test.clj └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | profiles.clj 5 | pom.xml 6 | pom.xml.asc 7 | *.jar 8 | *.class 9 | /.cpcache 10 | /.lein-* 11 | /.nrepl-port 12 | .hgignore 13 | .hg/ 14 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject jise "0.1.0-SNAPSHOT" 2 | :description "JiSE: Java in S-Expression" 3 | :url "https://github.com/athos/JiSE" 4 | :license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0" 5 | :url "https://www.eclipse.org/legal/epl-2.0/"} 6 | :dependencies [[org.clojure/clojure "1.10.0"]] 7 | :repl-options {:init-ns jise.core} 8 | :profiles {:dev {:source-paths ["examples"]}}) 9 | -------------------------------------------------------------------------------- /src/jise/misc.clj: -------------------------------------------------------------------------------- 1 | (ns jise.misc) 2 | 3 | (defn strip-jise-ns [sym] 4 | (if (= (namespace sym) "jise.core") 5 | (symbol (name sym)) 6 | sym)) 7 | 8 | (defn resolve-ns [sym] 9 | (let [ns (namespace sym)] 10 | (if-let [orig (some->> ns symbol (get (ns-aliases *ns*)))] 11 | (symbol (str orig) (name sym)) 12 | sym))) 13 | 14 | (defn fixup-ns [sym] 15 | (strip-jise-ns (resolve-ns sym))) 16 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:src ["src"] 2 | :deps {org.clojure/clojure {:mvn/version "1.10.0"}} 3 | :aliases {:check {:extra-deps {athos/clj-check 4 | {:git/url "https://github.com/athos/clj-check.git" 5 | :sha "b48d4e7000586529f81c1e29069b503b57259514"}} 6 | :main-opts ["-m" "clj-check.check"]} 7 | :test {:extra-paths ["test"] 8 | :extra-deps {com.cognitect/test-runner 9 | {:git/url "https://github.com/cognitect-labs/test-runner.git" 10 | :sha "209b64504cb3bd3b99ecfec7937b358a879f55c1"}} 11 | :main-opts ["-m" "cognitect.test-runner"]} 12 | :examples {:extra-paths ["examples"]}}} 13 | -------------------------------------------------------------------------------- /src/jise/macroexpand.clj: -------------------------------------------------------------------------------- 1 | (ns jise.macroexpand 2 | (:refer-clojure :exclude [macroexpand]) 3 | (:require [jise.type :as t])) 4 | 5 | (defn macroexpand [cenv form] 6 | (let [expanded (macroexpand-1 form)] 7 | (if (identical? expanded form) 8 | (if-let [[op & args] (and (seq? form) 9 | (symbol? (first form)) 10 | (some->> (namespace (first form)) symbol (t/find-in-cenv cenv)) 11 | form)] 12 | (with-meta `(. ~(symbol (namespace op)) ~(symbol (name op)) ~@args) (meta form)) 13 | form) 14 | (recur cenv 15 | (cond-> expanded 16 | (instance? clojure.lang.IObj expanded) 17 | (vary-meta merge (meta form))))))) 18 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | All notable changes to this project will be documented in this file. This change log follows the conventions of [keepachangelog.com](http://keepachangelog.com/). 3 | 4 | ## [Unreleased] 5 | ### Changed 6 | - Add a new arity to `make-widget-async` to provide a different widget shape. 7 | 8 | ## [0.1.1] - 2019-02-21 9 | ### Changed 10 | - Documentation on how to make the widgets. 11 | 12 | ### Removed 13 | - `make-widget-sync` - we're all async, all the time. 14 | 15 | ### Fixed 16 | - Fixed widget maker to keep working when daylight savings switches over. 17 | 18 | ## 0.1.0 - 2019-02-21 19 | ### Added 20 | - Files from the new template. 21 | - Widget maker public API - `make-widget-sync`. 22 | 23 | [Unreleased]: https://github.com/your-name/jise/compare/0.1.1...HEAD 24 | [0.1.1]: https://github.com/your-name/jise/compare/0.1.0...0.1.1 25 | -------------------------------------------------------------------------------- /examples/example/quicksort.clj: -------------------------------------------------------------------------------- 1 | (ns example.quicksort 2 | (:gen-class) 3 | (:require [jise.core :refer [defclass]])) 4 | 5 | ^:public 6 | (defclass Quicksort 7 | ^:public ^:static 8 | (defm sort [^ints xs] 9 | (sort xs 0 (- (alength xs) 1))) 10 | 11 | ^:private ^:static 12 | (defm sort [^ints xs ^int left ^int right] 13 | (when (< left right) 14 | (let [p (aget xs (/ (+ left right) 2)) 15 | l left 16 | r right] 17 | (while (<= l r) 18 | (while (< (xs l) p) (inc! l)) 19 | (while (> (xs r) p) (dec! r)) 20 | (when (<= l r) 21 | (let [tmp (aget xs l)] 22 | (set! (xs l) (xs r)) 23 | (set! (xs r) tmp) 24 | (inc! l) 25 | (dec! r)))) 26 | (sort xs left r) 27 | (sort xs l right))))) 28 | 29 | (comment 30 | 31 | (def arr (int-array [3 1 4 1 5 9 2 6 5])) 32 | (Quicksort/sort arr) 33 | (seq arr) 34 | 35 | ) 36 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: clojure:tools-deps 6 | 7 | working_directory: ~/repo 8 | 9 | environment: 10 | LEIN_ROOT: "true" 11 | JVM_OPTS: -Xmx3200m 12 | 13 | steps: 14 | - checkout 15 | 16 | # Download and cache dependencies 17 | - restore_cache: 18 | key: v1-dependencies-{{ checksum "deps.edn" }} 19 | 20 | - run: clojure -R:check:test -Stree 21 | 22 | - save_cache: 23 | paths: 24 | - ~/.m2 25 | - ~/.gitlibs 26 | key: v1-dependencies-{{ checksum "deps.edn" }} 27 | 28 | - run: 29 | name: check 30 | command: clojure -A:examples:check src examples 31 | 32 | - run: 33 | name: test 34 | command: clojure -A:test 35 | 36 | # - run: 37 | # name: test coverage 38 | # command: | 39 | # clojure -A:test:coverage 40 | # bash <(curl -s https://codecov.io/bash) 41 | -------------------------------------------------------------------------------- /examples/example/graph.clj: -------------------------------------------------------------------------------- 1 | (ns example.graph 2 | (:require [jise.core :refer [defclass]])) 3 | 4 | ;; This example code is taken from [JLS §14.16](https://docs.oracle.com/javase/specs/jls/se12/html/jls-14.html#jls-14.16) 5 | 6 | ^:public 7 | (defclass Graph 8 | ^:public ^{:tag [[int]]} 9 | (def edges) 10 | 11 | ^:public 12 | (defm Graph [^{:tag [[int]]} edges] 13 | (set! (.-edges this) edges)) 14 | 15 | ^:public ^Graph 16 | (defm loseEdges [^int i ^int j] 17 | (let [n (alength edges) 18 | new-edges (new [[int]] n)] 19 | ^{:label :edgelist} 20 | (for [k 0 (< k n) (inc! k)] 21 | (let [z 0] 22 | ^{:label :search} 23 | (do (cond (== k i) 24 | (for [nil (< z (alength (edges k))) (inc! z)] 25 | (when (== (edges k z) j) 26 | (break :search))) 27 | (== k j) 28 | (for [nil (< z (alength (edges k))) (inc! z)] 29 | (when (== (edges k z) i) 30 | (break :search)))) 31 | (set! (new-edges k) (edges k)) 32 | (continue :edgelist)) 33 | (let [m (- (alength (edges k)) 1) 34 | ne (new [int] m)] 35 | (System/arraycopy (edges k) 0 ne 0 z) 36 | (System/arraycopy (edges k) (+ z 1) ne z (- m z)) 37 | (set! (new-edges k) ne)))) 38 | (Graph. new-edges)))) 39 | 40 | (comment 41 | 42 | (require '[jise.utils :as jise]) 43 | (def g (Graph. (jise/do (new [[int]] [[1 2 3] [3] [3] [0 2]])))) 44 | (def g' (.loseEdges g 0 3)) 45 | (mapv vec (.-edges g')) ;=> [[1 2] [3] [3] [2]] 46 | 47 | ) 48 | -------------------------------------------------------------------------------- /examples/example/heapsort.clj: -------------------------------------------------------------------------------- 1 | (ns example.heapsort 2 | (:refer-clojure :exclude [swap!]) 3 | (:require [jise.core :as j :refer [defclass]])) 4 | 5 | (defmacro parent [i] 6 | `(j// (j/- ~i 1) 2)) 7 | 8 | (defmacro left-child [i] 9 | `(j/+ (j/* 2 ~i) 1)) 10 | 11 | (defmacro right-child [i] 12 | `(j/+ (j/* 2 ~i) 2)) 13 | 14 | (defmacro swap! [arr i j] 15 | `(j/let [tmp# (~arr ~i)] 16 | (j/set! (~arr ~i) (~arr ~j)) 17 | (j/set! (~arr ~j) tmp#))) 18 | 19 | ^:public 20 | (defclass Heapsort 21 | ^:public ^:static 22 | (defm sort [^ints arr] 23 | (let [end (- (alength arr) 1)] 24 | (heapify! arr) 25 | (while (> end 0) 26 | (swap! arr end 0) 27 | (dec! end) 28 | (siftdown! arr 0 end)))) 29 | 30 | ^:private ^:static 31 | (defm heapify! [^ints arr] 32 | (let [end (- (alength arr) 1)] 33 | (for [start (parent end), (>= start 0), (dec! start)] 34 | (siftdown! arr start end)))) 35 | 36 | ^:private ^:static 37 | (defm siftdown! [^ints arr ^int start ^int end] 38 | (let [root start] 39 | (while (<= (left-child root) end) 40 | (let [left (left-child root) 41 | right (right-child root) 42 | swap root] 43 | (when (< (arr swap) (arr left)) 44 | (set! swap left)) 45 | (when (and (<= right end) (< (arr swap) (arr right))) 46 | (set! swap right)) 47 | (when (== swap root) 48 | (return)) 49 | (swap! arr root swap) 50 | (set! root swap))))) 51 | ) 52 | 53 | (comment 54 | 55 | (def arr (int-array [3 1 4 1 5 9 2 6 5])) 56 | (Heapsort/sort arr) 57 | (seq arr) 58 | 59 | ) 60 | -------------------------------------------------------------------------------- /src/jise/insns.clj: -------------------------------------------------------------------------------- 1 | (ns jise.insns 2 | (:require [jise.type :as t]) 3 | (:import [clojure.asm Opcodes])) 4 | 5 | (def const-insns 6 | {t/BOOLEAN {true Opcodes/ICONST_1, false Opcodes/ICONST_0} 7 | t/INT {-1 Opcodes/ICONST_M1, 0 Opcodes/ICONST_0 8 | 1 Opcodes/ICONST_1, 2 Opcodes/ICONST_2 9 | 3 Opcodes/ICONST_3,4 Opcodes/ICONST_4 10 | 5 Opcodes/ICONST_5} 11 | t/LONG {0 Opcodes/LCONST_0, 1 Opcodes/LCONST_1} 12 | t/FLOAT {0.0 Opcodes/FCONST_0, 1.0 Opcodes/FCONST_1 13 | 2.0 Opcodes/FCONST_2} 14 | t/DOUBLE {0.0 Opcodes/DCONST_0, 1.0 Opcodes/DCONST_1}}) 15 | 16 | (def arithmetic-insns 17 | {:add Opcodes/IADD 18 | :sub Opcodes/ISUB 19 | :mul Opcodes/IMUL 20 | :div Opcodes/IDIV 21 | :rem Opcodes/IREM 22 | :bitwise-and Opcodes/IAND 23 | :bitwise-or Opcodes/IOR 24 | :bitwise-xor Opcodes/IXOR 25 | :shift-left Opcodes/ISHL 26 | :shift-right Opcodes/ISHR 27 | :logical-shift-right Opcodes/IUSHR}) 28 | 29 | (def comparison-insns 30 | {t/BOOLEAN {:eq [Opcodes/IF_ICMPNE], :ne [Opcodes/IF_ICMPEQ]} 31 | t/INT {:eq [Opcodes/IF_ICMPNE], :ne [Opcodes/IF_ICMPEQ] 32 | :lt [Opcodes/IF_ICMPGE], :gt [Opcodes/IF_ICMPLE] 33 | :le [Opcodes/IF_ICMPGT], :ge [Opcodes/IF_ICMPLT]} 34 | t/LONG {:eq [Opcodes/LCMP Opcodes/IFNE], :ne [Opcodes/LCMP Opcodes/IFEQ] 35 | :lt [Opcodes/LCMP Opcodes/IFGE], :gt [Opcodes/LCMP Opcodes/IFLE] 36 | :le [Opcodes/LCMP Opcodes/IFGT], :ge [Opcodes/LCMP Opcodes/IFLT]} 37 | t/FLOAT {:eq [Opcodes/FCMPL Opcodes/IFNE], :ne [Opcodes/FCMPL Opcodes/IFEQ] 38 | :lt [Opcodes/FCMPG Opcodes/IFGE], :gt [Opcodes/FCMPL Opcodes/IFLE] 39 | :le [Opcodes/FCMPG Opcodes/IFGT], :ge [Opcodes/FCMPL Opcodes/IFLT]} 40 | t/DOUBLE {:eq [Opcodes/DCMPL Opcodes/IFNE], :ne [Opcodes/DCMPL Opcodes/IFEQ] 41 | :lt [Opcodes/DCMPG Opcodes/IFGE], :gt [Opcodes/DCMPL Opcodes/IFLE] 42 | :le [Opcodes/DCMPG Opcodes/IFGT], :ge [Opcodes/DCMPL Opcodes/IFLT]}}) 43 | 44 | (def constant-comparison-insns 45 | {:eq-null Opcodes/IFNONNULL :ne-null Opcodes/IFNULL 46 | :eq-0 Opcodes/IFNE :ne-0 Opcodes/IFEQ 47 | :lt-0 Opcodes/IFGE :gt-0 Opcodes/IFLE 48 | :le-0 Opcodes/IFGT :ge-0 Opcodes/IFLT}) 49 | 50 | (def widening-insns 51 | {t/INT {t/LONG Opcodes/I2L 52 | t/FLOAT Opcodes/I2F 53 | t/DOUBLE Opcodes/I2D} 54 | t/LONG {t/FLOAT Opcodes/L2F 55 | t/DOUBLE Opcodes/L2D} 56 | t/FLOAT {t/DOUBLE Opcodes/F2D}}) 57 | 58 | (def narrowing-insns 59 | {t/INT {t/BYTE Opcodes/I2B 60 | t/CHAR Opcodes/I2C 61 | t/SHORT Opcodes/I2S} 62 | t/LONG {t/INT Opcodes/L2I} 63 | t/FLOAT {t/INT Opcodes/F2I 64 | t/LONG Opcodes/F2L} 65 | t/DOUBLE {t/INT Opcodes/D2I 66 | t/LONG Opcodes/D2L 67 | t/FLOAT Opcodes/D2F}}) 68 | -------------------------------------------------------------------------------- /src/jise/core.clj: -------------------------------------------------------------------------------- 1 | (ns jise.core 2 | (:refer-clojure :exclude [class]) 3 | (:require [clojure.string :as str] 4 | [jise.emit :as emit] 5 | [jise.parse :as parse] 6 | [jise.type :as type]) 7 | (:import [clojure.lang Compiler Compiler$LocalBinding DynamicClassLoader])) 8 | 9 | (defn- qualify-cname [cname] 10 | (let [cname' (name cname)] 11 | (-> (cond->> cname' 12 | (neg? (.indexOf cname' ".")) 13 | (str (ns-name *ns*) \.)) 14 | (.replace \- \_) 15 | symbol 16 | (with-meta (meta cname))))) 17 | 18 | (defn- compile-to-bytecode [source form-meta enclosing-env qname body] 19 | (->> (with-meta `(defclass ~qname ~@body) form-meta) 20 | (parse/parse-class enclosing-env) 21 | (#(cond-> % source (assoc :source source))) 22 | emit/emit-class)) 23 | 24 | (defn- compile-class [form-meta enclosing-env cname body] 25 | (let [qname (with-meta (qualify-cname cname) (meta cname)) 26 | qname' (str qname) 27 | bytecode (compile-to-bytecode *source-path* form-meta enclosing-env qname body)] 28 | (when *compile-files* 29 | (Compiler/writeClassFile (str/replace qname' \. \/) bytecode)) 30 | (.defineClass ^DynamicClassLoader @Compiler/LOADER qname' bytecode nil) 31 | qname)) 32 | 33 | (defn- enclosing-env [&env] 34 | (reduce-kv (fn [m sym ^Compiler$LocalBinding lb] 35 | (assoc m (name sym) 36 | {:type (if (.hasJavaClass lb) 37 | (type/tag->type {} (.getJavaClass lb)) 38 | type/OBJECT) 39 | :foreign? true 40 | :used? (atom false)})) 41 | {} 42 | &env)) 43 | 44 | (defmacro defclass [cname & body] 45 | (let [qname (compile-class (meta &form) {} cname body)] 46 | `(do (import '~qname) 47 | ~qname))) 48 | 49 | (defmacro class [maybe-name & body] 50 | (let [cname (if (symbol? maybe-name) 51 | maybe-name 52 | (gensym 'C)) 53 | enclosing-env (enclosing-env &env) 54 | body (if (symbol? maybe-name) body (cons maybe-name body)) 55 | qname (compile-class (meta &form) enclosing-env cname body) 56 | obj (gensym 'obj)] 57 | `(let [~obj (new ~qname)] 58 | ~@(for [[name {:keys [used?]}] enclosing-env 59 | :when @used? 60 | :let [sym (symbol name)]] 61 | `(set! (. ~obj ~sym) ~sym)) 62 | ~obj))) 63 | 64 | (comment 65 | 66 | (require '[clojure.java.io :as io]) 67 | (import 'java.io.DataOutputStream) 68 | 69 | (defn gen [[_ cname & body :as class] filename] 70 | (let [qname (with-meta (qualify-cname cname) (meta cname)) 71 | qname' (str qname) 72 | bytecode (compile-to-bytecode nil (meta class) {} qname body)] 73 | (with-open [out (DataOutputStream. (io/output-stream filename))] 74 | (.write out bytecode) 75 | (.flush out)))) 76 | 77 | ) 78 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # JiSE: Java in S-Expression 2 | [![Clojars Project](https://img.shields.io/clojars/v/jise.svg)](https://clojars.org/jise) 3 | [![CircleCI](https://circleci.com/gh/athos/JiSE.svg?style=shield)](https://circleci.com/gh/athos/JiSE) 4 | 5 | JiSE is a Clojure DSL library that compiles a Java-like language into JVM bytecode at macroexpansion time. 6 | 7 | ## Features 8 | 9 | Using JiSE, you can: 10 | 11 | - Write imperative code that is compiled to JVM bytecode as efficient as written in Java 12 | - You can use assignment, (nested) loops, (labeled) break/continue, etc. 13 | - Define your own Java class in a cleaner way than using `gen-class` or `proxy` 14 | - Combine JiSE code with Clojure in a function- or expression-level of granularity 15 | - Find more errors at compile time due to its static typing 16 | - Extend JiSE syntax with Clojure's ordinary macros 17 | - Existing Clojure macros can also be used seamlessly from JiSE, such as `->`, `..` and `with-open` 18 | 19 | ## Installation 20 | 21 | Add the following to your project `:dependencies`: 22 | 23 | [![Clojars Project](https://clojars.org/jise/latest-version.svg)](https://clojars.org/jise) 24 | 25 | If you would rather use an unstable version of the library via [Clojure CLI tool](https://clojure.org/guides/deps_and_cli), add the following to your `deps.edn` instead: 26 | 27 | ```clj 28 | {... 29 | :deps {... 30 | athos/jise {:git/url "https://github.com/athos/JiSE.git" 31 | :sha ""} 32 | ...} 33 | ...} 34 | ``` 35 | 36 | ## Usage 37 | 38 | ```clojure 39 | (require '[jise.core :refer [defclass]]) 40 | 41 | 42 | ^:public 43 | (defclass Counter 44 | ^:private 45 | (def ^int c) 46 | ^:public 47 | (defm Counter [^int c] 48 | (set! (.-c this) c)) 49 | ^:public ^int 50 | (defm inc [] 51 | (inc! (.-c this)))) 52 | 53 | ;; You can use the defined class (`Counter`) as an ordinary Java class 54 | (def c (Counter. 10)) 55 | (.inc c) ;=> 11 56 | (.inc c) ;=> 12 57 | (.inc c) ;=> 13 58 | 59 | ;; Also, you can even write quite imperative code easily as follows: 60 | 61 | ^:public 62 | (defclass Qsort 63 | ^:public ^:static 64 | (defm qsort [^{:tag [int]} xs] 65 | (qsort xs 0 (- (alength xs) 1))) 66 | 67 | ^:private ^:static 68 | (defm qsort [^{:tag [int]} xs ^int left ^int right] 69 | (when (< left right) 70 | (let [p (aget xs (/ (+ left right) 2)) 71 | l left 72 | r right] 73 | (while (<= l r) 74 | (while (< (aget xs l) p) (inc! l)) 75 | (while (> (aget xs r) p) (dec! r)) 76 | (when (<= l r) 77 | (let [tmp (aget xs l)] 78 | (aset xs l (aget xs r)) 79 | (aset xs r tmp) 80 | (inc! l) 81 | (dec! r)))) 82 | (qsort xs left r) 83 | (qsort xs l right))))) 84 | 85 | (def arr (int-array [3 1 4 1 5 9 2])) 86 | (Qsort/qsort arr) 87 | (seq arr) 88 | ;=> (1 1 2 3 4 5 9) 89 | ``` 90 | 91 | For a more practical example, see also [AOBench code](examples/example/aobench.clj) written in JiSE. 92 | 93 | ## Supported Java features 94 | - [x] class definition 95 | - [x] inheritance & interface implementation 96 | - [x] constructor definition 97 | - [x] field & method definition 98 | - [x] non-static fields & methods 99 | - [x] static fields & static methods 100 | - [x] method overloading 101 | - [x] variable arity methods 102 | - [x] various modifiers 103 | - [x] access control (`public` / `protected` / `private`) 104 | - [x] `abstract` 105 | - [x] `final` 106 | - [x] `transient` 107 | - [x] `volatile` 108 | - [x] `synchronized` 109 | - [x] initializer & static initializer 110 | - [x] primitive arithmetics 111 | - [x] logical expressions 112 | - [x] assignments 113 | - [x] increments & decrements 114 | - [x] conditionals (`if` / `switch`) 115 | - [x] loops (`while` / `for` / enhanced `for` / `break` / `continue`) 116 | - [x] `return` 117 | - [x] arrays (including multi-dimensional arrays) 118 | - [x] casting 119 | - [x] string concatenation 120 | - [x] auto-boxing & auto-unboxing 121 | - [x] constructor invocation (including explicit `this()` / `super()` invocation) 122 | - [x] field access 123 | - [x] method invocation (including variable arity method invocation) 124 | - [x] exception handling (`try` / `catch` / `finally` / `throw`) 125 | 126 | ## Not supported Java features 127 | 128 | - [ ] interface definition 129 | - [ ] enum definition 130 | - [ ] nested class definition 131 | - [ ] member classes 132 | - [ ] local classes 133 | - [ ] anonymous classes 134 | - [ ] `synchronized` blocks 135 | - [ ] annotations 136 | - [ ] generics 137 | - [ ] lambda expressions 138 | - [ ] method references 139 | 140 | ## License 141 | 142 | Copyright © 2019 Shogo Ohta 143 | 144 | This program and the accompanying materials are made available under the 145 | terms of the Eclipse Public License 2.0 which is available at 146 | http://www.eclipse.org/legal/epl-2.0. 147 | 148 | This Source Code may also be made available under the following Secondary 149 | Licenses when the conditions for such availability set forth in the Eclipse 150 | Public License, v. 2.0 are satisfied: GNU General Public License as published by 151 | the Free Software Foundation, either version 2 of the License, or (at your 152 | option) any later version, with the GNU Classpath Exception which is available 153 | at https://www.gnu.org/software/classpath/license.html. 154 | -------------------------------------------------------------------------------- /src/jise/simplify.clj: -------------------------------------------------------------------------------- 1 | (ns jise.simplify 2 | (:require [jise.macroexpand :as mex] 3 | [jise.misc :as misc] 4 | [jise.type :as t])) 5 | 6 | (declare simplify) 7 | 8 | (defmulti simplify* (fn [cenv expr] (misc/fixup-ns (first expr)))) 9 | (defmethod simplify* :default [cenv expr] 10 | (let [expanded (mex/macroexpand cenv expr)] 11 | (when-not (identical? expanded expr) 12 | (simplify cenv expanded)))) 13 | 14 | (defn simplify [cenv expr] 15 | (cond (or (boolean? expr) (char? expr) (string? expr)) expr 16 | (int? expr) (int expr) 17 | (float? expr) (double expr) 18 | (seq? expr) (try (simplify* cenv expr) (catch Exception _)) 19 | (symbol? expr) (let [ns (namespace expr) 20 | class (if ns 21 | (t/tag->type cenv (symbol ns) :throws-on-failure? false) 22 | (when (not (contains? (:lenv cenv) expr)) 23 | (:class-type cenv))) 24 | caller (:class-type cenv)] 25 | (when-let [field (and class (t/find-field cenv caller class (name expr)))] 26 | (let [{:keys [access value]} field] 27 | (when (and (:final access) value 28 | (or (not (:static? cenv)) (:static access))) 29 | value)))) 30 | :else nil)) 31 | 32 | (defn- simplify-exprs [cenv exprs] 33 | (let [exprs' (map (partial simplify cenv) exprs)] 34 | (when-not (some nil? exprs') 35 | exprs'))) 36 | 37 | (defn- simplify-arithmetic [cenv [_ & args] op] 38 | (if-some [args' (simplify-exprs cenv args)] 39 | (let [res (apply op args')] 40 | (if (boolean? res) 41 | res 42 | (cond (some double? args') (double res) 43 | (some float? args') (float res) 44 | (some #(instance? Long %) args') (long res) 45 | :else (int res)))))) 46 | 47 | (defmethod simplify* '+ [cenv expr] 48 | (simplify-arithmetic cenv expr +)) 49 | 50 | (defmethod simplify* '- [cenv expr] 51 | (simplify-arithmetic cenv expr -)) 52 | 53 | (defmethod simplify* '* [cenv expr] 54 | (simplify-arithmetic cenv expr *)) 55 | 56 | (defmethod simplify* '/ [cenv expr] 57 | (let [div (fn [x y] 58 | (if (or (float? x) (float? y)) 59 | (/ x y) 60 | (quot x y))) 61 | div* (fn [& args] (reduce div args))] 62 | (simplify-arithmetic cenv expr div*))) 63 | 64 | (defmethod simplify* '% [cenv expr] 65 | (simplify-arithmetic cenv expr rem)) 66 | 67 | (defmethod simplify* '& [cenv expr] 68 | (simplify-arithmetic cenv expr bit-and)) 69 | 70 | (defmethod simplify* '| [cenv expr] 71 | (simplify-arithmetic cenv expr bit-or)) 72 | 73 | (defmethod simplify* 'xor [cenv expr] 74 | (simplify-arithmetic cenv expr bit-xor)) 75 | 76 | (defmethod simplify* '! [cenv expr] 77 | (simplify-arithmetic cenv expr bit-not)) 78 | 79 | (defmethod simplify* '== [cenv expr] 80 | (let [eql (fn [x y] 81 | (if (and (or (int? x) (float? x)) 82 | (or (int? y) (float? y))) 83 | (== x y) 84 | (= x y))) 85 | eql* (fn [& args] (reduce (fn [acc [x y]] (and acc (eql x y))) args))] 86 | (simplify-arithmetic cenv expr eql*))) 87 | 88 | (defmethod simplify* '< [cenv expr] 89 | (simplify-arithmetic cenv expr <)) 90 | 91 | (defmethod simplify* '> [cenv expr] 92 | (simplify-arithmetic cenv expr >)) 93 | 94 | (defmethod simplify* '<= [cenv expr] 95 | (simplify-arithmetic cenv expr <=)) 96 | 97 | (defmethod simplify* '>= [cenv expr] 98 | (simplify-arithmetic cenv expr >=)) 99 | 100 | (defn- simplify-shift [cenv [_ expr1 expr2] op] 101 | (when-some [[expr1' expr2'] (simplify-exprs cenv [expr1 expr2])] 102 | (cond-> (op expr1' expr2) 103 | (instance? Integer expr1') 104 | int))) 105 | 106 | (defmethod simplify* '<< [cenv expr] 107 | (simplify-shift cenv expr bit-shift-left)) 108 | 109 | (defmethod simplify* '>> [cenv expr] 110 | (simplify-shift cenv expr bit-shift-right)) 111 | 112 | (defmethod simplify* '>>> [cenv expr] 113 | (simplify-shift cenv expr unsigned-bit-shift-right)) 114 | 115 | (defn- simplify-cast [cenv [_ expr] op] 116 | (when-let [expr' (simplify cenv expr)] 117 | (op expr'))) 118 | 119 | (defmethod simplify* 'byte [cenv expr] 120 | (simplify-cast cenv expr byte)) 121 | 122 | (defmethod simplify* 'short [cenv expr] 123 | (simplify-cast cenv expr short)) 124 | 125 | (defmethod simplify* 'int [cenv expr] 126 | (simplify-cast cenv expr int)) 127 | 128 | (defmethod simplify* 'long [cenv expr] 129 | (simplify-cast cenv expr long)) 130 | 131 | (defmethod simplify* 'do [cenv [_ & exprs]] 132 | (when (= (count exprs) 1) 133 | (simplify cenv (first exprs)))) 134 | 135 | (defmethod simplify* 'if [cenv [_ test then else]] 136 | (when-some [test' (simplify cenv test)] 137 | (if test' 138 | (simplify cenv then) 139 | (simplify cenv else)))) 140 | 141 | (defmethod simplify* 'and [cenv [_ & args]] 142 | (when-some [args' (simplify-exprs cenv args)] 143 | (reduce #(and %1 %2) args'))) 144 | 145 | (defmethod simplify* 'or [cenv [_ & args]] 146 | (when-some [args' (simplify-exprs cenv args)] 147 | (reduce #(or %1 %2) args'))) 148 | 149 | (defmethod simplify* 'not [cenv [_ expr]] 150 | (when-some [expr' (simplify cenv expr)] 151 | (not expr'))) 152 | 153 | (defmethod simplify* 'str [cenv [_ & args]] 154 | (when-some [args' (simplify-exprs cenv args)] 155 | (apply str args'))) 156 | -------------------------------------------------------------------------------- /src/jise/error.clj: -------------------------------------------------------------------------------- 1 | (ns jise.error 2 | (:require [clojure.string :as str] 3 | [jise.type :as t])) 4 | 5 | (def ^:dynamic *line* nil) 6 | (def ^:dynamic *column* nil) 7 | 8 | (defmacro with-line&column-of [x & body] 9 | `(let [{line# :line column# :column} (meta ~x)] 10 | (if (and line# column#) 11 | (binding [*line* line# *column* column#] 12 | ~@body) 13 | (do ~@body)))) 14 | 15 | (defn stringify-type [t] 16 | (if (nil? t) 17 | "" 18 | (-> (t/type->tag t) str (str/replace #"^java\.lang\.([^.]+)$" "$1")))) 19 | 20 | (defmacro error [msg & [data]] 21 | `(let [msg# (str "Error: " ~msg " (" *file* \: *line* \: *column* ")") 22 | data# (merge {:line *line* :column *column*} ~data)] 23 | (throw (ex-info msg# data#)))) 24 | 25 | (defmacro error-on-reserved-word [keyword] 26 | `(error ~(str keyword " is a reserved word, but cannot be used now"))) 27 | 28 | (defmacro error-on-illegal-access-to-non-static [name] 29 | `(error (str "non-static variable " ~name " cannot be referenced from a static context"))) 30 | 31 | (defn error-message-on-incompatible-types [expected actual] 32 | (format "incompatible types: %s cannot be converted to %s" 33 | (stringify-type actual) 34 | (stringify-type expected))) 35 | 36 | (defmacro error-on-incompatible-types [expected actual] 37 | `(error (error-message-on-incompatible-types ~expected ~actual))) 38 | 39 | (defmacro error-on-bad-operand-type [op-name t] 40 | `(error (format "bad operand type %s for unary operator '%s'" 41 | (stringify-type ~t) ~op-name))) 42 | 43 | (defmacro error-on-bad-operand-types [op-name t1 t2] 44 | `(error (str "bad operand types for binary operator '" ~op-name "'\n" 45 | " first type: " (stringify-type ~t1) "\n" 46 | " second type: " (stringify-type ~t2)))) 47 | 48 | (defn error-on-missing-arguments [op-name num varargs?] 49 | (error (str (when varargs? 50 | "at least ") 51 | num (if (= num 1) " argument " " arguments ") 52 | "required for operator '" op-name "'"))) 53 | 54 | (defn handle-ctor-error [class arg-types e] 55 | (if-let [cause (:cause (ex-data e))] 56 | (let [class-name (stringify-type class)] 57 | (-> (case cause 58 | :no-such-target 59 | (format "cannot find symbol: method %s(%s)" class-name 60 | (str/join "," (map stringify-type arg-types))) 61 | :args-length-mismatch 62 | (str "constructor " class-name " in class " class-name 63 | " cannot be applied to given types") 64 | :arg-type-mismatch 65 | (format "no suitable constructor found for %s(%s)" 66 | class-name (str/join "," (map stringify-type arg-types))) 67 | (ex-message e)) 68 | (error (dissoc (ex-data e) :cause)))) 69 | (throw e))) 70 | 71 | (defn- param-types-string [param-types] 72 | (if (seq param-types) 73 | (str/join \, (map stringify-type param-types)) 74 | "no arguments")) 75 | 76 | (defn- signature-string [name param-types] 77 | (format "%s(%s)" name (param-types-string param-types))) 78 | 79 | (defn- first-mismatched-arg-type [cenv arg-types method] 80 | (try 81 | (if (:varargs (:access method)) 82 | (t/variable-arity-invocation-conversion cenv arg-types method) 83 | (t/loose-invocation-conversion cenv arg-types method)) 84 | (catch Exception e 85 | (let [{:keys [param-type arg-type]} (ex-data e)] 86 | [param-type arg-type])))) 87 | 88 | (defn handle-method-error [cenv class name arg-types e] 89 | (let [{:keys [cause] :as ed} (ex-data e) 90 | class-name (stringify-type class)] 91 | (if cause 92 | (-> (case cause 93 | :no-such-target 94 | (str "cannot find symbol\n" 95 | " symbol: method " (signature-string name arg-types) "\n" 96 | " location: class " class-name) 97 | :args-length-mismatch 98 | (let [{[m :as ms] :alternatives} ed 99 | reason "actual and formal argument lists differ in length"] 100 | (if (= (count ms) 1) 101 | (str "method " name " in class " class-name 102 | " cannot be applied to given types\n" 103 | " required: " (param-types-string (:param-types m)) "\n" 104 | " found: " (param-types-string arg-types) "\n" 105 | " reason: " reason) 106 | (str "no suitable method found for " (signature-string name arg-types) "\n" 107 | (->> (for [{:keys [access param-types]} ms] 108 | (format " method %s is not applicable\n (%s)" 109 | (cond->> (signature-string name param-types) 110 | (:static access) (str class-name \.)) 111 | reason)) 112 | (str/join \newline))))) 113 | :arg-type-mismatch 114 | (let [{[m :as ms] :alternatives} ed] 115 | (if (= (count ms) 1) 116 | (let [[pt at] (first-mismatched-arg-type cenv arg-types m)] 117 | (error-message-on-incompatible-types pt at)) 118 | (str "no suitable method found for " 119 | (signature-string name arg-types) "\n" 120 | (->> (for [{:keys [access param-types] :as m} ms 121 | :let [[pt at] (first-mismatched-arg-type cenv arg-types m)]] 122 | (format " method %s is not applicable\n (argument mismatch; %s)" 123 | (cond->> (signature-string name param-types) 124 | (:static access) (str class-name \.)) 125 | (error-message-on-incompatible-types pt at))) 126 | (str/join \newline))))) 127 | :ambiguous-invocation 128 | (let [[m1 m2] (:alternatives ed)] 129 | (str "reference to " name " is ambiguous\n" 130 | " both method " (signature-string name (:param-types m1)) 131 | " in " (stringify-type (:class m1)) 132 | " and method " (signature-string name (:param-types m2)) 133 | " in " (stringify-type (:class m2)) 134 | " match")) 135 | (ex-message e)) 136 | (error (dissoc ed :cause))) 137 | (throw e)))) 138 | -------------------------------------------------------------------------------- /src/jise/utils.clj: -------------------------------------------------------------------------------- 1 | (ns jise.utils 2 | (:refer-clojure :exclude [defn fn deftype]) 3 | (:require [clojure.core :as c] 4 | [jise.core :as jise]) 5 | (:import [clojure.lang Compiler$LocalBinding])) 6 | 7 | (defn- primitive-type [t] 8 | (case t 9 | (float double) 'double 10 | (byte short int long) 'long 11 | 'Object)) 12 | 13 | (defn- fixup-type-hint [allow-primitive? arg] 14 | (let [{:keys [tag] :or {tag 'Object}} (meta arg) 15 | tag' (or (when allow-primitive? 16 | (primitive-type tag)) 17 | 'Object)] 18 | (cond-> arg 19 | (not= tag tag') 20 | (vary-meta assoc :tag tag')))) 21 | 22 | (defn- fixup-type-hints [args & {:keys [allow-primitive?] :or {allow-primitive? true}}] 23 | (mapv (partial fixup-type-hint (and allow-primitive? (< (count args) 5))) args)) 24 | 25 | (defmacro ^:private def-type->primitive-interface [] 26 | `(def ~'type->primitive-interface 27 | ~(letfn [(rec [n] 28 | (if (= n 0) 29 | [[]] 30 | (let [xs (rec (dec n))] 31 | (for [x xs 32 | c '[L D O]] 33 | (conj x c)))))] 34 | (->> (for [cs (mapcat rec (range 1 6)) 35 | :when (not (every? '#{O} cs))] 36 | [`'~cs (symbol (apply str 'clojure.lang.IFn$ cs))]) 37 | (into {}))))) 38 | 39 | (def-type->primitive-interface) 40 | 41 | (defn- type-char [t] 42 | (case t 43 | long 'L 44 | double 'D 45 | 'O)) 46 | 47 | (defn- primitive-interface [args return-type] 48 | (let [hints (mapv (c/fn [arg] 49 | (-> (:tag (meta arg)) 50 | #{'long 'double} 51 | type-char)) 52 | args)] 53 | (type->primitive-interface (conj hints (type-char return-type))))) 54 | 55 | (defn- emit-fn-body [args args' body] 56 | (if-let [diffs (->> (map vector args args') 57 | (remove (c/fn [[s s']] (identical? s s'))) 58 | seq)] 59 | `((let ~(into [] (mapcat (c/fn [[s s']] [s (with-meta s' nil)])) diffs) 60 | ~@body)) 61 | body)) 62 | 63 | (defn- emit-fn-methods [[params & body]] 64 | (let [params' (fixup-type-hints params) 65 | return-type (primitive-type (:tag (meta params)))] 66 | (if-let [prim (primitive-interface params' return-type)] 67 | (let [params'' (fixup-type-hints params :allow-primitive? false)] 68 | [(with-meta 69 | `(jise/defm ~'invokePrim ~(vec params') 70 | ~@(emit-fn-body params params' body)) 71 | {:public true :tag return-type}) 72 | `^:public ^Object 73 | (jise/defm ~'invoke ~(vec params'') 74 | (.invokePrim (jise/cast ~prim jise/this) ~@params'))]) 75 | [`^:public ^Object 76 | (jise/defm ~'invoke ~(vec params') 77 | ~@(emit-fn-body params params' body))]))) 78 | 79 | (defn- emit-fn-class [fname sigs] 80 | (let [fname' (or fname (gensym 'f)) 81 | {:keys [prims]} 82 | (reduce (c/fn [m [params]] 83 | (let [arity (count params) 84 | params' (fixup-type-hints params) 85 | return-type (primitive-type (:tag (meta params)))] 86 | (when ((:arities m) arity) 87 | (throw (ex-info "Can't have 2 overloads with same arity" {}))) 88 | (as-> (update m :arities conj arity) m 89 | (if-let [prim (primitive-interface params' return-type)] 90 | (update m :prims conj prim) 91 | m)))) 92 | {:prims [] :arities #{}} 93 | sigs)] 94 | (cond-> `^:public 95 | (jise/class ~fname' [clojure.lang.AFunction clojure.lang.IFn ~@prims] 96 | ~@(mapcat emit-fn-methods sigs)) 97 | fname 98 | (vary-meta assoc ::jise/this-name fname)))) 99 | 100 | (defmacro fn [& sigs] 101 | (let [[fname sigs] (if (symbol? (first sigs)) 102 | [(first sigs) (next sigs)] 103 | [nil sigs]) 104 | sigs (if (vector? (first sigs)) 105 | (list sigs) 106 | sigs)] 107 | (emit-fn-class fname sigs))) 108 | 109 | (defmacro defn [name & fdecl] 110 | (let [[fdecl m] (if (string? (first fdecl)) 111 | [(next fdecl) {:doc (first fdecl)}] 112 | [fdecl {}]) 113 | [fdecl m] (if (map? fdecl) 114 | [(next fdecl) (merge m (first fdecl))] 115 | [fdecl m]) 116 | fdecl (if (vector? (first fdecl)) 117 | (list fdecl) 118 | fdecl) 119 | fdecl' (for [[params & body] fdecl 120 | :let [params' (fixup-type-hints params) 121 | meta (meta params)]] 122 | `(~(with-meta (vec params') 123 | (cond-> meta (:tag meta) (update :tag primitive-type))) 124 | ~@body)) 125 | m (cond->> (merge {:arglists `'~(#'c/sigs fdecl')} m) 126 | (meta name) 127 | (merge (meta name))) 128 | name-with-meta (with-meta name m)] 129 | `(do 130 | ;; the following `declare` is necessary to allow self reference within fn definition 131 | (declare ~name-with-meta) 132 | (def ~name-with-meta 133 | (fn ~name ~@fdecl))))) 134 | 135 | (defmacro do [& body] 136 | `((fn [] ~@body))) 137 | 138 | (defn- parse-opts+specs [opts+specs] 139 | (loop [opts+specs opts+specs 140 | interfaces [] 141 | methods []] 142 | (if (empty? opts+specs) 143 | [interfaces methods] 144 | (let [[x & more] opts+specs] 145 | (if (symbol? x) 146 | (recur more (conj interfaces x) methods) 147 | (recur more interfaces (conj methods x))))))) 148 | 149 | (defn- visibility-of [x] 150 | (let [m (meta x)] 151 | (cond (:public m) :public 152 | (:private m) :private 153 | :else :public))) 154 | 155 | (defmacro deftype [name fields & opts+specs] 156 | (let [[interfaces methods] (parse-opts+specs opts+specs) 157 | interfaces' (into ['clojure.lang.IType] 158 | (map (c/fn [name] 159 | (let [v (resolve name)] 160 | (if-let [^Class c (or (and (var? v) (:on-interface @v)) 161 | (and (class? v) v))] 162 | (symbol (.getName c)) 163 | name)))) 164 | interfaces) 165 | ctor (with-meta 166 | `(jise/defm ~(with-meta name nil) ~fields 167 | ~@(for [field fields 168 | :let [field' (with-meta field nil)]] 169 | `(jise/set! (jise/. jise/this ~field') ~field'))) 170 | {:public true}) 171 | fields' (for [field fields 172 | :let [visibility (visibility-of field)]] 173 | `(jise/def ~(with-meta field 174 | (merge {visibility true} 175 | (dissoc (meta field) :public :private))))) 176 | methods' (for [[mname args & body :as method] methods 177 | :let [visibility (visibility-of method)]] 178 | (with-meta 179 | `(jise/defm ~mname ~(vec (rest args)) ~@body) 180 | (merge {visibility true ::jise/this-name (first args)} 181 | (dissoc (meta method) :public :private))))] 182 | `(do 183 | ^:public 184 | (jise/defclass ~name ~interfaces' ~@fields' ~ctor ~@methods') 185 | (defn ~(symbol (str "->" name)) 186 | ~(str "Positional factory function for class " name) 187 | ~(vec fields) 188 | (new ~name ~@(map #(with-meta % nil) fields)))))) 189 | -------------------------------------------------------------------------------- /examples/example/aobench.clj: -------------------------------------------------------------------------------- 1 | (ns example.aobench 2 | (:gen-class) 3 | (:require [jise.core :refer [defclass]]) 4 | (:import [java.io FileOutputStream] 5 | [java.util Random])) 6 | 7 | ^:public 8 | (defclass Vec 9 | ^:public ^double (def x) 10 | ^:public ^double (def y) 11 | ^:public ^double (def z) 12 | 13 | ^:public 14 | (defm Vec [] 15 | (this 0.0 0.0 0.0)) 16 | 17 | ^:public 18 | (defm Vec [^double x ^double y ^double z] 19 | (set! (.-x this) x) 20 | (set! (.-y this) y) 21 | (set! (.-z this) z)) 22 | 23 | ^:public ^double 24 | (defm dot [^Vec v] 25 | (+ (* x (.-x v)) (* y (.-y v)) (* z (.-z v)))) 26 | 27 | ^:public ^:static ^Vec 28 | (defm cross [^Vec v0 ^Vec v1] 29 | (Vec. (- (* (.-y v0) (.-z v1)) (* (.-z v0) (.-y v1))) 30 | (- (* (.-z v0) (.-x v1)) (* (.-x v0) (.-z v1))) 31 | (- (* (.-x v0) (.-y v1)) (* (.-y v0) (.-x v1))))) 32 | 33 | ^:public ^Vec 34 | (defm normalize! [] 35 | (let [len (Math/sqrt (.dot this this))] 36 | (when (> len 1.0e-17) 37 | (set! (.-x this) (/ (.-x this) len)) 38 | (set! (.-y this) (/ (.-y this) len)) 39 | (set! (.-z this) (/ (.-z this) len)))) 40 | this) 41 | 42 | ^:public ^Vec 43 | (defm copy [] 44 | (Vec. x y z))) 45 | 46 | ^:public 47 | (defclass Isect 48 | ^:public ^double (def t) 49 | ^:public ^Vec (def p) 50 | ^:public ^Vec (def n) 51 | ^:public ^boolean (def hit?) 52 | 53 | ^:public 54 | (defm Isect [^double t] 55 | (set! (.-t this) t) 56 | (set! p (Vec.)) 57 | (set! n (Vec.)) 58 | (set! hit? false))) 59 | 60 | ^:public 61 | (defclass Sphere 62 | ^:public ^:final 63 | (def ^Vec center) 64 | ^:public ^:final 65 | (def ^double radius) 66 | 67 | ^:public 68 | (defm Sphere [^Vec center ^double radius] 69 | (set! (.-center this) center) 70 | (set! (.-radius this) radius))) 71 | 72 | ^:public 73 | (defclass Plane 74 | ^:public ^:final 75 | (def ^Vec p) 76 | ^:public ^:final 77 | (def ^Vec n) 78 | 79 | ^:public 80 | (defm Plane [^Vec p ^Vec n] 81 | (set! (.-p this) p) 82 | (set! (.-n this) n))) 83 | 84 | ^:public 85 | (defclass Ray 86 | ^:public ^:final 87 | (def ^Vec org) 88 | ^:public ^:final 89 | (def ^Vec dir) 90 | 91 | ^:public 92 | (defm Ray [^Vec org ^Vec dir] 93 | (set! (.-org this) org) 94 | (set! (.-dir this) dir))) 95 | 96 | ^:public 97 | (defclass AOBench 98 | ^:static ^:private ^:final ^int (def NAO_SAMPLES 8) 99 | 100 | ^:private ^int (def width) 101 | ^:private ^int (def height) 102 | ^:private ^int (def nsubsamples) 103 | 104 | ^:private ^bytes (def image) 105 | 106 | ^:private ^{:tag [Sphere]} (def spheres) 107 | ^:private ^Plane (def plane) 108 | 109 | ^:private ^Random (def random (Random. (long 0))) 110 | 111 | ^:public 112 | (defm AOBench [^int width ^int height ^int nsubsamples] 113 | (set! (.-width this) width) 114 | (set! (.-height this) height) 115 | (set! (.-nsubsamples this) nsubsamples) 116 | (set! image (new [byte] (* width height 3)))) 117 | 118 | ^:public ^AOBench 119 | (defm spheres [& ^Sphere... spheres] 120 | (set! (.-spheres this) spheres) 121 | this) 122 | 123 | ^:public ^AOBench 124 | (defm plane [^Plane plane] 125 | (set! (.-plane this) plane) 126 | this) 127 | 128 | ^:private 129 | (defm ray-sphere-intersect [^Isect isect ^Ray ray ^Sphere sphere] 130 | (let [rs (Vec. (- (.. ray -org -x) (.. sphere -center -x)) 131 | (- (.. ray -org -y) (.. sphere -center -y)) 132 | (- (.. ray -org -z) (.. sphere -center -z))) 133 | B (.dot rs (.-dir ray)) 134 | C (- (.dot rs rs) (* (.-radius sphere) (.-radius sphere))) 135 | D (- (* B B) C)] 136 | (when (> D 0) 137 | (let [t (- (- B) (Math/sqrt D))] 138 | (when (and (> t 0) (< t (.-t isect))) 139 | (set! (.-t isect) t) 140 | (set! (.-hit? isect) true) 141 | (set! (.. isect -p -x) (+ (.. ray -org -x) (* (.. ray -dir -x) t))) 142 | (set! (.. isect -p -y) (+ (.. ray -org -y) (* (.. ray -dir -y) t))) 143 | (set! (.. isect -p -z) (+ (.. ray -org -z) (* (.. ray -dir -z) t))) 144 | (set! (.. isect -n -x) (- (.. isect -p -x) (.. sphere -center -x))) 145 | (set! (.. isect -n -y) (- (.. isect -p -y) (.. sphere -center -y))) 146 | (set! (.. isect -n -z) (- (.. isect -p -z) (.. sphere -center -z))) 147 | (.normalize! (.-n isect))))))) 148 | 149 | ^:private 150 | (defm ray-plane-intersect [^Isect isect ^Ray ray ^Plane plane] 151 | (let [d (- (.dot (.-p plane) (.-n plane))) 152 | v (.dot (.-dir ray) (.-n plane))] 153 | (when (< (Math/abs v) 1.0e-17) (return)) 154 | (let [t (/ (- (+ (.dot (.-org ray) (.-n plane)) d)) v)] 155 | (when (and (> t 0) (< t (.-t isect))) 156 | (set! (.-t isect) t) 157 | (set! (.-hit? isect) true) 158 | (set! (.. isect -p -x) (+ (.. ray -org -x) (* (.. ray -dir -x) t))) 159 | (set! (.. isect -p -y) (+ (.. ray -org -y) (* (.. ray -dir -y) t))) 160 | (set! (.. isect -p -z) (+ (.. ray -org -z) (* (.. ray -dir -z) t))) 161 | (set! (.-n isect) (.copy (.-n plane))))))) 162 | 163 | ^:private ^{:tag [Vec]} 164 | (defm ortho-basis [^Vec n] 165 | (let [v1 (cond (< -0.6 (.-x n) 0.6) (Vec. 1.0 0.0 0.0) 166 | (< -0.6 (.-y n) 0.6) (Vec. 0.0 1.0 0.0) 167 | (< -0.6 (.-z n) 0.6) (Vec. 0.0 0.0 1.0) 168 | true (Vec. 1.0 0.0 0.0)) 169 | v0 (.normalize! (Vec/cross v1 n))] 170 | (new [Vec] [v0 (.normalize! (Vec/cross n v0)) (.copy n)]))) 171 | 172 | ^:private ^Vec 173 | (defm ambient-occlusion [^Isect isect] 174 | (let [ntheta NAO_SAMPLES 175 | nphi NAO_SAMPLES 176 | eps 0.0001 177 | p (Vec. (+ (.. isect -p -x) (* eps (.. isect -n -x))) 178 | (+ (.. isect -p -y) (* eps (.. isect -n -y))) 179 | (+ (.. isect -p -z) (* eps (.. isect -n -z)))) 180 | basis (ortho-basis (.-n isect)) 181 | occlusion 0.0] 182 | (for [j 0, (< j ntheta), (inc! j)] 183 | (for [i 0, (< i nphi), (inc! i)] 184 | (let [theta (Math/sqrt (.nextDouble random)) 185 | phi (* 2.0 Math/PI (.nextDouble random)) 186 | x (* (Math/cos phi) theta) 187 | y (* (Math/sin phi) theta) 188 | z (Math/sqrt (- 1.0 (* theta theta))) 189 | rx (+ (* x (.-x (basis 0))) (* y (.-x (basis 1))) (* z (.-x (basis 2)))) 190 | ry (+ (* x (.-y (basis 0))) (* y (.-y (basis 1))) (* z (.-y (basis 2)))) 191 | rz (+ (* x (.-z (basis 0))) (* y (.-z (basis 1))) (* z (.-z (basis 2)))) 192 | ray (Ray. p (Vec. rx ry rz)) 193 | occ-isect (Isect. 1.0e+17)] 194 | (ray-sphere-intersect occ-isect ray (spheres 0)) 195 | (ray-sphere-intersect occ-isect ray (spheres 1)) 196 | (ray-sphere-intersect occ-isect ray (spheres 2)) 197 | (ray-plane-intersect occ-isect ray plane) 198 | (when (.-hit? occ-isect) 199 | (inc! occlusion))))) 200 | (set! occlusion (/ (- (* ntheta nphi) occlusion) (* ntheta nphi))) 201 | (Vec. occlusion occlusion occlusion))) 202 | 203 | ^:private ^int 204 | (defm clamp [^double f] 205 | (let [^int n (* f 255.5)] 206 | (cond (< n 0) 0 207 | (> n 255) 255 208 | true n))) 209 | 210 | ^:public ^bytes 211 | (defm render [] 212 | (let [fimg (new [double] (* width height 3)) 213 | ^double nsub*nsub (* nsubsamples nsubsamples)] 214 | (for [y 0, (< y height), (inc! y)] 215 | (for [x 0, (< x width), (inc! x)] 216 | (let [offset (* 3 (+ (* y width) x))] 217 | (for [v 0, (< v nsubsamples), (inc! v)] 218 | (for [u 0, (< u nsubsamples), (inc! u)] 219 | (let [px (/ (- (+ x (/ u (double nsubsamples))) (/ width 2.0)) (/ width 2.0)) 220 | py (/ (- (- (+ y (/ v (double nsubsamples))) (/ height 2.0))) (/ height 2.0)) 221 | ray (Ray. (Vec.) (.normalize! (Vec. px py -1.0))) 222 | isect (Isect. 1.0e+17)] 223 | (ray-sphere-intersect isect ray (spheres 0)) 224 | (ray-sphere-intersect isect ray (spheres 1)) 225 | (ray-sphere-intersect isect ray (spheres 2)) 226 | (ray-plane-intersect isect ray plane) 227 | (when (.-hit? isect) 228 | (let [col (ambient-occlusion isect)] 229 | (inc! (fimg (+ offset 0)) (.-x col)) 230 | (inc! (fimg (+ offset 1)) (.-y col)) 231 | (inc! (fimg (+ offset 2)) (.-z col))))))) 232 | (set! (fimg (+ offset 0)) (/ (fimg (+ offset 0)) nsub*nsub)) 233 | (set! (fimg (+ offset 1)) (/ (fimg (+ offset 1)) nsub*nsub)) 234 | (set! (fimg (+ offset 2)) (/ (fimg (+ offset 2)) nsub*nsub)) 235 | (set! (image (+ offset 0)) (byte (clamp (fimg (+ offset 0))))) 236 | (set! (image (+ offset 1)) (byte (clamp (fimg (+ offset 1))))) 237 | (set! (image (+ offset 2)) (byte (clamp (fimg (+ offset 2))))))))) 238 | image) 239 | 240 | ^:static ^:private ^:final (def ^int WIDTH 256) 241 | ^:static ^:private ^:final (def ^int HEIGHT 256) 242 | ^:static ^:private ^:final (def ^int NSUBSAMPLES 2) 243 | 244 | ^:static ^:public 245 | (defm main [& ^String... args] 246 | (let [bench (.. (AOBench. WIDTH HEIGHT NSUBSAMPLES) 247 | (spheres (Sphere. (Vec. -2.0 0.0 -3.5) 0.5) 248 | (Sphere. (Vec. -0.5 0.0 -3.0) 0.5) 249 | (Sphere. (Vec. 1.0 0.0 -2.2) 0.5)) 250 | (plane (Plane. (Vec. 0.0 -0.5 0.0) (Vec. 0.0 1.0 0.0)))) 251 | image (.render bench)] 252 | (with-open [fos (FileOutputStream. "ao.ppm")] 253 | (.write fos (.getBytes (String/format "P6\n%d %d\n255\n" WIDTH HEIGHT))) 254 | (.write fos image)))) 255 | 256 | ) 257 | -------------------------------------------------------------------------------- /test/jise/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns jise.core-test 2 | (:require [clojure.test :refer [deftest testing is are]] 3 | [jise.core :refer [defclass]]) 4 | (:import clojure.lang.Compiler$CompilerException)) 5 | 6 | (defn- eval-expr [type expr] 7 | (eval `(do 8 | ^:public 9 | (defclass ~'C 10 | ~(with-meta 11 | `(~'defm ~'m [] ~expr) 12 | {:tag type :public true})) 13 | (.m (C.))))) 14 | 15 | (deftest literal-test 16 | (testing "valid literals" 17 | (are [expr type expected] (= expected (eval-expr 'type 'expr)) 18 | true boolean true 19 | false boolean false 20 | \a char \a 21 | 42 int 42 22 | 42.195 double 42.195 23 | "foo" String "foo" 24 | nil Object nil)) 25 | (testing "invalid literals" 26 | (are [expr] (thrown? Compiler$CompilerException (eval-expr 'Object 'expr)) 27 | :a 28 | [0] 29 | {"foo" 0} 30 | #{"bar"} 31 | #"regex"))) 32 | 33 | (deftest arithmetic-test 34 | (testing "simple arithmetics" 35 | (are [expr type expected] (= expected (eval-expr 'type 'expr)) 36 | (+ 1 2) int 3 37 | (+ 1.0 2.0) double 3.0 38 | (+ 1 2 3) int 6 39 | (+ 100) int 100 40 | (+) int 0 41 | (- 3 1) int 2 42 | (- 3.0 1.0) double 2.0 43 | (- 3 2 1) int 0 44 | (- 100) int -100 45 | (* 10 20) int 200 46 | (* 2.0 2.0) double 4.0 47 | (* 2.0) double 2.0 48 | (*) int 1 49 | (/ 9 2) int 4 50 | (/ 9.0 2.0) double 4.5 51 | (/ 2.0) double 0.5 52 | (rem 9 2) int 1 53 | (rem 9.0 2.0) double 1.0 54 | (& 5 3) int 1 55 | (& true true) boolean true 56 | (& true false) boolean false 57 | (| 5 3) int 7 58 | (| false false) boolean false 59 | (| false true) boolean true 60 | (xor 5 3) int 6 61 | (xor true true) boolean false 62 | (xor true false) boolean true 63 | (! -1) int 0 64 | (<< 5 2) int 20 65 | (>> 14 2) int 3 66 | (>> -11 2) int -3 67 | (>>> 14 2) int 3 68 | (>>> -11 2) int 0x3ffffffd)) 69 | (testing "numeric promotion" 70 | (are [expr type expected] (= expected (eval-expr 'type 'expr)) 71 | (+ 4.0 1) double 5.0 72 | (+ 2 (Long/valueOf 3)) Long 5 73 | (+ (Byte/valueOf "1") (Short/valueOf "2")) int 3 74 | (- 1 0.5) double 0.5 75 | (- \b 1) int 97 76 | (* (Short/valueOf "3") 3) int 9 77 | (* 3 (Float/valueOf "3.0")) float 9.0 78 | (/ 1.0 2) double 0.5 79 | (/ (Short/valueOf "9") 3) int 3 80 | (rem 5 (Byte/valueOf "2")) int 1 81 | (rem 9.0 2) double 1.0 82 | (& 5 (Long/valueOf "3")) long 1 83 | (& true (Boolean/valueOf false)) boolean false 84 | (| (Long/valueOf "5") 3) long 7 85 | (| (Boolean/valueOf true) false) boolean true 86 | (xor (Short/valueOf "5") (Byte/valueOf "3")) int 6 87 | (xor false (Boolean/valueOf true)) boolean true 88 | (! (Byte/valueOf "0")) int -1 89 | (<< (Long/valueOf "5") 2) long 20 90 | (>> (Long/valueOf "14") 2) long 3 91 | (>>> (Long/valueOf "-11") 2) long 0x3ffffffffffffffd)) 92 | (testing "invalid arithmetics" 93 | (are [expr] (thrown? Compiler$CompilerException (eval-expr 'Object 'expr)) 94 | (+ 1 true) 95 | (- false 2) 96 | (-) 97 | (* "foo" 3) 98 | (/ 4 true) 99 | (/) 100 | (rem 9 true) 101 | (& 5.0 3) 102 | (& 1 true) 103 | (| 5 3.0) 104 | (| 1 true) 105 | (xor 5 3.0) 106 | (xor 1 true) 107 | (! 1.0) 108 | (<< 2.0 1) 109 | (<< 2 1.0) 110 | (>> 2.0 1) 111 | (>> 2 1.0) 112 | (>>> 2.0 1) 113 | (>>> 2 1.0)))) 114 | 115 | (deftest comparison-test 116 | (testing "comparison to 0" 117 | (are [expr expected] (= expected (eval-expr 'boolean 'expr)) 118 | (== 0 0) true 119 | (== 0 1) false 120 | (== 1 0) false 121 | (!= 0 0) false 122 | (!= 0 1) true 123 | (!= 1 0) true 124 | (< 0 0) false 125 | (< 0 1) true 126 | (< 1 0) false 127 | (> 0 0) false 128 | (> 0 1) false 129 | (> 1 0) true 130 | (<= 0 0) true 131 | (<= 0 1) true 132 | (<= 1 0) false 133 | (>= 0 0) true 134 | (>= 0 1) false 135 | (>= 1 0) true)) 136 | (testing "simple comparison" 137 | (are [expr expected] (= expected (eval-expr 'boolean 'expr)) 138 | (== true true) true 139 | (== true false) false 140 | (== \a \a) true 141 | (== \a \b) false 142 | (== 1.0 1.0) true 143 | (== 1.0 2.0) false 144 | (== "foo" "foo") true 145 | (== "foo" "bar") false 146 | (== "foo" nil) false 147 | (== nil nil) true 148 | (== 1 1 1) true 149 | (== 1 1 2) false 150 | (!= true true) false 151 | (!= true false) true 152 | (!= \a \a) false 153 | (!= \a \b) true 154 | (!= 1.0 1.0) false 155 | (!= 1.0 2.0) true 156 | (!= "foo" "foo") false 157 | (!= "foo" "bar") true 158 | (!= "foo" nil) true 159 | (!= nil nil) false 160 | (!= 1 1 1) false 161 | (!= 1 1 2) true 162 | (< 100 100) false 163 | (< 1.0 1.0) false 164 | (< 100 200) true 165 | (< 1.0 2.0) true 166 | (< 200 100) false 167 | (< 2.0 1.0) false 168 | (< 1 2 3) true 169 | (< 1 2 2) false 170 | (< 1 3 2) false 171 | (> 100 100) false 172 | (> 1.0 1.0) false 173 | (> 100 200) false 174 | (> 1.0 2.0) false 175 | (> 200 100) true 176 | (> 2.0 1.0) true 177 | (> 3 2 1) true 178 | (> 3 2 2) false 179 | (> 2 3 1) false 180 | (<= 100 100) true 181 | (<= 1.0 1.0) true 182 | (<= 100 200) true 183 | (<= 1.0 2.0) true 184 | (<= 200 100) false 185 | (<= 2.0 1.0) false 186 | (<= 1 2 3) true 187 | (<= 1 2 2) true 188 | (<= 1 3 2) false 189 | (>= 100 100) true 190 | (>= 100 200) false 191 | (>= 1.0 2.0) false 192 | (>= 200 100) true 193 | (>= 2.0 1.0) true 194 | (>= 3 2 1) true 195 | (>= 3 2 2) true 196 | (>= 2 3 1) false)) 197 | (testing "numeric promotion" 198 | (are [expr expected] (= expected (eval-expr 'boolean 'expr)) 199 | (== \a 97) true 200 | (== 1 1.0) true 201 | (== (Long/valueOf "1") 1) true 202 | (== \a 97 (Long/valueOf "97")) true 203 | (!= \a 97) false 204 | (!= 1 1.0) false 205 | (!= (Long/valueOf "1") 1) false 206 | (!= \a 97 (Long/valueOf "97")) false 207 | (< 97 \a) false 208 | (< \a 98) true 209 | (< 1 2.0) true 210 | (< (Long/valueOf "1") 2) true 211 | (< \a 98 (Long/valueOf "99")) true 212 | (> \a 97) false 213 | (> 98 \a) true 214 | (> 1 2.0) false 215 | (> (Long/valueOf "1") 2) false 216 | (> \a 96 (Long/valueOf "95")) true 217 | (<= 97 \a) true 218 | (<= \a 98) true 219 | (<= 1 2.0) true 220 | (<= (Long/valueOf "1") 2) true 221 | (<= \a 98 (Long/valueOf "99")) true 222 | (>= 97 \a) true 223 | (>= \a 98) false 224 | (>= 1 2.0) false 225 | (>= (Long/valueOf "1") 2) false 226 | (>= \a 96 (Long/valueOf "96")) true)) 227 | (testing "invalid comparison" 228 | (are [expr] (thrown? Compiler$CompilerException (eval-expr 'Object 'expr)) 229 | (== true 1) 230 | (== 1.0 "foo") 231 | (== \a nil) 232 | (== (Integer/valueOf 1) (Long/valueOf "1")) 233 | (== 1) 234 | (!= true 1) 235 | (!= 1.0 "foo") 236 | (!= \a nil) 237 | (!= (Integer/valueOf 1) (Long/valueOf "1")) 238 | (!= 1) 239 | (< true 1) 240 | (< 1.0 "foo") 241 | (< 1) 242 | (> true 1) 243 | (> 1.0 "foo") 244 | (> 1) 245 | (<= true 1) 246 | (<= 1.0 "foo") 247 | (<= 1) 248 | (>= true 1) 249 | (>= 1.0 "foo") 250 | (>= 1)))) 251 | 252 | (deftest logical-test 253 | (testing "simple logical" 254 | (are [expr expected] (= expected (eval-expr 'boolean 'expr)) 255 | (and) true 256 | (and true) true 257 | (and false) false 258 | (and true true) true 259 | (and true false) false 260 | (and false false) false 261 | (and true true true) true 262 | (and true false true) false 263 | (and false false false) false 264 | (and (< 1 2) (< 2 3)) true 265 | (or) false 266 | (or true) true 267 | (or false) false 268 | (or true true) true 269 | (or true false) true 270 | (or true true true) true 271 | (or true false true) true 272 | (or false false false) false 273 | (or (< 2 1) (< 2 3)) true 274 | (not true) false 275 | (not false) true 276 | (not (not (< 1 2))) true 277 | (not (and (< 1 2) (< 3 2))) true 278 | (not (and (not (< 2 1)) (not (< 2 3)))) true 279 | (not (or (< 1 2) (< 2 3))) false 280 | (not (or (not (< 1 2)) (not (< 2 3)))) true)) 281 | (testing "boxed logical" 282 | (are [expr expected] (= expected (eval-expr 'boolean 'expr)) 283 | (and true (Boolean/valueOf false)) false 284 | (and (Boolean/valueOf true) true) true 285 | (or (Boolean/valueOf false) true) true 286 | (or true (Boolean/valueOf true)) true 287 | (not (Boolean/valueOf true)) false)) 288 | (testing "invalid logical" 289 | (are [expr] (thrown? Compiler$CompilerException (eval-expr 'boolean 'expr)) 290 | (and 1 false) 291 | (and true nil) 292 | (or 1 false) 293 | (or true nil) 294 | (not 1) 295 | (not nil) 296 | (not) 297 | (not true false)))) 298 | 299 | (deftest casting-test 300 | (testing "valid casting" 301 | (are [expr type expected] (= expected (eval-expr 'type 'expr)) 302 | (byte 42) byte 42 303 | (short 42) short 42 304 | (int 42) int 42 305 | (float 42) float 42.0 306 | (double 42) double 42.0 307 | (boolean (Boolean/valueOf "true")) boolean true 308 | (char 97) char \a 309 | (int \a) int 97 310 | (long (Long/valueOf "42")) long 42 311 | (cast long 42) long 42 312 | (cast Object "foo") Object "foo" 313 | (cast Object 42) Object 42 314 | (cast String (cast Object "foo")) String "foo")) 315 | (testing "invalid casting" 316 | (are [expr] (thrown? Compiler$CompilerException (eval-expr 'Object 'expr)) 317 | (boolean 42) 318 | (byte true) 319 | (short false) 320 | (int nil) 321 | (float "foo") 322 | (double true) 323 | (cast String 42) 324 | (cast int "foo")))) 325 | 326 | (deftest do-test 327 | (are [expr type expected] (= expected (eval-expr 'type 'expr)) 328 | (do 42) int 42 329 | (do 43 42) int 42 330 | (do) Object nil)) 331 | 332 | (deftest let-test 333 | (testing "valid let expr" 334 | (are [expr type expected] (= expected (eval-expr 'type 'expr)) 335 | (let [x 2] x) int 2 336 | (let [x 2 y 3] (+ x y)) int 5 337 | (let [x 3 x (+ x x)] x) int 6 338 | (let [x 3 y 5] 339 | (let [x (* x x)] 340 | (+ x y))) 341 | int 14 342 | 343 | (let [x 42] 344 | (- x 1) 345 | (+ x 1)) 346 | int 43 347 | 348 | (let [x 100 349 | x (let [x 2] (+ x 1))] 350 | (+ x 1)) 351 | int 4 352 | 353 | (do (let [x 100] x) 354 | (let [x 42] x)) 355 | int 42 356 | 357 | (let [this 42] this) 358 | int 42 359 | 360 | (let [^int c \a] (+ c 1)) int 98)) 361 | (testing "invalid let expr" 362 | (are [expr] (thrown? Compiler$CompilerException (eval-expr 'Object 'expr)) 363 | (let [y x x 5] y) 364 | (let [x 0] 365 | (let [y 1] (+ x y)) 366 | y) 367 | (let [^int x true] x)))) 368 | 369 | (deftest set!-test 370 | (testing "valid set! expr" 371 | (are [expr type expected] (= expected (eval-expr 'type 'expr)) 372 | (let [x 42] 373 | (set! x (+ x 1)) 374 | x) 375 | int 43 376 | 377 | (let [x 0] 378 | (set! x 42)) 379 | int 42 380 | 381 | (let [x 0] 382 | (set! x \a) 383 | x) 384 | int 97 385 | 386 | (let [x 0] 387 | (set! x (Integer/valueOf 1)) 388 | x) 389 | int 1 390 | 391 | (let [x (Integer/valueOf 0)] 392 | (set! x 1) 393 | x) 394 | Integer 1)) 395 | (testing "invalid set! expr" 396 | (are [expr] (thrown? Compiler$CompilerException (eval-expr 'Object 'expr)) 397 | (set! x 0) 398 | (let [x 0] 399 | (set! x "foo")) 400 | (let [x 0] 401 | (set! x (long 42))) 402 | (let [^:final x 0] 403 | (set! x 1)) 404 | (set! this this)))) 405 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 2.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION 5 | OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial content 12 | Distributed under this Agreement, and 13 | 14 | b) in the case of each subsequent Contributor: 15 | i) changes to the Program, and 16 | ii) additions to the Program; 17 | where such changes and/or additions to the Program originate from 18 | and are Distributed by that particular Contributor. A Contribution 19 | "originates" from a Contributor if it was added to the Program by 20 | such Contributor itself or anyone acting on such Contributor's behalf. 21 | Contributions do not include changes or additions to the Program that 22 | are not Modified Works. 23 | 24 | "Contributor" means any person or entity that Distributes the Program. 25 | 26 | "Licensed Patents" mean patent claims licensable by a Contributor which 27 | are necessarily infringed by the use or sale of its Contribution alone 28 | or when combined with the Program. 29 | 30 | "Program" means the Contributions Distributed in accordance with this 31 | Agreement. 32 | 33 | "Recipient" means anyone who receives the Program under this Agreement 34 | or any Secondary License (as applicable), including Contributors. 35 | 36 | "Derivative Works" shall mean any work, whether in Source Code or other 37 | form, that is based on (or derived from) the Program and for which the 38 | editorial revisions, annotations, elaborations, or other modifications 39 | represent, as a whole, an original work of authorship. 40 | 41 | "Modified Works" shall mean any work in Source Code or other form that 42 | results from an addition to, deletion from, or modification of the 43 | contents of the Program, including, for purposes of clarity any new file 44 | in Source Code form that contains any contents of the Program. Modified 45 | Works shall not include works that contain only declarations, 46 | interfaces, types, classes, structures, or files of the Program solely 47 | in each case in order to link to, bind by name, or subclass the Program 48 | or Modified Works thereof. 49 | 50 | "Distribute" means the acts of a) distributing or b) making available 51 | in any manner that enables the transfer of a copy. 52 | 53 | "Source Code" means the form of a Program preferred for making 54 | modifications, including but not limited to software source code, 55 | documentation source, and configuration files. 56 | 57 | "Secondary License" means either the GNU General Public License, 58 | Version 2.0, or any later versions of that license, including any 59 | exceptions or additional permissions as identified by the initial 60 | Contributor. 61 | 62 | 2. GRANT OF RIGHTS 63 | 64 | a) Subject to the terms of this Agreement, each Contributor hereby 65 | grants Recipient a non-exclusive, worldwide, royalty-free copyright 66 | license to reproduce, prepare Derivative Works of, publicly display, 67 | publicly perform, Distribute and sublicense the Contribution of such 68 | Contributor, if any, and such Derivative Works. 69 | 70 | b) Subject to the terms of this Agreement, each Contributor hereby 71 | grants Recipient a non-exclusive, worldwide, royalty-free patent 72 | license under Licensed Patents to make, use, sell, offer to sell, 73 | import and otherwise transfer the Contribution of such Contributor, 74 | if any, in Source Code or other form. This patent license shall 75 | apply to the combination of the Contribution and the Program if, at 76 | the time the Contribution is added by the Contributor, such addition 77 | of the Contribution causes such combination to be covered by the 78 | Licensed Patents. The patent license shall not apply to any other 79 | combinations which include the Contribution. No hardware per se is 80 | licensed hereunder. 81 | 82 | c) Recipient understands that although each Contributor grants the 83 | licenses to its Contributions set forth herein, no assurances are 84 | provided by any Contributor that the Program does not infringe the 85 | patent or other intellectual property rights of any other entity. 86 | Each Contributor disclaims any liability to Recipient for claims 87 | brought by any other entity based on infringement of intellectual 88 | property rights or otherwise. As a condition to exercising the 89 | rights and licenses granted hereunder, each Recipient hereby 90 | assumes sole responsibility to secure any other intellectual 91 | property rights needed, if any. For example, if a third party 92 | patent license is required to allow Recipient to Distribute the 93 | Program, it is Recipient's responsibility to acquire that license 94 | before distributing the Program. 95 | 96 | d) Each Contributor represents that to its knowledge it has 97 | sufficient copyright rights in its Contribution, if any, to grant 98 | the copyright license set forth in this Agreement. 99 | 100 | e) Notwithstanding the terms of any Secondary License, no 101 | Contributor makes additional grants to any Recipient (other than 102 | those set forth in this Agreement) as a result of such Recipient's 103 | receipt of the Program under the terms of a Secondary License 104 | (if permitted under the terms of Section 3). 105 | 106 | 3. REQUIREMENTS 107 | 108 | 3.1 If a Contributor Distributes the Program in any form, then: 109 | 110 | a) the Program must also be made available as Source Code, in 111 | accordance with section 3.2, and the Contributor must accompany 112 | the Program with a statement that the Source Code for the Program 113 | is available under this Agreement, and informs Recipients how to 114 | obtain it in a reasonable manner on or through a medium customarily 115 | used for software exchange; and 116 | 117 | b) the Contributor may Distribute the Program under a license 118 | different than this Agreement, provided that such license: 119 | i) effectively disclaims on behalf of all other Contributors all 120 | warranties and conditions, express and implied, including 121 | warranties or conditions of title and non-infringement, and 122 | implied warranties or conditions of merchantability and fitness 123 | for a particular purpose; 124 | 125 | ii) effectively excludes on behalf of all other Contributors all 126 | liability for damages, including direct, indirect, special, 127 | incidental and consequential damages, such as lost profits; 128 | 129 | iii) does not attempt to limit or alter the recipients' rights 130 | in the Source Code under section 3.2; and 131 | 132 | iv) requires any subsequent distribution of the Program by any 133 | party to be under a license that satisfies the requirements 134 | of this section 3. 135 | 136 | 3.2 When the Program is Distributed as Source Code: 137 | 138 | a) it must be made available under this Agreement, or if the 139 | Program (i) is combined with other material in a separate file or 140 | files made available under a Secondary License, and (ii) the initial 141 | Contributor attached to the Source Code the notice described in 142 | Exhibit A of this Agreement, then the Program may be made available 143 | under the terms of such Secondary Licenses, and 144 | 145 | b) a copy of this Agreement must be included with each copy of 146 | the Program. 147 | 148 | 3.3 Contributors may not remove or alter any copyright, patent, 149 | trademark, attribution notices, disclaimers of warranty, or limitations 150 | of liability ("notices") contained within the Program from any copy of 151 | the Program which they Distribute, provided that Contributors may add 152 | their own appropriate notices. 153 | 154 | 4. COMMERCIAL DISTRIBUTION 155 | 156 | Commercial distributors of software may accept certain responsibilities 157 | with respect to end users, business partners and the like. While this 158 | license is intended to facilitate the commercial use of the Program, 159 | the Contributor who includes the Program in a commercial product 160 | offering should do so in a manner which does not create potential 161 | liability for other Contributors. Therefore, if a Contributor includes 162 | the Program in a commercial product offering, such Contributor 163 | ("Commercial Contributor") hereby agrees to defend and indemnify every 164 | other Contributor ("Indemnified Contributor") against any losses, 165 | damages and costs (collectively "Losses") arising from claims, lawsuits 166 | and other legal actions brought by a third party against the Indemnified 167 | Contributor to the extent caused by the acts or omissions of such 168 | Commercial Contributor in connection with its distribution of the Program 169 | in a commercial product offering. The obligations in this section do not 170 | apply to any claims or Losses relating to any actual or alleged 171 | intellectual property infringement. In order to qualify, an Indemnified 172 | Contributor must: a) promptly notify the Commercial Contributor in 173 | writing of such claim, and b) allow the Commercial Contributor to control, 174 | and cooperate with the Commercial Contributor in, the defense and any 175 | related settlement negotiations. The Indemnified Contributor may 176 | participate in any such claim at its own expense. 177 | 178 | For example, a Contributor might include the Program in a commercial 179 | product offering, Product X. That Contributor is then a Commercial 180 | Contributor. If that Commercial Contributor then makes performance 181 | claims, or offers warranties related to Product X, those performance 182 | claims and warranties are such Commercial Contributor's responsibility 183 | alone. Under this section, the Commercial Contributor would have to 184 | defend claims against the other Contributors related to those performance 185 | claims and warranties, and if a court requires any other Contributor to 186 | pay any damages as a result, the Commercial Contributor must pay 187 | those damages. 188 | 189 | 5. NO WARRANTY 190 | 191 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT 192 | PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS" 193 | BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 194 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF 195 | TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR 196 | PURPOSE. Each Recipient is solely responsible for determining the 197 | appropriateness of using and distributing the Program and assumes all 198 | risks associated with its exercise of rights under this Agreement, 199 | including but not limited to the risks and costs of program errors, 200 | compliance with applicable laws, damage to or loss of data, programs 201 | or equipment, and unavailability or interruption of operations. 202 | 203 | 6. DISCLAIMER OF LIABILITY 204 | 205 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT 206 | PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS 207 | SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 208 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST 209 | PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 210 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 211 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 212 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE 213 | POSSIBILITY OF SUCH DAMAGES. 214 | 215 | 7. GENERAL 216 | 217 | If any provision of this Agreement is invalid or unenforceable under 218 | applicable law, it shall not affect the validity or enforceability of 219 | the remainder of the terms of this Agreement, and without further 220 | action by the parties hereto, such provision shall be reformed to the 221 | minimum extent necessary to make such provision valid and enforceable. 222 | 223 | If Recipient institutes patent litigation against any entity 224 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 225 | Program itself (excluding combinations of the Program with other software 226 | or hardware) infringes such Recipient's patent(s), then such Recipient's 227 | rights granted under Section 2(b) shall terminate as of the date such 228 | litigation is filed. 229 | 230 | All Recipient's rights under this Agreement shall terminate if it 231 | fails to comply with any of the material terms or conditions of this 232 | Agreement and does not cure such failure in a reasonable period of 233 | time after becoming aware of such noncompliance. If all Recipient's 234 | rights under this Agreement terminate, Recipient agrees to cease use 235 | and distribution of the Program as soon as reasonably practicable. 236 | However, Recipient's obligations under this Agreement and any licenses 237 | granted by Recipient relating to the Program shall continue and survive. 238 | 239 | Everyone is permitted to copy and distribute copies of this Agreement, 240 | but in order to avoid inconsistency the Agreement is copyrighted and 241 | may only be modified in the following manner. The Agreement Steward 242 | reserves the right to publish new versions (including revisions) of 243 | this Agreement from time to time. No one other than the Agreement 244 | Steward has the right to modify this Agreement. The Eclipse Foundation 245 | is the initial Agreement Steward. The Eclipse Foundation may assign the 246 | responsibility to serve as the Agreement Steward to a suitable separate 247 | entity. Each new version of the Agreement will be given a distinguishing 248 | version number. The Program (including Contributions) may always be 249 | Distributed subject to the version of the Agreement under which it was 250 | received. In addition, after a new version of the Agreement is published, 251 | Contributor may elect to Distribute the Program (including its 252 | Contributions) under the new version. 253 | 254 | Except as expressly stated in Sections 2(a) and 2(b) above, Recipient 255 | receives no rights or licenses to the intellectual property of any 256 | Contributor under this Agreement, whether expressly, by implication, 257 | estoppel or otherwise. All rights in the Program not expressly granted 258 | under this Agreement are reserved. Nothing in this Agreement is intended 259 | to be enforceable by any entity that is not a Contributor or Recipient. 260 | No third-party beneficiary rights are created under this Agreement. 261 | 262 | Exhibit A - Form of Secondary Licenses Notice 263 | 264 | "This Source Code may also be made available under the following 265 | Secondary Licenses when the conditions for such availability set forth 266 | in the Eclipse Public License, v. 2.0 are satisfied: {name license(s), 267 | version(s), and exceptions or additional permissions here}." 268 | 269 | Simply including a copy of this Agreement, including this Exhibit A 270 | is not sufficient to license the Source Code under Secondary Licenses. 271 | 272 | If it is not possible or desirable to put the notice in a particular 273 | file, then You may include the notice in a location (such as a LICENSE 274 | file in a relevant directory) where a recipient would be likely to 275 | look for such a notice. 276 | 277 | You may add additional accurate notices of copyright ownership. 278 | -------------------------------------------------------------------------------- /test/jise/type_test.clj: -------------------------------------------------------------------------------- 1 | (ns jise.type-test 2 | (:require [clojure.test :refer [deftest testing is are]] 3 | [jise.type :as t]) 4 | (:import [clojure.asm Type] 5 | [java.lang.reflect Modifier] 6 | [java.io BufferedReader])) 7 | 8 | (deftest tag->type-test 9 | (testing "symbol representing primitive type can be converted to corresponding Type" 10 | (are [t type] (= type (t/tag->type t)) 11 | 'boolean t/BOOLEAN 12 | 'byte t/BYTE 13 | 'short t/SHORT 14 | 'char t/CHAR 15 | 'int t/INT 16 | 'long t/LONG 17 | 'float t/FLOAT 18 | 'double t/DOUBLE)) 19 | (testing "symbol representing Java classe can be converted to corresponding Type" 20 | (are [t class] 21 | (= (Type/getType ^Class class) 22 | (binding [*ns* (the-ns 'jise.type-test)] 23 | (t/tag->type t))) 24 | 'String 25 | String 26 | 27 | 'java.util.List 28 | java.util.List 29 | 30 | 'BufferedReader 31 | BufferedReader)) 32 | (testing "vector representing array type can be converted to corresponding Type" 33 | (are [t type] 34 | (= (Type/getType ^String type) (t/tag->type t)) 35 | '[int] 36 | "[I" 37 | 38 | '[Object] 39 | "[Ljava/lang/Object;" 40 | 41 | '[[double]] 42 | "[[D")) 43 | (testing "symbol representing vararg type can be converted to corresponding array Type" 44 | (are [t type] 45 | (= (Type/getType ^String type) 46 | (binding [*ns* (the-ns 'jise.type-test)] 47 | (t/tag->type {} t :allow-vararg-param-type? true))) 48 | 'int... 49 | "[I" 50 | 51 | 'BufferedReader... 52 | "[Ljava/io/BufferedReader;")) 53 | (testing "symbol representing user-defined class can be converted to corresponding Type" 54 | (is (= (Type/getType "Lfoo/bar/C;") 55 | (t/tag->type {:classes {'foo.bar.C {}}} 'foo.bar.C))) 56 | (is (= (Type/getType "Lfoo/bar/C;") 57 | (t/tag->type {:classes {'foo.bar.C {}} 58 | :aliases {'C 'foo.bar.C}} 59 | 'C)))) 60 | (testing "symbol representing unknown type cannot be converted to Type" 61 | (is (thrown-with-msg? Exception #"cannot resolve type UnknownClass" 62 | (t/tag->type 'UnknownClass))) 63 | (is (nil? (t/tag->type {} 'UnknownClass :throws-on-failure? false)))) 64 | (testing "vararg type is not allowed unless it's especially allowed" 65 | (is (thrown-with-msg? Exception #"vararg param type not allowed" 66 | (t/tag->type 'String...))))) 67 | 68 | (deftest type->class-test 69 | (testing "existing classes can be reified with type->class" 70 | (are [type class] 71 | (= class (t/type->class {} type)) 72 | t/CHAR 73 | Character/TYPE 74 | 75 | (Type/getType "Ljava/lang/String;") 76 | String 77 | 78 | (Type/getType "[I") 79 | (Class/forName "[I")) 80 | (let [cenv {:classes {'foo.bar.C {}} 81 | :aliases {'C 'foo.bar.C}}] 82 | (is (= Character/TYPE (t/type->class cenv t/CHAR))))) 83 | (testing "non Java classes cannot be reified with type->class" 84 | (let [cenv {:classes {'foo.bar.C {}} 85 | :aliases {'C 'foo.bar.C}}] 86 | (is (nil? (t/type->class cenv (t/tag->type cenv 'C))))))) 87 | 88 | (deftest type->tag-test 89 | (are [type t] 90 | (= t (t/type->tag type)) 91 | t/BOOLEAN 92 | 'boolean 93 | 94 | t/OBJECT 95 | 'java.lang.Object 96 | 97 | (Type/getType "[I") 98 | '[int] 99 | 100 | (Type/getType "[[Ljava/lang/String;") 101 | '[[java.lang.String]])) 102 | 103 | (deftest super?-test 104 | (testing "t1 is super type of t2" 105 | (are [t1 t2] (t/super? {} t1 t2) 106 | t/SHORT t/BYTE 107 | t/INT t/SHORT 108 | t/INT t/CHAR 109 | t/LONG t/INT 110 | t/FLOAT t/LONG 111 | t/DOUBLE t/FLOAT 112 | t/DOUBLE t/CHAR 113 | t/OBJECT t/STRING 114 | (t/tag->type 'java.io.Closeable) (t/tag->type 'java.io.Reader) 115 | (t/tag->type 'Cloneable) (t/tag->type '[int]) 116 | (t/tag->type '[Object]) (t/tag->type '[String]) 117 | t/STRING nil) 118 | (let [cenv {:classes {'foo.bar.C 119 | {:parent t/OBJECT 120 | :interfaces #{(t/tag->type 'Runnable)}}}}] 121 | (are [t1 t2] (t/super? cenv t1 t2) 122 | (t/tag->type 'Runnable) 123 | (t/tag->type cenv 'foo.bar.C)))) 124 | (testing "t1 is not super type of t2" 125 | (are [t1 t2] (not (t/super? {} t1 t2)) 126 | t/BOOLEAN t/INT 127 | t/INT t/BOOLEAN 128 | (t/tag->type '[long]) (t/tag->type '[int]) 129 | nil t/STRING))) 130 | 131 | (deftest modifiers->access-flags-test 132 | (are [ms expected] 133 | (= expected (t/modifiers->access-flags ms)) 134 | (bit-or Modifier/ABSTRACT Modifier/PUBLIC) 135 | #{:abstract :public} 136 | 137 | (bit-or Modifier/FINAL Modifier/PRIVATE Modifier/STATIC) 138 | #{:final :private :static} 139 | 140 | (bit-or Modifier/PROTECTED Modifier/TRANSIENT) 141 | #{:protected :transient} 142 | 143 | Modifier/VOLATILE 144 | #{:package :volatile})) 145 | 146 | (deftest widening-primitive-conversion-test 147 | (testing "t1 can be widened to t2" 148 | (are [t1 t2] 149 | (= {:conversion :widening-primitive :from t1 :to t2} 150 | (t/widening-primitive-conversion t1 t2)) 151 | t/BYTE t/INT 152 | t/INT t/LONG 153 | t/LONG t/FLOAT 154 | t/FLOAT t/DOUBLE)) 155 | (testing "t1 cannot be widened to t2" 156 | (are [t1 t2] 157 | (= nil (t/widening-primitive-conversion t1 t2)) 158 | t/BOOLEAN t/INT 159 | t/INT t/SHORT 160 | t/DOUBLE t/FLOAT 161 | t/CHAR t/STRING 162 | t/STRING t/CHAR))) 163 | 164 | (deftest narrowing-primitive-conversion-test 165 | (testing "t1 can be narrowed to t2" 166 | (are [t1 t2] 167 | (= {:conversion :narrowing-primitive :from t1 :to t2} 168 | (t/narrowing-primitive-conversion t1 t2)) 169 | t/INT t/CHAR 170 | t/LONG t/SHORT 171 | t/FLOAT t/LONG 172 | t/DOUBLE t/FLOAT)) 173 | (testing "t1 cannot be narrowed to t2" 174 | (are [t1 t2] 175 | (= nil (t/narrowing-primitive-conversion t1 t2)) 176 | t/INT t/BOOLEAN 177 | t/CHAR t/INT 178 | t/FLOAT t/DOUBLE 179 | t/CHAR t/STRING 180 | t/STRING t/CHAR))) 181 | 182 | (deftest boxing-conversion-test 183 | (testing "t1 can be boxed to t2" 184 | (are [t1 t2] 185 | (= {:conversion :boxing :from t1 :to t2} 186 | (t/boxing-conversion t1)) 187 | t/BOOLEAN t/BOOLEAN_CLASS 188 | t/BYTE t/BYTE_CLASS 189 | t/CHAR t/CHARACTER_CLASS 190 | t/SHORT t/SHORT_CLASS 191 | t/INT t/INTEGER_CLASS 192 | t/LONG t/LONG_CLASS 193 | t/FLOAT t/FLOAT_CLASS 194 | t/DOUBLE t/DOUBLE_CLASS)) 195 | (testing "t cannot be boxed" 196 | (are [t] (= nil (t/boxing-conversion t)) 197 | t/BOOLEAN_CLASS 198 | t/STRING 199 | (t/tag->type '[int])))) 200 | 201 | (deftest unboxing-conversion-test 202 | (testing "t1 can be unboxed to t2" 203 | (are [t1 t2] 204 | (= {:conversion :unboxing :from t1 :to t2} 205 | (t/unboxing-conversion t1)) 206 | t/BOOLEAN_CLASS t/BOOLEAN 207 | t/BYTE_CLASS t/BYTE 208 | t/CHARACTER_CLASS t/CHAR 209 | t/SHORT_CLASS t/SHORT 210 | t/INTEGER_CLASS t/INT 211 | t/LONG_CLASS t/LONG 212 | t/FLOAT_CLASS t/FLOAT 213 | t/DOUBLE_CLASS t/DOUBLE)) 214 | (testing "t cannot be unboxed" 215 | (are [t] (= nil (t/unboxing-conversion t)) 216 | t/BOOLEAN 217 | t/STRING 218 | (t/tag->type '[Integer])))) 219 | 220 | (deftest widening-reference-conversion-test 221 | (testing "t1 can be widened to t2" 222 | (are [t1 t2] 223 | (= {:conversion :widening-reference :from t1 :to t2} 224 | (binding [*ns* (the-ns 'jise.type-test)] 225 | (t/widening-reference-conversion {} t1 t2))) 226 | t/STRING t/OBJECT 227 | (t/tag->type 'java.io.BufferedReader) (t/tag->type 'java.io.Closeable) 228 | (t/tag->type '[String]) (t/tag->type '[Object]) 229 | nil t/STRING) 230 | (let [r (t/tag->type 'java.io.Reader) 231 | cenv {:classes {'foo.bar.C {:parent r}}} 232 | c (t/tag->type cenv 'foo.bar.C)] 233 | (is (= {:conversion :widening-reference :from c :to r} 234 | (t/widening-reference-conversion cenv c r))))) 235 | (testing "t1 cannot be widened to t2" 236 | (are [t1 t2] (= nil (t/widening-reference-conversion {} t1 t2)) 237 | t/INT t/LONG 238 | t/OBJECT t/STRING 239 | t/STRING (t/tag->type 'java.io.Closeable) 240 | t/STRING nil))) 241 | 242 | (deftest narrowing-reference-conversion-test 243 | (testing "t1 can be narrowed to t2" 244 | (are [t1 t2] 245 | (= {:conversion :narrowing-reference :from t1 :to t2} 246 | (t/narrowing-reference-conversion {} t1 t2)) 247 | t/OBJECT t/STRING 248 | (t/tag->type 'java.io.Closeable) (t/tag->type 'java.io.BufferedReader) 249 | (t/tag->type '[Object]) (t/tag->type '[String]) 250 | t/OBJECT (t/tag->type '[int]) 251 | (t/tag->type 'Cloneable) (t/tag->type 'java.io.Serializable) 252 | t/STRING nil) 253 | (let [r (t/tag->type 'java.io.Reader) 254 | cenv {:classes {'foo.bar.C {:parent r}}} 255 | c (t/tag->type cenv 'foo.bar.C)] 256 | (is (= {:conversion :narrowing-reference :from r :to c} 257 | (t/narrowing-reference-conversion cenv r c))))) 258 | (testing "t1 cannot be narrowed to t2" 259 | (are [t1 t2] 260 | (= nil (t/narrowing-reference-conversion {} t1 t2)) 261 | t/LONG t/INT 262 | t/STRING t/OBJECT 263 | t/STRING (t/tag->type '[long]) 264 | (t/tag->type 'java.io.Closeable) t/STRING 265 | nil t/STRING))) 266 | 267 | (deftest assignment-conversion-test 268 | (testing "t1 can be converted to t2 in assignment context" 269 | (are [t1 t2 expected] 270 | (= expected (t/assignment-conversion {} t1 t2)) 271 | t/INT t/INT 272 | [] 273 | 274 | t/INT t/LONG 275 | [{:conversion :widening-primitive :from t/INT :to t/LONG}] 276 | 277 | t/INT t/INTEGER_CLASS 278 | [{:conversion :boxing :from t/INT :to t/INTEGER_CLASS}] 279 | 280 | t/CHAR t/OBJECT 281 | [{:conversion :boxing :from t/CHAR :to t/CHARACTER_CLASS} 282 | {:conversion :widening-reference :from t/CHARACTER_CLASS :to t/OBJECT}] 283 | 284 | t/BOOLEAN_CLASS t/BOOLEAN 285 | [{:conversion :unboxing :from t/BOOLEAN_CLASS :to t/BOOLEAN}] 286 | 287 | t/CHARACTER_CLASS t/DOUBLE 288 | [{:conversion :unboxing :from t/CHARACTER_CLASS :to t/CHAR} 289 | {:conversion :widening-primitive :from t/CHAR :to t/DOUBLE}] 290 | 291 | t/STRING t/OBJECT 292 | [{:conversion :widening-reference :from t/STRING :to t/OBJECT}] 293 | 294 | nil t/STRING 295 | [{:conversion :widening-reference :from nil :to t/STRING}]) 296 | (let [r (t/tag->type 'java.io.Reader) 297 | cenv {:classes {'foo.bar.C {:parent r}}} 298 | c (t/tag->type cenv 'foo.bar.C)] 299 | (is (= [{:conversion :widening-reference :from c :to r}] 300 | (t/assignment-conversion cenv c r))))) 301 | (testing "t1 cannot be converted to t2 in assignment context" 302 | (are [t1 t2] (= nil (t/assignment-conversion {} t1 t2)) 303 | t/LONG t/INT 304 | t/INT t/LONG_CLASS 305 | t/FLOAT_CLASS t/INT 306 | t/OBJECT t/STRING 307 | t/STRING nil))) 308 | 309 | (deftest casting-conversion-test 310 | (testing "t1 can be converted to t2 in casting context" 311 | (are [t1 t2 expected] 312 | (= expected (t/casting-conversion {} t1 t2)) 313 | t/INT t/INT 314 | [] 315 | 316 | t/INT t/LONG 317 | [{:conversion :widening-primitive :from t/INT :to t/LONG}] 318 | 319 | t/DOUBLE t/LONG 320 | [{:conversion :narrowing-primitive :from t/DOUBLE :to t/LONG}] 321 | 322 | t/CHAR t/CHARACTER_CLASS 323 | [{:conversion :boxing :from t/CHAR :to t/CHARACTER_CLASS}] 324 | 325 | t/FLOAT t/OBJECT 326 | [{:conversion :boxing :from t/FLOAT :to t/FLOAT_CLASS} 327 | {:conversion :widening-reference :from t/FLOAT_CLASS :to t/OBJECT}] 328 | 329 | t/LONG_CLASS t/LONG 330 | [{:conversion :unboxing :from t/LONG_CLASS :to t/LONG}] 331 | 332 | t/OBJECT t/CHAR 333 | [{:conversion :narrowing-reference :from t/OBJECT :to t/CHARACTER_CLASS} 334 | {:conversion :unboxing :from t/CHARACTER_CLASS :to t/CHAR}] 335 | 336 | t/STRING t/OBJECT 337 | [{:conversion :widening-reference :from t/STRING :to t/OBJECT}] 338 | 339 | (t/tag->type 'java.io.Reader) 340 | (t/tag->type 'java.io.BufferedReader) 341 | [{:conversion :narrowing-reference 342 | :from (t/tag->type 'java.io.Reader) 343 | :to (t/tag->type 'java.io.BufferedReader)}] 344 | 345 | nil t/STRING 346 | [{:conversion :widening-reference :from nil :to t/STRING}] 347 | 348 | t/STRING nil 349 | [{:conversion :narrowing-reference :from t/STRING :to nil}]) 350 | (let [r (t/tag->type 'java.io.Reader) 351 | cenv {:classes {'foo.bar.C {:parent r}}} 352 | c (t/tag->type cenv 'foo.bar.C)] 353 | (is (= [{:conversion :narrowing-reference :from r :to c}] 354 | (t/casting-conversion cenv r c))))) 355 | (testing "t1 cannot be converted to t2 in casting context" 356 | (are [t1 t2] (= nil (t/casting-conversion {} t1 t2)) 357 | t/INT t/LONG_CLASS 358 | t/CHAR nil 359 | t/FLOAT_CLASS t/INT 360 | nil t/BOOLEAN))) 361 | 362 | (deftest unary-numeric-promotion-test 363 | (testing "t can be promoted by unary numeric promotion" 364 | (are [t expected] (= expected (t/unary-numeric-promotion t)) 365 | t/INT 366 | [] 367 | 368 | t/LONG 369 | [] 370 | 371 | t/BYTE 372 | [{:conversion :widening-primitive :from t/BYTE :to t/INT}] 373 | 374 | t/CHARACTER_CLASS 375 | [{:conversion :unboxing :from t/CHARACTER_CLASS :to t/CHAR} 376 | {:conversion :widening-primitive :from t/CHAR :to t/INT}] 377 | 378 | t/FLOAT_CLASS 379 | [{:conversion :unboxing :from t/FLOAT_CLASS :to t/FLOAT}])) 380 | (testing "t cannot be promoted by unary numeric promotion" 381 | (are [t] (= nil (t/unary-numeric-promotion t)) 382 | t/BOOLEAN 383 | (t/tag->type '[int]) 384 | t/STRING 385 | nil))) 386 | 387 | (deftest binary-numeric-promotion-test 388 | (testing "t1 and t2 can be promoted by binary numeric promotion" 389 | (are [t1 t2 expected] (= expected (t/binary-numeric-promotion t1 t2)) 390 | t/INT t/INT 391 | [[] []] 392 | 393 | t/DOUBLE t/DOUBLE 394 | [[] []] 395 | 396 | t/INT t/SHORT 397 | [[] 398 | [{:conversion :widening-primitive :from t/SHORT :to t/INT}]] 399 | 400 | t/CHAR t/LONG 401 | [[{:conversion :widening-primitive :from t/CHAR :to t/LONG}] 402 | []] 403 | 404 | t/BYTE t/SHORT 405 | [[{:conversion :widening-primitive :from t/BYTE :to t/INT}] 406 | [{:conversion :widening-primitive :from t/SHORT :to t/INT}]] 407 | 408 | t/INT t/INTEGER_CLASS 409 | [[] 410 | [{:conversion :unboxing :from t/INTEGER_CLASS :to t/INT}]] 411 | 412 | t/LONG_CLASS t/INT 413 | [[{:conversion :unboxing :from t/LONG_CLASS :to t/LONG}] 414 | [{:conversion :widening-primitive :from t/INT :to t/LONG}]] 415 | 416 | t/FLOAT_CLASS t/DOUBLE_CLASS 417 | [[{:conversion :unboxing :from t/FLOAT_CLASS :to t/FLOAT} 418 | {:conversion :widening-primitive :from t/FLOAT :to t/DOUBLE}] 419 | [{:conversion :unboxing :from t/DOUBLE_CLASS :to t/DOUBLE}]])) 420 | (testing "t1 and t2 cannot be promoted by binary numeric promotion" 421 | (are [t1 t2] (= nil (t/binary-numeric-promotion t1 t2)) 422 | t/OBJECT t/INT 423 | t/INT (t/tag->type '[int]) 424 | nil t/LONG 425 | t/DOUBLE nil))) 426 | 427 | (deftest find-field-test 428 | (let [system (t/tag->type 'System)] 429 | (is (= {:class system :type (t/tag->type 'java.io.PrintStream) 430 | :access #{:static :public :final}} 431 | (t/find-field {} nil system "out")))) 432 | (let [reader (t/tag->type 'java.io.Reader)] 433 | (is (= {:class reader :type t/OBJECT :access #{:protected}} 434 | (t/find-field {} nil reader "lock"))) 435 | (is (= nil (t/find-field {} nil reader "noSuchField")))) 436 | (let [cenv {:classes 437 | {'foo.bar.C 438 | {:parent (t/tag->type 'java.io.BufferedReader) 439 | :fields {"f" {:type t/INT :access #{:private}} 440 | "g" {:type t/STRING :access #{:static :public :final}}}} 441 | 'foo.bar.D {:parent t/OBJECT}}} 442 | c (t/tag->type cenv 'foo.bar.C) 443 | d (t/tag->type cenv 'foo.bar.D)] 444 | (is (= {:class c :type t/INT :access #{:private}} 445 | (t/find-field cenv c c "f"))) 446 | (is (= nil (t/find-field cenv d c "f"))) 447 | (is (= {:class c :type t/STRING :access #{:static :public :final}} 448 | (t/find-field cenv c c "g"))) 449 | (is (= {:class c :type t/STRING :access #{:static :public :final}} 450 | (t/find-field cenv d c "g"))) 451 | (is (= {:class (t/tag->type 'java.io.Reader) :type t/OBJECT :access #{:protected}} 452 | (t/find-field cenv c c "lock"))) 453 | (is (= nil (t/find-field cenv d c "lock"))))) 454 | 455 | (deftest get-methods-test 456 | (is (= #{{:class t/INTEGER_CLASS :interface? false :access #{:public :static} 457 | :param-types [t/INT] :return-type t/INTEGER_CLASS} 458 | {:class t/INTEGER_CLASS :interface? false :access #{:public :static} 459 | :param-types [t/STRING t/INT] :return-type t/INTEGER_CLASS} 460 | {:class t/INTEGER_CLASS :interface? false :access #{:public :static} 461 | :param-types [t/STRING] :return-type t/INTEGER_CLASS}} 462 | (set (t/get-methods {} nil t/INTEGER_CLASS "valueOf")))) 463 | (is (= nil (t/get-methods {} nil t/STRING "noSuchMethod"))) 464 | (let [cl (t/tag->type 'ClassLoader)] 465 | (is (= #{{:class cl :interface? false :access #{:public} 466 | :param-types [t/STRING] :return-type (t/tag->type 'Class)} 467 | {:class cl :interface? false :access #{:protected} 468 | :param-types [t/STRING t/BOOLEAN] :return-type (t/tag->type 'Class)}} 469 | (set (t/get-methods {} (t/tag->type 'java.net.URLClassLoader) cl "loadClass")))) 470 | (is (= [{:class cl :interface? false :access #{:public} 471 | :param-types [t/STRING] :return-type (t/tag->type 'Class)}] 472 | (t/get-methods {} t/OBJECT cl "loadClass")))) 473 | (is (= [{:class (t/tag->type 'java.io.InputStream) :interface? false :access #{:public} 474 | :param-types [] :return-type t/VOID}] 475 | (t/get-methods {} t/OBJECT (t/tag->type 'java.io.InputStream) "close"))) 476 | (is (= [{:class (t/tag->type 'java.io.Closeable) :interface? true :access #{:public :abstract} 477 | :param-types [] :return-type t/VOID}] 478 | (t/get-methods {} t/OBJECT (t/tag->type 'java.io.Closeable) "close"))) 479 | (is (= [{:class t/OBJECT :interface? false :access #{:public} 480 | :param-types [] :return-type t/STRING}] 481 | (t/get-methods {} t/OBJECT (t/tag->type 'java.io.Closeable) "toString"))) 482 | (let [cl (t/tag->type 'ClassLoader) 483 | class (t/tag->type 'Class) 484 | cenv {:classes 485 | {'foo.bar.C 486 | {:parent cl 487 | :methods {"m" [{:interface? false :access #{:public} 488 | :param-types [t/STRING] :return-type t/INT} 489 | {:interface? false :access #{:private} 490 | :param-types [t/STRING t/INT] :return-type t/INT}] 491 | "loadClass" [{:interface? false :access #{:public} 492 | :param-types [t/STRING] :return-type class}]}} 493 | 'foo.bar.D {:parent t/OBJECT}}} 494 | c (t/tag->type cenv 'foo.bar.C) 495 | d (t/tag->type cenv 'foo.bar.D)] 496 | (are [caller callee name expected] 497 | (= expected (set (t/get-methods cenv caller callee name))) 498 | c c "m" 499 | #{{:class c :interface? false :access #{:public} 500 | :param-types [t/STRING] :return-type t/INT} 501 | {:class c :interface? false :access #{:private} 502 | :param-types [t/STRING t/INT] :return-type t/INT}} 503 | 504 | d c "m" 505 | #{{:class c :interface? false :access #{:public} 506 | :param-types [t/STRING] :return-type t/INT}} 507 | 508 | c c "noSuchMethod" 509 | #{} 510 | 511 | c c "resolveClass" 512 | #{{:class cl :interface? false :access #{:protected :final} 513 | :param-types [class] :return-type t/VOID}} 514 | 515 | d c "resolveClass" 516 | #{} 517 | 518 | c c "loadClass" 519 | #{{:class cl :interface? false :access #{:protected} 520 | :param-types [t/STRING t/BOOLEAN] :return-type class} 521 | {:class c :interface? false :access #{:public} 522 | :param-types [t/STRING] :return-type class}}))) 523 | -------------------------------------------------------------------------------- /src/jise/type.clj: -------------------------------------------------------------------------------- 1 | (ns jise.type 2 | (:require [clojure.string :as str] 3 | [jise.misc :as misc]) 4 | (:import [clojure.asm Opcodes Type] 5 | [java.lang.reflect Constructor Field Method Modifier])) 6 | 7 | (set! *warn-on-reflection* true) 8 | 9 | (def VOID Type/VOID_TYPE) 10 | (def BOOLEAN Type/BOOLEAN_TYPE) 11 | (def BYTE Type/BYTE_TYPE) 12 | (def CHAR Type/CHAR_TYPE) 13 | (def SHORT Type/SHORT_TYPE) 14 | (def INT Type/INT_TYPE) 15 | (def LONG Type/LONG_TYPE) 16 | (def FLOAT Type/FLOAT_TYPE) 17 | (def DOUBLE Type/DOUBLE_TYPE) 18 | (def OBJECT (Type/getType Object)) 19 | (def STRING (Type/getType String)) 20 | (def CLASS (Type/getType Class)) 21 | (def THROWABLE (Type/getType Throwable)) 22 | 23 | (def VOID_CLASS (Type/getType Void)) 24 | (def BOOLEAN_CLASS (Type/getType Boolean)) 25 | (def BYTE_CLASS (Type/getType Byte)) 26 | (def CHARACTER_CLASS (Type/getType Character)) 27 | (def SHORT_CLASS (Type/getType Short)) 28 | (def INTEGER_CLASS (Type/getType Integer)) 29 | (def LONG_CLASS (Type/getType Long)) 30 | (def FLOAT_CLASS (Type/getType Float)) 31 | (def DOUBLE_CLASS (Type/getType Double)) 32 | 33 | (def ^:private primitive->type 34 | {'boolean BOOLEAN 35 | 'byte BYTE 36 | 'char CHAR 37 | 'short SHORT 38 | 'int INT 39 | 'long LONG 40 | 'float FLOAT 41 | 'double DOUBLE 42 | 'void VOID}) 43 | 44 | (def primitive-type? 45 | (comp boolean (set (vals primitive->type)))) 46 | 47 | (def integral-type? #{BYTE CHAR SHORT INT LONG}) 48 | (def numeric-type? (conj integral-type? FLOAT DOUBLE)) 49 | 50 | (defn boolean-type? [t] 51 | (or (= t BOOLEAN) (= t BOOLEAN_CLASS))) 52 | 53 | (def ^:private ^:const primitive-array-types 54 | '{ints [int] 55 | shorts [short] 56 | longs [long] 57 | floats [float] 58 | doubles [double] 59 | chars [char] 60 | bytes [byte] 61 | booleans [boolean]}) 62 | 63 | (defn array-type? [^Type t] 64 | (= (.getSort t) Type/ARRAY)) 65 | 66 | (defn ^Type element-type [^Type t] 67 | (Type/getType (str/replace (.getDescriptor t) #"^\[" ""))) 68 | 69 | (defn ^Type array-type [^Type t] 70 | (Type/getType (str \[ (.getDescriptor t)))) 71 | 72 | (declare tag->type) 73 | 74 | (defn- tag->array-type [cenv tag & {:keys [throws-on-failure?] :or {throws-on-failure? true}}] 75 | (let [elem-type (first tag)] 76 | (when-let [t (tag->type cenv elem-type :throws-on-failure? throws-on-failure?)] 77 | (array-type t)))) 78 | 79 | (defn find-in-cenv [cenv tag] 80 | (if-let [alias (get (:aliases cenv) tag)] 81 | (recur cenv alias) 82 | (when (contains? (:classes cenv) tag) 83 | (Type/getType (str \L (str/replace (str tag) \. \/) \;))))) 84 | 85 | (defn ^Type tag->type 86 | ([tag] (tag->type {} tag)) 87 | ([cenv tag & {:keys [allow-vararg-param-type? throws-on-failure?] :or {throws-on-failure? true}}] 88 | (letfn [(fail [] 89 | (when throws-on-failure? 90 | (throw (ex-info (str "cannot resolve type " (pr-str tag)) 91 | {:cause :unresolved-type :tag tag}))))] 92 | (cond (symbol? tag) (if (namespace tag) 93 | (let [tag' (misc/fixup-ns tag)] 94 | (if (namespace tag') 95 | (fail) 96 | (tag->type cenv tag' 97 | :allow-vararg-param-type? allow-vararg-param-type? 98 | :throws-on-failure? throws-on-failure?))) 99 | (or (primitive->type tag) 100 | (as-> (get primitive-array-types tag) t 101 | (tag->type cenv t 102 | :allow-vararg-param-type? allow-vararg-param-type? 103 | :throws-on-failure? throws-on-failure?)) 104 | (find-in-cenv cenv tag) 105 | (when-let [c (resolve tag)] 106 | (when (class? c) 107 | (Type/getType ^Class c))) 108 | (when-let [[_ name] (re-matches #"(.+)\.\.\.$" (name tag))] 109 | (if allow-vararg-param-type? 110 | (tag->array-type cenv [(symbol name)] 111 | :throws-on-failure? throws-on-failure?) 112 | (throw (ex-info "vararg param type not allowed here" 113 | {:cause :invalid-vararg-param-type})))) 114 | (fail))) 115 | (class? tag) (Type/getType ^Class tag) 116 | (vector? tag) (tag->array-type cenv tag :throws-on-failure? throws-on-failure?) 117 | (nil? tag) nil 118 | :else (fail))))) 119 | 120 | (def ^:private primitive-iname->class 121 | {"Z" Boolean/TYPE 122 | "B" Byte/TYPE 123 | "C" Character/TYPE 124 | "S" Short/TYPE 125 | "I" Integer/TYPE 126 | "J" Long/TYPE 127 | "F" Float/TYPE 128 | "D" Double/TYPE}) 129 | 130 | (defn ^Class type->class [cenv ^Type t] 131 | (when-not (find-in-cenv cenv (symbol (.getClassName t))) 132 | (let [iname (.getInternalName t)] 133 | (try 134 | (if (str/starts-with? iname "[") 135 | (Class/forName (str/replace iname #"/" ".")) 136 | (or (primitive-iname->class iname) 137 | (resolve (symbol (.getClassName t))))) 138 | (catch ClassNotFoundException _))))) 139 | 140 | (defn ^Type class->type [^Class class] 141 | (Type/getType class)) 142 | 143 | (defn type->symbol [^Type t] 144 | (symbol (.getClassName t))) 145 | 146 | (def ^:private primitive-type->symbol 147 | {BOOLEAN 'boolean 148 | BYTE 'byte 149 | CHAR 'char 150 | SHORT 'short 151 | INT 'int 152 | LONG 'long 153 | FLOAT 'float 154 | DOUBLE 'double}) 155 | 156 | (defn type->tag [^Type t] 157 | (cond (nil? t) nil 158 | (array-type? t) [(type->tag (element-type t))] 159 | :else (or (primitive-type->symbol t) 160 | (symbol (.getClassName t))))) 161 | 162 | (defn modifiers->access-flags [ms] 163 | (cond-> #{} 164 | (Modifier/isAbstract ms) (conj :abstract) 165 | (Modifier/isFinal ms) (conj :final) 166 | (Modifier/isPrivate ms) (conj :private) 167 | (Modifier/isProtected ms) (conj :protected) 168 | (Modifier/isPublic ms) (conj :public) 169 | (Modifier/isStatic ms) (conj :static) 170 | (Modifier/isTransient ms) (conj :transient) 171 | (Modifier/isVolatile ms) (conj :volatile) 172 | (->> (bit-or Modifier/PUBLIC Modifier/PROTECTED Modifier/PRIVATE) 173 | (bit-and ms) 174 | (= 0)) 175 | (conj :package))) 176 | 177 | (defn- modifiers-of [cenv t] 178 | (when-not (primitive-type? t) 179 | (let [tag (type->tag t)] 180 | (or (some-> (get-in cenv [:classes tag]) :access) 181 | (when-let [^Class class (type->class cenv t)] 182 | (modifiers->access-flags (.getModifiers class))))))) 183 | 184 | (defn final-type? [cenv t] 185 | (:final (modifiers-of cenv t))) 186 | 187 | (defn abstract-type? [cenv t] 188 | (:abstract (modifiers-of cenv t))) 189 | 190 | (def ^:private wider-primitive-types 191 | {BYTE #{SHORT INT LONG FLOAT DOUBLE} 192 | SHORT #{INT LONG FLOAT DOUBLE} 193 | CHAR #{INT LONG FLOAT DOUBLE} 194 | INT #{LONG FLOAT DOUBLE} 195 | LONG #{FLOAT DOUBLE} 196 | FLOAT #{DOUBLE}}) 197 | 198 | (def ^:private narrower-primitive-types 199 | {SHORT #{BYTE CHAR} 200 | CHAR #{BYTE SHORT} 201 | INT #{BYTE SHORT CHAR} 202 | LONG #{BYTE SHORT CHAR INT} 203 | FLOAT #{BYTE SHORT CHAR INT LONG} 204 | DOUBLE #{BYTE SHORT CHAR INT LONG FLOAT}}) 205 | 206 | (defn- proper-primitive-super? [t1 t2] 207 | (boolean (get-in narrower-primitive-types [t1 t2]))) 208 | 209 | (def ^:private CLONEABLE (Type/getType Cloneable)) 210 | (def ^:private SERIALIZABLE (Type/getType java.io.Serializable)) 211 | 212 | (defn- proper-reference-super? [cenv t1 t2] 213 | (or (= t1 OBJECT) 214 | (= t2 nil) 215 | (and (not= t1 nil) 216 | (if (array-type? t2) 217 | (or (#{OBJECT CLONEABLE SERIALIZABLE} t1) 218 | (let [et (element-type t2)] 219 | (and (not (primitive-type? et)) 220 | (array-type? t1) 221 | (proper-reference-super? cenv (element-type t1) et)))) 222 | (loop [t t2] 223 | (if-let [{:keys [parent interfaces]} (get-in cenv [:classes (type->symbol t)])] 224 | (cond (or (= parent t1) (contains? interfaces t1)) true 225 | (= parent OBJECT) false 226 | :else (recur parent)) 227 | (when-let [c (type->class cenv t)] 228 | (when-let [c1 (type->class cenv t1)] 229 | (contains? (supers c) c1))))))))) 230 | 231 | (defn super? [cenv t1 t2] 232 | (or (= t1 t2) 233 | (case [(primitive-type? t1) (primitive-type? t2)] 234 | [true true ] (proper-primitive-super? t1 t2) 235 | [false false] (proper-reference-super? cenv t1 t2) 236 | false))) 237 | 238 | (defn ^Type object-type [obj] 239 | (cond (boolean? obj) BOOLEAN 240 | (char? obj) CHAR 241 | (integer? obj) INT 242 | (or (float? obj) (decimal? obj)) DOUBLE 243 | (string? obj) STRING 244 | (instance? Type obj) CLASS 245 | :else nil)) 246 | 247 | (defn type-category ^long [t] 248 | (if (#{LONG DOUBLE} t) 2 1)) 249 | 250 | (defn widening-primitive-conversion [from to] 251 | (when (get-in wider-primitive-types [from to]) 252 | {:conversion :widening-primitive :from from :to to})) 253 | 254 | (defn narrowing-primitive-conversion [from to] 255 | (when (get-in narrower-primitive-types [from to]) 256 | {:conversion :narrowing-primitive :from from :to to})) 257 | 258 | (def boxed-types 259 | {VOID VOID_CLASS 260 | BOOLEAN BOOLEAN_CLASS 261 | BYTE BYTE_CLASS 262 | CHAR CHARACTER_CLASS 263 | SHORT SHORT_CLASS 264 | INT INTEGER_CLASS 265 | LONG LONG_CLASS 266 | FLOAT FLOAT_CLASS 267 | DOUBLE DOUBLE_CLASS}) 268 | 269 | (def unboxed-types 270 | (into {} (map (fn [[k v]] [v k])) boxed-types)) 271 | 272 | (defn convertible-to-integral? [t] 273 | (or (integral-type? t) 274 | (some-> (unboxed-types t) integral-type?))) 275 | 276 | (defn convertible-to-numeric? [t] 277 | (or (numeric-type? t) 278 | (some-> (unboxed-types t) numeric-type?))) 279 | 280 | (defn constant-value-compatible-with? [type value] 281 | (when value 282 | (or (when (convertible-to-integral? type) (int? value)) 283 | (when (convertible-to-numeric? type) (double? value)) 284 | (when (= type STRING) (string? value)) 285 | (when (boolean-type? type) (boolean? value))))) 286 | 287 | (defn boxing-conversion [t] 288 | (when-let [t' (boxed-types t)] 289 | {:conversion :boxing :from t :to t'})) 290 | 291 | (defn unboxing-conversion [t] 292 | (when-let [t' (unboxed-types t)] 293 | {:conversion :unboxing :from t :to t'})) 294 | 295 | (defn widening-reference-conversion [cenv from to] 296 | (when (and (not (primitive-type? from)) 297 | (not (primitive-type? to)) 298 | (proper-reference-super? cenv to from)) 299 | {:conversion :widening-reference :from from :to to})) 300 | 301 | (defn narrowing-reference-conversion [cenv from to] 302 | (when (and (not (primitive-type? from)) 303 | (not (primitive-type? to)) 304 | (not (proper-reference-super? cenv to from)) 305 | (or (proper-reference-super? cenv from to) 306 | (and (array-type? to) 307 | (or (#{OBJECT CLONEABLE SERIALIZABLE} from) 308 | (and (array-type? from) 309 | (let [e1 (element-type from) e2 (element-type to)] 310 | (narrowing-reference-conversion cenv e1 e2))))) 311 | (case [(boolean (some-> (type->class cenv from) (.isInterface))) 312 | (boolean (some-> (type->class cenv to) (.isInterface)))] 313 | [false true ] (not (final-type? cenv from)) 314 | [true false] (not (final-type? cenv to)) 315 | [true true] true 316 | false))) 317 | {:conversion :narrowing-reference :from from :to to})) 318 | 319 | (defn assignment-conversion [cenv from to] 320 | (if (= from to) 321 | [] 322 | (case [(primitive-type? from) (primitive-type? to)] 323 | [true true ] (when-let [c (widening-primitive-conversion from to)] 324 | [c]) 325 | [true false] (let [box (boxing-conversion from)] 326 | (or (and (= (:to box) to) [box]) 327 | (when-let [widen (widening-reference-conversion cenv (:to box) to)] 328 | [box widen]))) 329 | [false true ] (let [unbox (unboxing-conversion from)] 330 | (or (and (= (:to unbox) to) [unbox]) 331 | (when-let [widen (widening-primitive-conversion (:to unbox) to)] 332 | [unbox widen]))) 333 | [false false] (when-let [c (widening-reference-conversion cenv from to)] 334 | [c])))) 335 | 336 | (defn casting-conversion [cenv from to] 337 | (if (= from to) 338 | [] 339 | (case [(primitive-type? from) (primitive-type? to)] 340 | [true true ] (when-let [c (or (widening-primitive-conversion from to) 341 | (narrowing-primitive-conversion from to))] 342 | [c]) 343 | [true false] (let [box (boxing-conversion from)] 344 | (or (and (= (:to box) to) [box]) 345 | (when-let [widen (widening-reference-conversion cenv (:to box) to)] 346 | [box widen]))) 347 | [false true ] (if (= from OBJECT) 348 | (let [box (boxing-conversion to)] 349 | [{:conversion :narrowing-reference :from from :to (:to box)} 350 | {:conversion :unboxing :from (:to box) :to (:from box)}]) 351 | (let [unbox (unboxing-conversion from)] 352 | (or (and (= (:to unbox) to) [unbox]) 353 | (when-let [widen (widening-primitive-conversion (:to unbox) to)] 354 | [unbox widen])))) 355 | [false false] (when-let [c (or (widening-reference-conversion cenv from to) 356 | (narrowing-reference-conversion cenv from to))] 357 | [c])))) 358 | 359 | (defn unary-numeric-promotion [t] 360 | (condp contains? t 361 | #{BYTE_CLASS SHORT_CLASS CHARACTER_CLASS} 362 | (let [unbox (unboxing-conversion t) 363 | widen (widening-primitive-conversion (:to unbox) INT)] 364 | [unbox widen]) 365 | 366 | #{INTEGER_CLASS LONG_CLASS FLOAT_CLASS DOUBLE_CLASS} 367 | [(unboxing-conversion t)] 368 | 369 | #{BYTE SHORT CHAR} 370 | [(widening-primitive-conversion t INT)] 371 | 372 | #{INT LONG DOUBLE} 373 | [] 374 | 375 | nil)) 376 | 377 | (defn binary-numeric-promotion [t1 t2] 378 | (let [unbox1 (unboxing-conversion t1) 379 | unbox2 (unboxing-conversion t2) 380 | t1' (or (:to unbox1) t1) 381 | t2' (or (:to unbox2) t2)] 382 | (when (and (numeric-type? t1') (numeric-type? t2')) 383 | (let [widened (or (some (hash-set t1' t2') [DOUBLE FLOAT LONG]) INT) 384 | f (fn [t unbox] 385 | (let [widen (widening-primitive-conversion t widened)] 386 | (cond-> [] 387 | unbox (conj unbox) 388 | widen (conj widen))))] 389 | [(f t1' unbox1) (f t2' unbox2)])))) 390 | 391 | (defn- walk-class-hierarchy [^Class class f] 392 | ;; Here we assume that a JiSE class belongs to a package other than 393 | ;; any package a Java class belongs to, so JiSE classes can't refer to 394 | ;; any non-public Java classes 395 | (letfn [(walk [^Class c] 396 | (when c 397 | (concat (when (Modifier/isPublic (.getModifiers c)) 398 | (f c)) 399 | (mapcat walk (.getInterfaces c)) 400 | (walk (.getSuperclass c)))))] 401 | (walk class))) 402 | 403 | (defn- accessible-from? [cenv caller class access] 404 | (or (:public access) 405 | (and (or (:private access) (:package access)) (= caller class)) 406 | (and (:protected access) (super? cenv class caller)))) 407 | 408 | (defn find-field [cenv caller class name] 409 | (let [class-name (type->symbol class) 410 | name' (munge name)] 411 | (letfn [(field->map [c ^Field f] 412 | (let [type (class->type (.getType f)) 413 | access (modifiers->access-flags (.getModifiers f))] 414 | (when (accessible-from? cenv caller (class->type c) access) 415 | (cond-> {:class (class->type (.getDeclaringClass f)) 416 | :type type 417 | :access access} 418 | (and (:static access) (:final access) 419 | (or (primitive-type? type) (= type STRING))) 420 | (assoc :value (.get f nil)))))) 421 | (walk [^Class c] 422 | (-> (walk-class-hierarchy c 423 | (fn [^Class c] 424 | (some->> (.getDeclaredFields c) 425 | (filter #(= (.getName ^Field %) name')) 426 | first 427 | (field->map c) 428 | vector))) 429 | first))] 430 | (if-let [entry (get-in cenv [:classes class-name])] 431 | (if-let [field (get-in entry [:fields name])] 432 | (when (accessible-from? cenv caller class (:access field)) 433 | (assoc field :class class)) 434 | ;; Here we assume all the superclasses and interfaces are defined outside of JiSE 435 | (let [{:keys [parent interfaces]} entry] 436 | (or (some walk (map (partial type->class cenv) interfaces)) 437 | (walk (type->class cenv parent))))) 438 | (walk (type->class cenv class)))))) 439 | 440 | (defn- remove-overridden-methods [cenv methods] 441 | (->> methods 442 | (reduce (fn [ms {:keys [param-types] :as m}] 443 | (if-let [m' (get ms param-types)] 444 | (cond-> ms (super? cenv (:class m') (:class m)) (assoc param-types m)) 445 | (assoc ms param-types m))) 446 | {}) 447 | vals)) 448 | 449 | (defn- params-compatible? [nargs nparams varargs?] 450 | (or (= nargs nparams) 451 | (and varargs? (>= nargs (dec nparams))))) 452 | 453 | (defn get-methods [cenv caller class name] 454 | (let [class-name (type->symbol class) 455 | name' (munge name)] 456 | (letfn [(method->map [^Class c ^Method m] 457 | (let [access (modifiers->access-flags (.getModifiers m))] 458 | (when (accessible-from? cenv caller (class->type c) access) 459 | {:class (class->type (.getDeclaringClass m)) 460 | :interface? (.isInterface c) 461 | :param-types (mapv class->type (.getParameterTypes m)) 462 | :return-type (class->type (.getReturnType m)) 463 | :access (cond-> access (.isVarArgs m) (conj :varargs))}))) 464 | (walk [^Class c] 465 | (walk-class-hierarchy c 466 | (fn [^Class c] 467 | (keep (fn [^Method m] 468 | (when (= (.getName m) name') 469 | (method->map c m))) 470 | (.getDeclaredMethods c)))))] 471 | (->> (if-let [entry (get-in cenv [:classes class-name])] 472 | (concat (->> (get-in entry [:methods name]) 473 | (keep (fn [{:keys [access] :as m}] 474 | (when (accessible-from? cenv caller class access) 475 | (assoc m :class class))))) 476 | (mapcat (comp walk (partial type->class cenv)) (:interfaces entry)) 477 | (walk (type->class cenv (:parent entry)))) 478 | (let [c (type->class cenv class)] 479 | (cond-> (walk c) (.isInterface c) (concat (walk Object))))) 480 | (remove-overridden-methods cenv))))) 481 | 482 | (defn- convert-arg-types-with [f param-types arg-types throws-on-failure?] 483 | (let [fail (if throws-on-failure? 484 | #(->> {:arg-type %1 :param-type %2} 485 | (ex-info "arg type mismatch") 486 | (throw)) 487 | (fn [_ _] (reduced nil)))] 488 | (->> (map vector arg-types param-types) 489 | (reduce (fn [acc [at pt]] 490 | (if-let [cs (f at pt)] 491 | (conj acc cs) 492 | (fail at pt))) 493 | [])))) 494 | 495 | (defn strict-invocation-conversion 496 | [cenv arg-types method & {:keys [throws-on-failure?] :or {throws-on-failure? true}}] 497 | (letfn [(f [from to] 498 | (if (= from to) 499 | [] 500 | (when-let [c (or (widening-primitive-conversion from to) 501 | (widening-reference-conversion cenv from to))] 502 | [c])))] 503 | (when-let [cs (convert-arg-types-with f (:param-types method) arg-types 504 | throws-on-failure?)] 505 | (assoc method :conversions cs)))) 506 | 507 | (defn loose-invocation-conversion 508 | [cenv arg-types method & {:keys [throws-on-failure?] :or {throws-on-failure? true}}] 509 | (when-let [cs (convert-arg-types-with (partial assignment-conversion cenv) 510 | (:param-types method) 511 | arg-types 512 | throws-on-failure?)] 513 | (assoc method :conversions cs))) 514 | 515 | (defn variable-arity-invocation-conversion 516 | [cenv arg-types {:keys [param-types] :as method} 517 | & {:keys [throws-on-failure?] :or {throws-on-failure? true}}] 518 | (let [required-param-types (butlast param-types) 519 | vararg-type (last param-types)] 520 | (when-let [cs (convert-arg-types-with (partial assignment-conversion cenv) 521 | required-param-types 522 | arg-types 523 | throws-on-failure?)] 524 | (let [nargs (count arg-types) 525 | nparams (count param-types)] 526 | (or (when-let [cs' (if (< nargs nparams) 527 | [] 528 | (when-let [cs (and (= nargs nparams) 529 | (assignment-conversion cenv (last arg-types) vararg-type))] 530 | [cs]))] 531 | (assoc method :conversions (into cs cs'))) 532 | (when (convert-arg-types-with (partial assignment-conversion cenv) 533 | (repeat (element-type vararg-type)) 534 | (drop (dec nparams) arg-types) 535 | throws-on-failure?) 536 | (assoc method :conversions cs))))))) 537 | 538 | (defn- maximally-specific-methods [cenv methods] 539 | (for [[i m1] (map-indexed vector methods) 540 | :when (not-any? (fn [[j m2]] 541 | (when-not (= i j) 542 | (->> (map vector (:param-types m1) (:param-types m2)) 543 | (every? (fn [[p1 p2]] (super? cenv p1 p2)))))) 544 | (map-indexed vector methods))] 545 | m1)) 546 | 547 | (defn- filter-methods [cenv arg-types methods] 548 | (let [{fixed-ms false, variable-ms true} (group-by #(boolean (:varargs (:access %))) methods) 549 | filter-with (fn [f ms] 550 | (->> ms 551 | (keep #(f cenv arg-types % :throws-on-failure? false)) 552 | seq))] 553 | (some->> (or (filter-with strict-invocation-conversion fixed-ms) 554 | (filter-with loose-invocation-conversion fixed-ms) 555 | (filter-with variable-arity-invocation-conversion variable-ms)) 556 | (maximally-specific-methods cenv)))) 557 | 558 | (defn- ensure-not-empty 559 | ([cause message methods] 560 | (ensure-not-empty cause message {} methods)) 561 | ([cause message info methods] 562 | (when (empty? methods) 563 | (throw (ex-info message (assoc info :cause cause)))) 564 | methods)) 565 | 566 | (defn find-methods 567 | ([caller class name arg-types] 568 | (find-methods {} caller class name arg-types)) 569 | ([cenv caller class name arg-types 570 | & {:keys [throws-on-failure?] :or {throws-on-failure? true}}] 571 | (let [nargs (count arg-types) 572 | ensure-not-empty (if throws-on-failure? ensure-not-empty #(last %&))] 573 | (as-> (get-methods cenv caller class name) ms 574 | (ensure-not-empty :no-such-target "no such method" ms) 575 | (->> (filter (fn [{:keys [param-types access]}] 576 | (params-compatible? nargs (count param-types) (:varargs access))) 577 | ms) 578 | (ensure-not-empty :args-length-mismatch "args length mismatch" {:alternatives ms})) 579 | (->> (filter-methods cenv arg-types ms) 580 | (ensure-not-empty :arg-type-mismatch "arg type mismatch" {:alternatives ms})) 581 | (seq ms))))) 582 | 583 | (defn get-ctors [cenv caller class] 584 | (let [class-name (type->symbol class)] 585 | (or (->> (get-in cenv [:classes class-name :ctors]) 586 | (filter (fn [{:keys [access]}] 587 | (accessible-from? cenv caller class access))) 588 | seq) 589 | (->> (.getDeclaredConstructors (type->class cenv class)) 590 | (keep (fn [^Constructor ctor] 591 | (let [access (modifiers->access-flags (.getModifiers ctor)) 592 | varargs? (.isVarArgs ctor)] 593 | (when (accessible-from? cenv caller class access) 594 | {:param-types (mapv class->type (.getParameterTypes ctor)) 595 | :access (cond-> access varargs? (conj :varargs))})))) 596 | seq)))) 597 | 598 | (defn find-ctors 599 | ([caller class arg-types] 600 | (find-ctors {} caller class arg-types)) 601 | ([cenv caller class arg-types 602 | & {:keys [throws-on-failure?] :or {throws-on-failure? true}}] 603 | (let [nargs (count arg-types)] 604 | (as-> (get-ctors cenv caller class) ms 605 | (ensure-not-empty :no-such-target "no such ctor" ms) 606 | (->> (filter (fn [{:keys [param-types access]}] 607 | (params-compatible? nargs (count param-types) (:varargs access))) 608 | ms) 609 | (ensure-not-empty :args-length-mismatch "args length mismatch" {:alternatives ms})) 610 | (->> (filter-methods cenv arg-types ms) 611 | (ensure-not-empty :arg-type-mismatch "arg type mismatch" {:alternatives ms})) 612 | (seq ms))))) 613 | -------------------------------------------------------------------------------- /src/jise/emit.clj: -------------------------------------------------------------------------------- 1 | (ns jise.emit 2 | (:require [jise.insns :as insns] 3 | [jise.parse] 4 | [jise.type :as t]) 5 | (:import [clojure.asm AnnotationVisitor ClassVisitor ClassWriter Label MethodVisitor Opcodes Type] 6 | [clojure.lang Compiler DynamicClassLoader] 7 | [java.lang.annotation RetentionPolicy] 8 | [jise.parse AnnotationRecord])) 9 | 10 | (set! *warn-on-reflection* true) 11 | 12 | (defn- make-emitter [mv debug?] 13 | {:mv mv 14 | :continue-label nil 15 | :break-label nil 16 | :labels {} 17 | :debug? debug?}) 18 | 19 | (defn access-value [flags] 20 | (let [attrs {:abstract Opcodes/ACC_ABSTRACT 21 | :final Opcodes/ACC_FINAL 22 | :private Opcodes/ACC_PRIVATE 23 | :protected Opcodes/ACC_PROTECTED 24 | :public Opcodes/ACC_PUBLIC 25 | :static Opcodes/ACC_STATIC 26 | :synchronized Opcodes/ACC_SYNCHRONIZED 27 | :transient Opcodes/ACC_TRANSIENT 28 | :varargs Opcodes/ACC_VARARGS 29 | :volatile Opcodes/ACC_VOLATILE}] 30 | (apply + (keep attrs flags)))) 31 | 32 | (defn- emit-annotation [^AnnotationVisitor av values] 33 | (doseq [[name value] values] 34 | (cond (vector? value) 35 | (let [av' (.visitArray av name)] 36 | (doseq [v value] 37 | (emit-annotation av' v)) 38 | (.visitEnd av')) 39 | 40 | (instance? AnnotationRecord value) 41 | (let [av' (.visitAnnotation av name (.getDescriptor ^Type (:type value)))] 42 | (emit-annotation av' (:values value)) 43 | (.visitEnd av')) 44 | 45 | :else (.visit av name value)))) 46 | 47 | (defn emit-annotations [visitor-fn annotations] 48 | (doseq [{:keys [retention values] :as ann} annotations 49 | :when (not= retention RetentionPolicy/SOURCE)] 50 | (let [^AnnotationVisitor av (visitor-fn ann)] 51 | (emit-annotation av values) 52 | (.visitEnd av)))) 53 | 54 | (defn- emit-field [^ClassWriter cw {:keys [access name annotations type value]}] 55 | (let [access (access-value access) 56 | desc (.getDescriptor ^Type type) 57 | value' (when value 58 | ((get {t/BYTE byte t/SHORT short t/INT int 59 | t/LONG long t/FLOAT float t/DOUBLE double} 60 | type 61 | identity) 62 | value)) 63 | fv (.visitField cw access (munge name) desc nil value')] 64 | (emit-annotations (fn [{:keys [^Type type retention]}] 65 | (.visitAnnotation fv (.getDescriptor type) 66 | (= retention RetentionPolicy/RUNTIME))) 67 | annotations) 68 | (.visitEnd fv))) 69 | 70 | (defmulti emit-expr* (fn [emitter expr] (:op expr))) 71 | (defmethod emit-expr* :default [_ expr] 72 | (throw (ex-info (str "unknown expr found: " expr) {:expr expr}))) 73 | 74 | (defn- emit-line [{:keys [^MethodVisitor mv]} line] 75 | (when line 76 | (let [here (Label.)] 77 | (.visitLabel mv here) 78 | (.visitLineNumber mv line here)))) 79 | 80 | (defn- emit-return [{:keys [^MethodVisitor mv]} ^Type type] 81 | (.visitInsn mv (.getOpcode type Opcodes/IRETURN))) 82 | 83 | (defn emit-expr [{:keys [^MethodVisitor mv] :as emitter} {:keys [context] :as expr}] 84 | (emit-expr* emitter expr) 85 | (when (:return context) 86 | (let [t (if (:expression context) 87 | (or (:type expr) t/OBJECT) 88 | t/VOID)] 89 | (emit-return emitter t)))) 90 | 91 | (defn- emit-ctor-invocation 92 | [{:keys [^MethodVisitor mv] :as emitter} {:keys [ctor args line]}] 93 | (let [{:keys [class param-types]} ctor 94 | method-type (Type/getMethodType t/VOID (into-array Type param-types)) 95 | iname (.getInternalName ^Type class) 96 | desc (.getDescriptor ^Type method-type)] 97 | (doseq [arg args] 98 | (emit-expr emitter arg)) 99 | (emit-line emitter line) 100 | (.visitMethodInsn mv Opcodes/INVOKESPECIAL iname "" desc false))) 101 | 102 | (defn- emit-local-name [emitter {:keys [name ^Type type index]} start-label end-label] 103 | (when (:debug? emitter) 104 | (.visitLocalVariable ^MethodVisitor (:mv emitter) name (.getDescriptor type) nil 105 | start-label end-label index))) 106 | 107 | (defn- emit-method 108 | [^ClassWriter cw parent debug? 109 | {:keys [name annotations access return-type exceptions args body static-initializer? ctor? varargs?]}] 110 | (let [desc (->> (map :type args) 111 | (into-array Type) 112 | (Type/getMethodDescriptor return-type)) 113 | mname (cond static-initializer? "" 114 | ctor? "" 115 | :else (munge name)) 116 | excs (some->> (seq exceptions) 117 | (map #(.getInternalName ^Type %)) 118 | (into-array String)) 119 | mv (.visitMethod cw (access-value (cond-> access varargs? (conj :varargs))) mname desc nil excs) 120 | start-label (Label.) 121 | end-label (Label.) 122 | emitter (make-emitter mv debug?)] 123 | (emit-annotations (fn [{:keys [^Type type retention]}] 124 | (.visitAnnotation mv (.getDescriptor type) (= retention RetentionPolicy/RUNTIME))) 125 | annotations) 126 | (doseq [[i {:keys [name access annotations]}] (map-indexed vector args)] 127 | (.visitParameter mv name (access-value access)) 128 | (emit-annotations (fn [{:keys [^Type type retention]}] 129 | (.visitParameterAnnotation mv i (.getDescriptor type) 130 | (= retention RetentionPolicy/RUNTIME))) 131 | annotations)) 132 | (.visitCode mv) 133 | (.visitLabel mv start-label) 134 | (when-not (:abstract access) 135 | (emit-expr emitter body)) 136 | (.visitLabel mv end-label) 137 | (doseq [arg args] 138 | (emit-local-name emitter arg start-label end-label)) 139 | (.visitMaxs mv 1 1) 140 | (.visitEnd mv))) 141 | 142 | (defn emit-class 143 | [{:keys [source name annotations access parent interfaces static-initializer ctors fields methods]}] 144 | (let [cw (ClassWriter. ClassWriter/COMPUTE_FRAMES) 145 | debug? (true? (some-> (System/getProperty "jise.debug") read-string))] 146 | (.visit cw Opcodes/V1_8 147 | (+ (access-value access) Opcodes/ACC_SUPER) 148 | name 149 | nil 150 | (.getInternalName ^Type parent) 151 | (into-array String (map #(.getInternalName ^Type %) interfaces))) 152 | (emit-annotations (fn [{:keys [^Type type retention]}] 153 | (.visitAnnotation cw (.getDescriptor type) (= retention RetentionPolicy/RUNTIME))) 154 | annotations) 155 | (when source 156 | (.visitSource cw source nil)) 157 | (doseq [field fields] 158 | (emit-field cw field)) 159 | (when static-initializer 160 | (emit-method cw parent debug? static-initializer)) 161 | (doseq [ctor ctors] 162 | (emit-method cw parent debug? ctor)) 163 | (doseq [method methods] 164 | (emit-method cw parent debug? method)) 165 | (.visitEnd cw) 166 | (.toByteArray cw))) 167 | 168 | (defmethod emit-expr* :do [emitter {:keys [exprs]}] 169 | (doseq [expr exprs] 170 | (emit-expr emitter expr))) 171 | 172 | (defn- drop-if-statement [{:keys [^MethodVisitor mv]} context] 173 | (when (:statement context) 174 | (let [opcode (if (= (t/type-category type) 2) 175 | Opcodes/POP2 176 | Opcodes/POP)] 177 | (.visitInsn mv opcode)))) 178 | 179 | (defn- push-null-unless-statement [{:keys [^MethodVisitor mv]} context] 180 | (when-not (:statement context) 181 | (.visitInsn mv Opcodes/ACONST_NULL))) 182 | 183 | (defmethod emit-expr* :null [emitter {:keys [context]}] 184 | (push-null-unless-statement emitter context)) 185 | 186 | (defn- primitive-type [type] 187 | (if (#{t/BYTE t/CHAR t/SHORT} type) t/INT type)) 188 | 189 | (defmethod emit-expr* :literal [{:keys [^MethodVisitor mv]} {:keys [type value context]}] 190 | (when-not (:statement context) 191 | (let [v (condp = type 192 | t/BYTE (unchecked-byte value) 193 | t/SHORT (unchecked-short value) 194 | t/CHAR (unchecked-int value) 195 | t/INT (unchecked-int value) 196 | t/LONG (unchecked-long value) 197 | t/FLOAT (unchecked-float value) 198 | t/DOUBLE (unchecked-double value) 199 | value)] 200 | (if-let [opcode (get-in insns/const-insns [(primitive-type type) v])] 201 | (.visitInsn mv opcode) 202 | (cond (and (#{t/BYTE t/SHORT t/CHAR t/INT} type) 203 | (<= Byte/MIN_VALUE v Byte/MAX_VALUE)) 204 | (.visitIntInsn mv Opcodes/BIPUSH v) 205 | 206 | (and (#{t/SHORT t/INT} type) 207 | (<= Short/MIN_VALUE v Short/MAX_VALUE)) 208 | (.visitIntInsn mv Opcodes/SIPUSH v) 209 | 210 | (and (= type t/CLASS) (t/primitive-type? value)) 211 | (let [owner (.getInternalName ^Type (t/boxed-types value)) 212 | desc (.getDescriptor ^Type t/CLASS)] 213 | (.visitFieldInsn mv Opcodes/GETSTATIC owner "TYPE" desc)) 214 | 215 | :else (.visitLdcInsn mv v)))))) 216 | 217 | (defn- emit-load [{:keys [^MethodVisitor mv]} ^Type type index] 218 | (.visitVarInsn mv (.getOpcode type Opcodes/ILOAD) index)) 219 | 220 | (defmethod emit-expr* :local [emitter {:keys [type local context]}] 221 | (when-not (:statement context) 222 | (emit-load emitter type (:index local)))) 223 | 224 | (defmethod emit-expr* :super [emitter {:keys [type context]}] 225 | (when-not (:statement context) 226 | (emit-load emitter type 0))) 227 | 228 | (defn- emit-arithmetic [{:keys [^MethodVisitor mv] :as emitter} {:keys [type lhs rhs context line]} op] 229 | (let [opcode (.getOpcode ^Type type (get insns/arithmetic-insns op))] 230 | (emit-expr emitter lhs) 231 | (emit-expr emitter rhs) 232 | (emit-line emitter line) 233 | (.visitInsn mv opcode) 234 | (drop-if-statement emitter context))) 235 | 236 | (defmethod emit-expr* :add [emitter expr] 237 | (emit-arithmetic emitter expr :add)) 238 | 239 | (defmethod emit-expr* :sub [emitter expr] 240 | (emit-arithmetic emitter expr :sub)) 241 | 242 | (defmethod emit-expr* :mul [emitter expr] 243 | (emit-arithmetic emitter expr :mul)) 244 | 245 | (defmethod emit-expr* :div [emitter expr] 246 | (emit-arithmetic emitter expr :div)) 247 | 248 | (defmethod emit-expr* :rem [emitter expr] 249 | (emit-arithmetic emitter expr :rem)) 250 | 251 | (defmethod emit-expr* :neg [{:keys [^MethodVisitor mv] :as emitter} {:keys [type operand context line]}] 252 | (emit-expr emitter operand) 253 | (emit-line emitter line) 254 | (.visitInsn mv (.getOpcode ^Type type Opcodes/INEG)) 255 | (drop-if-statement emitter context)) 256 | 257 | (defmethod emit-expr* :bitwise-and [emitter expr] 258 | (emit-arithmetic emitter expr :bitwise-and)) 259 | 260 | (defmethod emit-expr* :bitwise-or [emitter expr] 261 | (emit-arithmetic emitter expr :bitwise-or)) 262 | 263 | (defmethod emit-expr* :bitwise-xor [emitter expr] 264 | (emit-arithmetic emitter expr :bitwise-xor)) 265 | 266 | (defmethod emit-expr* :shift-left [emitter expr] 267 | (emit-arithmetic emitter expr :shift-left)) 268 | 269 | (defmethod emit-expr* :shift-right [emitter expr] 270 | (emit-arithmetic emitter expr :shift-right)) 271 | 272 | (defmethod emit-expr* :logical-shift-right [emitter expr] 273 | (emit-arithmetic emitter expr :logical-shift-right)) 274 | 275 | (defmethod emit-expr* :widening-primitive [{:keys [^MethodVisitor mv] :as emitter} {:keys [type src context]}] 276 | (if (and (= (:op src) :literal) (#{t/LONG t/DOUBLE} type)) 277 | (emit-expr emitter (assoc src :context context :type type)) 278 | (do (emit-expr emitter src) 279 | (when-let [opcode (get-in insns/widening-insns [(:type src) type])] 280 | (.visitInsn mv opcode)) 281 | (drop-if-statement emitter context)))) 282 | 283 | (defmethod emit-expr* :narrowing-primitive [{:keys [^MethodVisitor mv] :as emitter} {:keys [type src context]}] 284 | (if (and (= (:op src) :literal) (#{t/BYTE t/SHORT t/CHAR t/FLOAT} type)) 285 | (emit-expr emitter (assoc src :context context :type type)) 286 | (do (emit-expr emitter src) 287 | (case type 288 | (byte char short) 289 | (do (when-let [opcode (get-in insns/narrowing-insns [(:type src) t/INT])] 290 | (.visitInsn mv opcode)) 291 | (.visitInsn mv (get-in insns/narrowing-insns [t/INT type]))) 292 | (.visitInsn mv (get-in insns/narrowing-insns [(:type src) type]))) 293 | (drop-if-statement emitter context)))) 294 | 295 | (defmethod emit-expr* :boxing [emitter {:keys [type src context]}] 296 | (emit-expr emitter {:op :method-invocation 297 | :context context 298 | :type type 299 | :method {:class type 300 | :access #{:public :static} 301 | :name "valueOf" 302 | :param-types [(:type src)]} 303 | :args [src]})) 304 | 305 | (def ^:private unboxing-method-names 306 | {t/BOOLEAN "booleanValue" 307 | t/BYTE "byteValue" 308 | t/CHAR "charValue" 309 | t/SHORT "shortValue" 310 | t/INT "intValue" 311 | t/LONG "longValue" 312 | t/FLOAT "floatValue" 313 | t/DOUBLE "doubleValue"}) 314 | 315 | (defmethod emit-expr* :unboxing [emitter {:keys [type src context]}] 316 | (emit-expr emitter {:op :method-invocation 317 | :context context 318 | :type type 319 | :method {:class (:type src) 320 | :access #{:public} 321 | :name (unboxing-method-names type) 322 | :param-types []} 323 | :target src 324 | :args []})) 325 | 326 | (defmethod emit-expr* :widening-reference [emitter {:keys [src]}] 327 | (emit-expr emitter src)) 328 | 329 | (defmethod emit-expr* :narrowing-reference [{:keys [^MethodVisitor mv] :as emitter} {:keys [type src context]}] 330 | (emit-expr emitter src) 331 | (.visitTypeInsn mv Opcodes/CHECKCAST (.getInternalName ^Type type)) 332 | (drop-if-statement emitter context)) 333 | 334 | (defmethod emit-expr* :instance? [{:keys [^MethodVisitor mv] :as emitter} {:keys [class operand context line]}] 335 | (emit-expr emitter operand) 336 | (emit-line emitter line) 337 | (.visitTypeInsn mv Opcodes/INSTANCEOF (.getInternalName ^Type class)) 338 | (drop-if-statement emitter context)) 339 | 340 | (defn- emit-store [{:keys [^MethodVisitor mv]} ^Type type index] 341 | (.visitVarInsn mv (.getOpcode type Opcodes/ISTORE) index)) 342 | 343 | (defmethod emit-expr* :let [{:keys [^MethodVisitor mv] :as emitter} {:keys [bindings body line]}] 344 | (let [start-labels (map (fn [_] (Label.)) bindings) 345 | end-label (Label.)] 346 | (emit-line emitter line) 347 | (doseq [[{:keys [init] :as b} start-label] (map vector bindings start-labels)] 348 | (emit-expr emitter init) 349 | (emit-store emitter (:type b) (:index b)) 350 | (.visitLabel mv start-label)) 351 | (emit-expr emitter body) 352 | (.visitLabel mv end-label) 353 | (doseq [[binding start-label] (map vector bindings start-labels)] 354 | (emit-local-name emitter binding start-label end-label)))) 355 | 356 | (defn- emit-dup [{:keys [^MethodVisitor mv]} type] 357 | (let [opcode (case (t/type-category type) 358 | 1 Opcodes/DUP 359 | 2 Opcodes/DUP2)] 360 | (.visitInsn mv opcode))) 361 | 362 | (defn- dup-unless-statement [emitter context type] 363 | (when-not (:statement context) 364 | (emit-dup emitter type))) 365 | 366 | (defmethod emit-expr* :assignment [emitter {:keys [lhs rhs context line]}] 367 | (emit-expr emitter rhs) 368 | (dup-unless-statement emitter context (:type rhs)) 369 | (emit-line emitter line) 370 | (emit-store emitter (:type lhs) (:index (:local lhs)))) 371 | 372 | (defmethod emit-expr* :increment [{:keys [^MethodVisitor mv] :as emitter} {:keys [target by context line]}] 373 | (let [{:keys [type local]} target] 374 | (emit-line emitter line) 375 | (.visitIincInsn mv (:index local) by) 376 | (when-not (:statement context) 377 | (emit-load emitter type (:index local))))) 378 | 379 | (defmethod emit-expr* :labeled [{:keys [^MethodVisitor mv] :as emitter} {:keys [label target kind]}] 380 | (let [break-label (Label.) 381 | emitter' (assoc-in emitter [:labels label] {:break-label break-label})] 382 | (emit-expr emitter' target) 383 | (.visitLabel mv break-label))) 384 | 385 | (defn- emit-comparison [{:keys [^MethodVisitor mv] :as emitter} op {:keys [operand lhs rhs]} label] 386 | (if operand 387 | (let [opcode (get insns/constant-comparison-insns op)] 388 | (emit-expr emitter operand) 389 | (.visitJumpInsn mv opcode label)) 390 | (let [t (:type lhs)] 391 | (emit-expr emitter lhs) 392 | (emit-expr emitter rhs) 393 | (if-let [[opcode1 opcode2] (get-in insns/comparison-insns [t op])] 394 | (if opcode2 395 | (do (.visitInsn mv opcode1) 396 | (.visitJumpInsn mv opcode2 label)) 397 | (.visitJumpInsn mv opcode1 label)) 398 | (let [opcode (case op 399 | :eq Opcodes/IF_ACMPNE 400 | :ne Opcodes/IF_ACMPEQ)] 401 | (.visitJumpInsn mv opcode label)))))) 402 | 403 | (declare emit-conditional) 404 | 405 | (defn- emit-and [emitter {:keys [exprs]} label] 406 | (run! #(emit-conditional emitter % label) exprs)) 407 | 408 | (defn- emit-or [{:keys [^MethodVisitor mv] :as emitter} {:keys [exprs expr]} else-label] 409 | (let [then-label (Label.)] 410 | (run! #(emit-conditional emitter % then-label) exprs) 411 | (emit-conditional emitter expr else-label) 412 | (.visitLabel mv then-label))) 413 | 414 | (def negated-comparison-ops 415 | {:eq :ne, :ne :eq, :lt :ge, :gt :le, :le :gt, :ge :lt 416 | :eq-0 :ne-0, :ne-0 :eq-0, :eq-null :ne-null, :ne-null :eq-null 417 | :lt-0 :ge-0, :gt-0 :le-0, :le-0 :gt-0, :ge-0 :lt-0}) 418 | 419 | (defn- emit-not [{:keys [^MethodVisitor mv] :as emitter} {:keys [expr]} label] 420 | (if-let [negated (negated-comparison-ops (:op expr))] 421 | (emit-comparison emitter negated expr label) 422 | (do (emit-expr emitter expr) 423 | (.visitJumpInsn mv Opcodes/IFNE label)))) 424 | 425 | (defn- emit-conditional [{:keys [^MethodVisitor mv] :as emitter} cond label] 426 | (let [op (:op cond)] 427 | (case op 428 | (:eq :ne :lt :gt :le :ge :eq-null :ne-null :eq-0 :ne-0 :lt-0 :gt-0 :le-0 :ge-0) 429 | (emit-comparison emitter op cond label) 430 | :and 431 | (emit-and emitter cond label) 432 | :or 433 | (emit-or emitter cond label) 434 | :not 435 | (emit-not emitter cond label) 436 | 437 | (do (emit-expr emitter cond) 438 | (.visitJumpInsn mv Opcodes/IFEQ label))))) 439 | 440 | (defmethod emit-expr* :if [{:keys [^MethodVisitor mv] :as emitter} {:keys [test then else line]}] 441 | (let [end-label (Label.) 442 | else-label (if else (Label.) end-label)] 443 | (emit-line emitter line) 444 | (emit-conditional emitter test else-label) 445 | (emit-expr emitter then) 446 | (when else 447 | (when-not (:tail (:context then)) 448 | (.visitJumpInsn mv Opcodes/GOTO end-label)) 449 | (.visitLabel mv else-label) 450 | (emit-expr emitter else)) 451 | (.visitLabel mv end-label))) 452 | 453 | (defn- assign-labels [clauses] 454 | (loop [clauses clauses 455 | key->label {} 456 | ret []] 457 | (if (empty? clauses) 458 | [ret (sort-by first key->label)] 459 | (let [[{:keys [keys] :as clause} & clauses] clauses 460 | label (or (some key->label keys) (Label.))] 461 | (recur clauses 462 | (into key->label (map (fn [k] [k label])) keys) 463 | (conj ret (assoc clause :label label))))))) 464 | 465 | (defn- sequential-min-max-keys [keys] 466 | (let [keys' (into (sorted-set) keys)] 467 | (when (->> keys' 468 | (partition 2 1) 469 | (every? (fn [[k k']] (= (inc k) k')))) 470 | [(first (seq keys')) 471 | (first (rseq keys'))]))) 472 | 473 | (defmethod emit-expr* :switch 474 | [{:keys [^MethodVisitor mv] :as emitter} {:keys [test clauses default]}] 475 | (let [end-label (Label.) 476 | default-label (if default (Label.) end-label) 477 | [clauses' key->label] (assign-labels clauses) 478 | keys (int-array (map first key->label)) 479 | labels (into-array Label (map second key->label))] 480 | (emit-expr emitter test) 481 | (if-let [[min max] (sequential-min-max-keys keys)] 482 | (->> (sort-by key key->label) 483 | (map val) 484 | (into-array Label) 485 | (.visitTableSwitchInsn mv min max default-label)) 486 | (.visitLookupSwitchInsn mv default-label keys labels)) 487 | (doseq [{:keys [label guard body]} clauses'] 488 | (.visitLabel mv label) 489 | (when guard 490 | (emit-conditional emitter guard default-label)) 491 | (emit-expr emitter body) 492 | (when-not (:tail (:context body)) 493 | (.visitJumpInsn mv Opcodes/GOTO end-label))) 494 | (when default 495 | (.visitLabel mv default-label) 496 | (emit-expr emitter default)) 497 | (.visitLabel mv end-label))) 498 | 499 | (defn- with-labels [emitter label-name continue-label break-label f] 500 | (let [emitter' (-> emitter 501 | (assoc :continue-label continue-label :break-label break-label) 502 | (cond-> label-name (assoc-in [:labels label-name :continue-label] continue-label)))] 503 | (f emitter'))) 504 | 505 | (defmethod emit-expr* :while [{:keys [^MethodVisitor mv] :as emitter} {:keys [cond body label context line]}] 506 | (let [start-label (Label.) 507 | end-label (Label.)] 508 | (with-labels emitter label start-label end-label 509 | (fn [emitter'] 510 | (.visitLabel mv start-label) 511 | (emit-line emitter' line) 512 | (when-not (and (= (:op cond) :literal) (true? (:value cond))) 513 | (emit-conditional emitter' cond end-label)) 514 | (emit-expr emitter' body) 515 | (.visitJumpInsn mv Opcodes/GOTO start-label) 516 | (.visitLabel mv end-label))) 517 | (push-null-unless-statement emitter context))) 518 | 519 | (defmethod emit-expr* :for [{:keys [^MethodVisitor mv] :as emitter} {:keys [cond step body label context]}] 520 | (let [start-label (Label.) 521 | continue-label (Label.) 522 | end-label (Label.)] 523 | (with-labels emitter label continue-label end-label 524 | (fn [emitter'] 525 | (.visitLabel mv start-label) 526 | (when-not (and (= (:op cond) :literal) (true? (:value cond))) 527 | (emit-conditional emitter' cond end-label)) 528 | (emit-expr emitter' body) 529 | (.visitLabel mv continue-label) 530 | (emit-expr emitter' step) 531 | (.visitJumpInsn mv Opcodes/GOTO start-label) 532 | (.visitLabel mv end-label))) 533 | (push-null-unless-statement emitter context))) 534 | 535 | (defmethod emit-expr* :try 536 | [{:keys [^MethodVisitor mv] :as emitter} {:keys [type body catch-clauses finally-clause]}] 537 | (let [body-start-label (Label.) 538 | body-end-label (Label.) 539 | try-end-label (Label.) 540 | default-clause-label (when finally-clause (Label.)) 541 | catch-clauses' (map #(assoc % :start-label (Label.) :end-label (Label.)) catch-clauses)] 542 | (.visitLabel mv body-start-label) 543 | (emit-expr emitter body) 544 | (.visitLabel mv body-end-label) 545 | (when finally-clause 546 | (emit-expr emitter finally-clause)) 547 | (.visitJumpInsn mv Opcodes/GOTO try-end-label) 548 | (doseq [[{:keys [start-label end-label local body]} more] (partition-all 2 1 catch-clauses') 549 | :let [label (Label.)]] 550 | (.visitLabel mv start-label) 551 | (emit-store emitter (or (:type local) t/THROWABLE) (:index local)) 552 | (.visitLabel mv label) 553 | (emit-expr emitter body) 554 | (.visitLabel mv end-label) 555 | (emit-local-name emitter local label end-label) 556 | (when finally-clause 557 | (emit-expr emitter finally-clause)) 558 | (when (or finally-clause more) 559 | (.visitJumpInsn mv Opcodes/GOTO try-end-label))) 560 | (when finally-clause 561 | (.visitLabel mv default-clause-label) 562 | (emit-expr emitter finally-clause) 563 | (.visitInsn mv Opcodes/ATHROW)) 564 | (.visitLabel mv try-end-label) 565 | (doseq [{:keys [start-label local]} catch-clauses' 566 | :let [iname (.getInternalName ^Type (:type local))]] 567 | (.visitTryCatchBlock mv body-start-label body-end-label start-label iname)) 568 | (when finally-clause 569 | (.visitTryCatchBlock mv body-start-label body-end-label default-clause-label nil) 570 | (doseq [{:keys [start-label end-label]} catch-clauses'] 571 | (.visitTryCatchBlock mv start-label end-label default-clause-label nil))))) 572 | 573 | (defmethod emit-expr* :continue [{:keys [^MethodVisitor mv] :as emitter} {:keys [label]}] 574 | (let [^Label label (if label 575 | (get-in emitter [:labels label :continue-label]) 576 | (:continue-label emitter))] 577 | (.visitJumpInsn mv Opcodes/GOTO label))) 578 | 579 | (defmethod emit-expr* :break [{:keys [^MethodVisitor mv] :as emitter} {:keys [label]}] 580 | (let [^Label label (if label 581 | (get-in emitter [:labels label :break-label]) 582 | (:break-label emitter))] 583 | (.visitJumpInsn mv Opcodes/GOTO label))) 584 | 585 | (defmethod emit-expr* :return [emitter {:keys [type value]}] 586 | (when-not (= type t/VOID) 587 | (emit-expr emitter value))) 588 | 589 | (defmethod emit-expr* :throw [{:keys [^MethodVisitor mv] :as emitter} {:keys [exception]}] 590 | (emit-expr emitter exception) 591 | (.visitInsn mv Opcodes/ATHROW)) 592 | 593 | (defmethod emit-expr* :new [{:keys [^MethodVisitor mv] :as emitter} {:keys [type context] :as expr}] 594 | (.visitTypeInsn mv Opcodes/NEW (.getInternalName ^Type type)) 595 | (dup-unless-statement emitter context type) 596 | (emit-ctor-invocation emitter expr)) 597 | 598 | (defmethod emit-expr* :field-access 599 | [{:keys [^MethodVisitor mv] :as emitter} {:keys [type field target context line]}] 600 | (let [static? (:static (:access field)) 601 | opcode (if static? Opcodes/GETSTATIC Opcodes/GETFIELD) 602 | owner (.getInternalName ^Type (:class field)) 603 | desc (.getDescriptor ^Type type)] 604 | (when-not static? 605 | (emit-expr emitter target)) 606 | (emit-line emitter line) 607 | (.visitFieldInsn mv opcode owner (munge (:name field)) desc) 608 | (drop-if-statement emitter context))) 609 | 610 | (defmethod emit-expr* :field-update 611 | [{:keys [^MethodVisitor mv] :as emitter} {:keys [type field target rhs context line]}] 612 | (let [static? (:static (:access field)) 613 | opcode (if static? Opcodes/PUTSTATIC Opcodes/PUTFIELD) 614 | owner (.getInternalName ^Type (:class field)) 615 | desc (.getDescriptor ^Type type)] 616 | (when-not static? 617 | (emit-expr emitter target)) 618 | (emit-expr emitter rhs) 619 | (when-not (:statement context) 620 | (let [t (:type rhs)] 621 | (if static? 622 | (dup-unless-statement emitter context t) 623 | (let [opcode (if (= (t/type-category t) 2) Opcodes/DUP_X2 Opcodes/DUP_X1)] 624 | (.visitInsn mv opcode))))) 625 | (emit-line emitter line) 626 | (.visitFieldInsn mv opcode owner (munge (:name field)) desc))) 627 | 628 | (defmethod emit-expr* :ctor-invocation [emitter {:keys [ctor] :as expr}] 629 | (emit-load emitter (:class ctor) 0) 630 | (emit-ctor-invocation emitter expr)) 631 | 632 | (defmethod emit-expr* :method-invocation 633 | [{:keys [^MethodVisitor mv] :as emitter} 634 | {:keys [type method super? target args context line]}] 635 | (let [{:keys [interface? class name access param-types]} method 636 | static? (:static access) 637 | method-type (Type/getMethodType ^Type type (into-array Type param-types)) 638 | opcode (cond static? Opcodes/INVOKESTATIC 639 | interface? Opcodes/INVOKEINTERFACE 640 | (or (:private access) super?) Opcodes/INVOKESPECIAL 641 | :else Opcodes/INVOKEVIRTUAL) 642 | iname (.getInternalName ^Type class) 643 | desc (.getDescriptor method-type)] 644 | (when-not static? 645 | (emit-expr emitter target)) 646 | (doseq [arg args] 647 | (emit-expr emitter arg)) 648 | (emit-line emitter line) 649 | (.visitMethodInsn mv opcode iname (munge name) desc (boolean interface?)) 650 | (if (= type t/VOID) 651 | (push-null-unless-statement emitter context) 652 | (drop-if-statement emitter context)))) 653 | 654 | (def ^:private primitive-types 655 | {t/BOOLEAN Opcodes/T_BOOLEAN 656 | t/BYTE Opcodes/T_BYTE 657 | t/CHAR Opcodes/T_CHAR 658 | t/SHORT Opcodes/T_SHORT 659 | t/INT Opcodes/T_INT 660 | t/LONG Opcodes/T_LONG 661 | t/FLOAT Opcodes/T_FLOAT 662 | t/DOUBLE Opcodes/T_DOUBLE}) 663 | 664 | (defmethod emit-expr* :new-array 665 | [{:keys [^MethodVisitor mv] :as emitter} {:keys [type dims elements context line]}] 666 | (let [dim (count dims)] 667 | (run! (partial emit-expr emitter) dims) 668 | (emit-line emitter line) 669 | (if (> dim 1) 670 | (.visitMultiANewArrayInsn mv (.getDescriptor ^Type type) dim) 671 | (let [elem-type (t/element-type type)] 672 | (if (t/primitive-type? elem-type) 673 | (let [t (primitive-types elem-type)] 674 | (.visitIntInsn mv Opcodes/NEWARRAY t)) 675 | (.visitTypeInsn mv Opcodes/ANEWARRAY (.getInternalName elem-type))) 676 | (when elements 677 | (doseq [[i elem] (map-indexed vector elements)] 678 | (emit-dup emitter type) 679 | (emit-expr emitter {:op :literal :value i :type t/INT :context #{:expression}}) 680 | (emit-expr emitter elem) 681 | (.visitInsn mv (.getOpcode elem-type Opcodes/IASTORE)))))) 682 | (drop-if-statement emitter context))) 683 | 684 | (defmethod emit-expr* :array-length [{:keys [^MethodVisitor mv] :as emitter} {:keys [array context line]}] 685 | (emit-expr emitter array) 686 | (emit-line emitter line) 687 | (.visitInsn mv Opcodes/ARRAYLENGTH) 688 | (drop-if-statement emitter context)) 689 | 690 | (defmethod emit-expr* :array-access [{:keys [^MethodVisitor mv] :as emitter} {:keys [array index context line]}] 691 | (emit-expr emitter array) 692 | (emit-expr emitter index) 693 | (emit-line emitter line) 694 | (let [elem-type (t/element-type (:type array))] 695 | (.visitInsn mv (.getOpcode elem-type Opcodes/IALOAD)) 696 | (drop-if-statement emitter context))) 697 | 698 | (defmethod emit-expr* :array-update 699 | [{:keys [^MethodVisitor mv] :as emitter} {:keys [array index expr context line]}] 700 | (let [elem-type (t/element-type (:type array))] 701 | (emit-expr emitter array) 702 | (emit-expr emitter index) 703 | (emit-expr emitter expr) 704 | (when-not (:statement context) 705 | (let [opcode (case (t/type-category elem-type) 706 | 1 Opcodes/DUP_X2 707 | 2 Opcodes/DUP2_X2)] 708 | (.visitInsn mv opcode))) 709 | (emit-line emitter line) 710 | (.visitInsn mv (.getOpcode elem-type Opcodes/IASTORE)))) 711 | --------------------------------------------------------------------------------