Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

file 722 lines (638 sloc) 32.066 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(in-ns 'clojure.core)

(import '(java.lang.reflect Modifier Constructor)
        '(clojure.asm ClassWriter ClassVisitor Opcodes Type)
        '(clojure.asm.commons Method GeneratorAdapter)
        '(clojure.lang IPersistentMap))

;(defn method-sig [^java.lang.reflect.Method meth]
; [(. meth (getName)) (seq (. meth (getParameterTypes)))])

(defn- non-private-methods [^Class c]
  (loop [mm {}
         considered #{}
         c c]
    (if c
      (let [[mm considered]
            (loop [mm mm
                   considered considered
                   meths (seq (concat
                                (seq (. c (getDeclaredMethods)))
                                (seq (. c (getMethods)))))]
              (if meths
                (let [^java.lang.reflect.Method meth (first meths)
                      mods (. meth (getModifiers))
                      mk (method-sig meth)]
                  (if (or (considered mk)
                          (not (or (Modifier/isPublic mods) (Modifier/isProtected mods)))
                          ;(. Modifier (isPrivate mods))
                          (. Modifier (isStatic mods))
                          (. Modifier (isFinal mods))
                          (= "finalize" (.getName meth)))
                    (recur mm (conj considered mk) (next meths))
                    (recur (assoc mm mk meth) (conj considered mk) (next meths))))
                [mm considered]))]
        (recur mm considered (. c (getSuperclass))))
      mm)))

(defn- ctor-sigs [^Class super]
  (for [^Constructor ctor (. super (getDeclaredConstructors))
        :when (not (. Modifier (isPrivate (. ctor (getModifiers)))))]
    (apply vector (. ctor (getParameterTypes)))))

(defn- escape-class-name [^Class c]
  (.. (.getSimpleName c)
      (replace "[]" "<>")))

(defn- overload-name [mname pclasses]
  (if (seq pclasses)
    (apply str mname (interleave (repeat \-)
                                 (map escape-class-name pclasses)))
    (str mname "-void")))

(defn- ^java.lang.reflect.Field find-field [^Class c f]
  (let [start-class c]
    (loop [c c]
      (if (= c Object)
        (throw (new Exception (str "field, " f ", not defined in class, " start-class ", or its ancestors")))
        (let [dflds (.getDeclaredFields c)
              rfld (first (filter #(= f (.getName ^java.lang.reflect.Field %)) dflds))]
          (or rfld (recur (.getSuperclass c))))))))

;(distinct (map first(keys (mapcat non-private-methods [Object IPersistentMap]))))

(def ^{:private true} prim->class
     {'int Integer/TYPE
      'ints (Class/forName "[I")
      'long Long/TYPE
      'longs (Class/forName "[J")
      'float Float/TYPE
      'floats (Class/forName "[F")
      'double Double/TYPE
      'doubles (Class/forName "[D")
      'void Void/TYPE
      'short Short/TYPE
      'shorts (Class/forName "[S")
      'boolean Boolean/TYPE
      'booleans (Class/forName "[Z")
      'byte Byte/TYPE
      'bytes (Class/forName "[B")
      'char Character/TYPE
      'chars (Class/forName "[C")})

(defn- ^Class the-class [x]
  (cond
   (class? x) x
   (contains? prim->class x) (prim->class x)
   :else (let [strx (str x)]
           (clojure.lang.RT/classForName
            (if (some #{\. \[} strx)
              strx
              (str "java.lang." strx))))))

;; someday this can be made codepoint aware
(defn- valid-java-method-name
  [^String s]
  (= s (clojure.lang.Compiler/munge s)))

(defn- validate-generate-class-options
  [{:keys [methods]}]
  (let [[mname] (remove valid-java-method-name (map (comp str first) methods))]
    (when mname (throw (IllegalArgumentException. (str "Not a valid method name: " mname))))))

(defn- generate-class [options-map]
  (validate-generate-class-options options-map)
  (let [default-options {:prefix "-" :load-impl-ns true :impl-ns (ns-name *ns*)}
        {:keys [name extends implements constructors methods main factory state init exposes
                exposes-methods prefix load-impl-ns impl-ns post-init]}
          (merge default-options options-map)
        name-meta (meta name)
        name (str name)
        super (if extends (the-class extends) Object)
        interfaces (map the-class implements)
        supers (cons super interfaces)
        ctor-sig-map (or constructors (zipmap (ctor-sigs super) (ctor-sigs super)))
        cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
        cname (. name (replace "." "/"))
        pkg-name name
        impl-pkg-name (str impl-ns)
        impl-cname (.. impl-pkg-name (replace "." "/") (replace \- \_))
        ctype (. Type (getObjectType cname))
        iname (fn [^Class c] (.. Type (getType c) (getInternalName)))
        totype (fn [^Class c] (. Type (getType c)))
        to-types (fn [cs] (if (pos? (count cs))
                            (into-array (map totype cs))
                            (make-array Type 0)))
        obj-type ^Type (totype Object)
        arg-types (fn [n] (if (pos? n)
                            (into-array (replicate n obj-type))
                            (make-array Type 0)))
        super-type ^Type (totype super)
        init-name (str init)
        post-init-name (str post-init)
        factory-name (str factory)
        state-name (str state)
        main-name "main"
        var-name (fn [s] (clojure.lang.Compiler/munge (str s "__var")))
        class-type (totype Class)
        rt-type (totype clojure.lang.RT)
        var-type ^Type (totype clojure.lang.Var)
        ifn-type (totype clojure.lang.IFn)
        iseq-type (totype clojure.lang.ISeq)
        ex-type (totype java.lang.UnsupportedOperationException)
        all-sigs (distinct (concat (map #(let[[m p] (key %)] {m [p]}) (mapcat non-private-methods supers))
                                   (map (fn [[m p]] {(str m) [p]}) methods)))
        sigs-by-name (apply merge-with concat {} all-sigs)
        overloads (into1 {} (filter (fn [[m s]] (next s)) sigs-by-name))
        var-fields (concat (when init [init-name])
                           (when post-init [post-init-name])
                           (when main [main-name])
                           ;(when exposes-methods (map str (vals exposes-methods)))
                           (distinct (concat (keys sigs-by-name)
                                             (mapcat (fn [[m s]] (map #(overload-name m (map the-class %)) s)) overloads)
                                             (mapcat (comp (partial map str) vals val) exposes))))
        emit-get-var (fn [^GeneratorAdapter gen v]
                       (let [false-label (. gen newLabel)
                             end-label (. gen newLabel)]
                         (. gen getStatic ctype (var-name v) var-type)
                         (. gen dup)
                         (. gen invokeVirtual var-type (. Method (getMethod "boolean isBound()")))
                         (. gen ifZCmp (. GeneratorAdapter EQ) false-label)
                         (. gen invokeVirtual var-type (. Method (getMethod "Object get()")))
                         (. gen goTo end-label)
                         (. gen mark false-label)
                         (. gen pop)
                         (. gen visitInsn (. Opcodes ACONST_NULL))
                         (. gen mark end-label)))
        emit-unsupported (fn [^GeneratorAdapter gen ^Method m]
                           (. gen (throwException ex-type (str (. m (getName)) " ("
                                                               impl-pkg-name "/" prefix (.getName m)
                                                               " not defined?)"))))
        emit-forwarding-method
        (fn [name pclasses rclass as-static else-gen]
          (let [mname (str name)
                pmetas (map meta pclasses)
                pclasses (map the-class pclasses)
                rclass (the-class rclass)
                ptypes (to-types pclasses)
                rtype ^Type (totype rclass)
                m (new Method mname rtype ptypes)
                is-overload (seq (overloads mname))
                gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (if as-static (. Opcodes ACC_STATIC) 0))
                         m nil nil cv)
                found-label (. gen (newLabel))
                else-label (. gen (newLabel))
                end-label (. gen (newLabel))]
            (add-annotations gen (meta name))
            (dotimes [i (count pmetas)]
              (add-annotations gen (nth pmetas i) i))
            (. gen (visitCode))
            (if (> (count pclasses) 18)
              (else-gen gen m)
              (do
                (when is-overload
                  (emit-get-var gen (overload-name mname pclasses))
                  (. gen (dup))
                  (. gen (ifNonNull found-label))
                  (. gen (pop)))
                (emit-get-var gen mname)
                (. gen (dup))
                (. gen (ifNull else-label))
                (when is-overload
                  (. gen (mark found-label)))
                                        ;if found
                (.checkCast gen ifn-type)
                (when-not as-static
                  (. gen (loadThis)))
                                        ;box args
                (dotimes [i (count ptypes)]
                  (. gen (loadArg i))
                  (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
                                        ;call fn
                (. gen (invokeInterface ifn-type (new Method "invoke" obj-type
                                                      (to-types (replicate (+ (count ptypes)
                                                                              (if as-static 0 1))
                                                                           Object)))))
                                        ;(into-array (cons obj-type
                                        ; (replicate (count ptypes) obj-type))))))
                                        ;unbox return
                (. gen (unbox rtype))
                (when (= (. rtype (getSort)) (. Type VOID))
                  (. gen (pop)))
                (. gen (goTo end-label))
                
                                        ;else call supplied alternative generator
                (. gen (mark else-label))
                (. gen (pop))
                
                (else-gen gen m)
            
                (. gen (mark end-label))))
            (. gen (returnValue))
            (. gen (endMethod))))
        ]
                                        ;start class definition
    (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))
                 cname nil (iname super)
                 (when-let [ifc (seq interfaces)]
                   (into-array (map iname ifc)))))

                                        ; class annotations
    (add-annotations cv name-meta)
    
                                        ;static fields for vars
    (doseq [v var-fields]
      (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_FINAL) (. Opcodes ACC_STATIC))
                        (var-name v)
                        (. var-type getDescriptor)
                        nil nil)))
    
                                        ;instance field for state
    (when state
      (. cv (visitField (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_FINAL))
                        state-name
                        (. obj-type getDescriptor)
                        nil nil)))
    
                                        ;static init to set up var fields and load init
    (let [gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
                   (. Method getMethod "void <clinit> ()")
                   nil nil cv)]
      (. gen (visitCode))
      (doseq [v var-fields]
        (. gen push impl-pkg-name)
        (. gen push (str prefix v))
        (. gen (invokeStatic var-type (. Method (getMethod "clojure.lang.Var internPrivate(String,String)"))))
        (. gen putStatic ctype (var-name v) var-type))
      
      (when load-impl-ns
        (. gen push "clojure.core")
        (. gen push "load")
        (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.Var var(String,String)"))))
        (. gen push (str "/" impl-cname))
        (. gen (invokeInterface ifn-type (new Method "invoke" obj-type (to-types [Object]))))
; (. gen push (str (.replace impl-pkg-name \- \_) "__init"))
; (. gen (invokeStatic class-type (. Method (getMethod "Class forName(String)"))))
        (. gen pop))

      (. gen (returnValue))
      (. gen (endMethod)))
    
                                        ;ctors
    (doseq [[pclasses super-pclasses] ctor-sig-map]
      (let [pclasses (map the-class pclasses)
            super-pclasses (map the-class super-pclasses)
            ptypes (to-types pclasses)
            super-ptypes (to-types super-pclasses)
            m (new Method "<init>" (. Type VOID_TYPE) ptypes)
            super-m (new Method "<init>" (. Type VOID_TYPE) super-ptypes)
            gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
            no-init-label (. gen newLabel)
            end-label (. gen newLabel)
            no-post-init-label (. gen newLabel)
            end-post-init-label (. gen newLabel)
            nth-method (. Method (getMethod "Object nth(Object,int)"))
            local (. gen newLocal obj-type)]
        (. gen (visitCode))
        
        (if init
          (do
            (emit-get-var gen init-name)
            (. gen dup)
            (. gen ifNull no-init-label)
            (.checkCast gen ifn-type)
                                        ;box init args
            (dotimes [i (count pclasses)]
              (. gen (loadArg i))
              (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
                                        ;call init fn
            (. gen (invokeInterface ifn-type (new Method "invoke" obj-type
                                                  (arg-types (count ptypes)))))
                                        ;expecting [[super-ctor-args] state] returned
            (. gen dup)
            (. gen push (int 0))
            (. gen (invokeStatic rt-type nth-method))
            (. gen storeLocal local)
            
            (. gen (loadThis))
            (. gen dupX1)
            (dotimes [i (count super-pclasses)]
              (. gen loadLocal local)
              (. gen push (int i))
              (. gen (invokeStatic rt-type nth-method))
              (. clojure.lang.Compiler$HostExpr (emitUnboxArg nil gen (nth super-pclasses i))))
            (. gen (invokeConstructor super-type super-m))
            
            (if state
              (do
                (. gen push (int 1))
                (. gen (invokeStatic rt-type nth-method))
                (. gen (putField ctype state-name obj-type)))
              (. gen pop))
            
            (. gen goTo end-label)
                                        ;no init found
            (. gen mark no-init-label)
            (. gen (throwException ex-type (str impl-pkg-name "/" prefix init-name " not defined")))
            (. gen mark end-label))
          (if (= pclasses super-pclasses)
            (do
              (. gen (loadThis))
              (. gen (loadArgs))
              (. gen (invokeConstructor super-type super-m)))
            (throw (new Exception ":init not specified, but ctor and super ctor args differ"))))

        (when post-init
          (emit-get-var gen post-init-name)
          (. gen dup)
          (. gen ifNull no-post-init-label)
          (.checkCast gen ifn-type)
          (. gen (loadThis))
                                       ;box init args
          (dotimes [i (count pclasses)]
            (. gen (loadArg i))
            (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
                                       ;call init fn
          (. gen (invokeInterface ifn-type (new Method "invoke" obj-type
                                                (arg-types (inc (count ptypes))))))
          (. gen pop)
          (. gen goTo end-post-init-label)
                                       ;no init found
          (. gen mark no-post-init-label)
          (. gen (throwException ex-type (str impl-pkg-name "/" prefix post-init-name " not defined")))
          (. gen mark end-post-init-label))

        (. gen (returnValue))
        (. gen (endMethod))
                                        ;factory
        (when factory
          (let [fm (new Method factory-name ctype ptypes)
                gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
                         fm nil nil cv)]
            (. gen (visitCode))
            (. gen newInstance ctype)
            (. gen dup)
            (. gen (loadArgs))
            (. gen (invokeConstructor ctype m))
            (. gen (returnValue))
            (. gen (endMethod))))))
    
                                        ;add methods matching supers', if no fn -> call super
    (let [mm (non-private-methods super)]
      (doseq [^java.lang.reflect.Method meth (vals mm)]
             (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false
                                     (fn [^GeneratorAdapter gen ^Method m]
                                       (. gen (loadThis))
                                        ;push args
                                       (. gen (loadArgs))
                                        ;call super
                                       (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL)
                                                               (. super-type (getInternalName))
                                                               (. m (getName))
                                                               (. m (getDescriptor)))))))
                                        ;add methods matching interfaces', if no fn -> throw
      (reduce1 (fn [mm ^java.lang.reflect.Method meth]
                (if (contains? mm (method-sig meth))
                  mm
                  (do
                    (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false
                                            emit-unsupported)
                    (assoc mm (method-sig meth) meth))))
              mm (mapcat #(.getMethods ^Class %) interfaces))
                                        ;extra methods
       (doseq [[mname pclasses rclass :as msig] methods]
         (emit-forwarding-method mname pclasses rclass (:static (meta msig))
                                 emit-unsupported))
                                        ;expose specified overridden superclass methods
       (doseq [[local-mname ^java.lang.reflect.Method m] (reduce1 (fn [ms [[name _ _] m]]
                              (if (contains? exposes-methods (symbol name))
                                (conj ms [((symbol name) exposes-methods) m])
                                ms)) [] (seq mm))]
         (let [ptypes (to-types (.getParameterTypes m))
               rtype (totype (.getReturnType m))
               exposer-m (new Method (str local-mname) rtype ptypes)
               target-m (new Method (.getName m) rtype ptypes)
               gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) exposer-m nil nil cv)]
           (. gen (loadThis))
           (. gen (loadArgs))
           (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL)
                                   (. super-type (getInternalName))
                                   (. target-m (getName))
                                   (. target-m (getDescriptor))))
           (. gen (returnValue))
           (. gen (endMethod)))))
                                        ;main
    (when main
      (let [m (. Method getMethod "void main (String[])")
            gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
                     m nil nil cv)
            no-main-label (. gen newLabel)
            end-label (. gen newLabel)]
        (. gen (visitCode))

        (emit-get-var gen main-name)
        (. gen dup)
        (. gen ifNull no-main-label)
        (.checkCast gen ifn-type)
        (. gen loadArgs)
        (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.ISeq seq(Object)"))))
        (. gen (invokeInterface ifn-type (new Method "applyTo" obj-type
                                              (into-array [iseq-type]))))
        (. gen pop)
        (. gen goTo end-label)
                                        ;no main found
        (. gen mark no-main-label)
        (. gen (throwException ex-type (str impl-pkg-name "/" prefix main-name " not defined")))
        (. gen mark end-label)
        (. gen (returnValue))
        (. gen (endMethod))))
                                        ;field exposers
    (doseq [[f {getter :get setter :set}] exposes]
      (let [fld (find-field super (str f))
            ftype (totype (.getType fld))
            static? (Modifier/isStatic (.getModifiers fld))
            acc (+ Opcodes/ACC_PUBLIC (if static? Opcodes/ACC_STATIC 0))]
        (when getter
          (let [m (new Method (str getter) ftype (to-types []))
                gen (new GeneratorAdapter acc m nil nil cv)]
            (. gen (visitCode))
            (if static?
              (. gen getStatic ctype (str f) ftype)
              (do
                (. gen loadThis)
                (. gen getField ctype (str f) ftype)))
            (. gen (returnValue))
            (. gen (endMethod))))
        (when setter
          (let [m (new Method (str setter) Type/VOID_TYPE (into-array [ftype]))
                gen (new GeneratorAdapter acc m nil nil cv)]
            (. gen (visitCode))
            (if static?
              (do
                (. gen loadArgs)
                (. gen putStatic ctype (str f) ftype))
              (do
                (. gen loadThis)
                (. gen loadArgs)
                (. gen putField ctype (str f) ftype)))
            (. gen (returnValue))
            (. gen (endMethod))))))
                                        ;finish class def
    (. cv (visitEnd))
    [cname (. cv (toByteArray))]))

(defmacro gen-class
  "When compiling, generates compiled bytecode for a class with the
given package-qualified :name (which, as all names in these
parameters, can be a string or symbol), and writes the .class file
to the *compile-path* directory. When not compiling, does
nothing. The gen-class construct contains no implementation, as the
implementation will be dynamically sought by the generated class in
functions in an implementing Clojure namespace. Given a generated
class org.mydomain.MyClass with a method named mymethod, gen-class
will generate an implementation that looks for a function named by
(str prefix mymethod) (default prefix: \"-\") in a
Clojure namespace specified by :impl-ns
(defaults to the current namespace). All inherited methods,
generated methods, and init and main functions (see :methods, :init,
and :main below) will be found similarly prefixed. By default, the
static initializer for the generated class will attempt to load the
Clojure support code for the class as a resource from the classpath,
e.g. in the example case, ``org/mydomain/MyClass__init.class``. This
behavior can be controlled by :load-impl-ns

Note that methods with a maximum of 18 parameters are supported.

In all subsequent sections taking types, the primitive types can be
referred to by their Java names (int, float etc), and classes in the
java.lang package can be used without a package qualifier. All other
classes must be fully qualified.

Options should be a set of key/value pairs, all except for :name are optional:

:name aname

The package-qualified name of the class to be generated

:extends aclass

Specifies the superclass, the non-private methods of which will be
overridden by the class. If not provided, defaults to Object.

:implements [interface ...]

One or more interfaces, the methods of which will be implemented by the class.

:init name

If supplied, names a function that will be called with the arguments
to the constructor. Must return [ [superclass-constructor-args] state]
If not supplied, the constructor args are passed directly to
the superclass constructor and the state will be nil

:constructors {[param-types] [super-param-types], ...}

By default, constructors are created for the generated class which
match the signature(s) of the constructors for the superclass. This
parameter may be used to explicitly specify constructors, each entry
providing a mapping from a constructor signature to a superclass
constructor signature. When you supply this, you must supply an :init
specifier.

:post-init name

If supplied, names a function that will be called with the object as
the first argument, followed by the arguments to the constructor.
It will be called every time an object of this class is created,
immediately after all the inherited constructors have completed.
It's return value is ignored.

:methods [ [name [param-types] return-type], ...]

The generated class automatically defines all of the non-private
methods of its superclasses/interfaces. This parameter can be used
to specify the signatures of additional methods of the generated
class. Static methods can be specified with ^{:static true} in the
signature's metadata. Do not repeat superclass/interface signatures
here.

:main boolean

If supplied and true, a static public main function will be generated. It will
pass each string of the String[] argument as a separate argument to
a function called (str prefix main).

:factory name

If supplied, a (set of) public static factory function(s) will be
created with the given name, and the same signature(s) as the
constructor(s).
:state name

If supplied, a public final instance field with the given name will be
created. You must supply an :init function in order to provide a
value for the state. Note that, though final, the state can be a ref
or agent, supporting the creation of Java objects with transactional
or asynchronous mutation semantics.

:exposes {protected-field-name {:get name :set name}, ...}

Since the implementations of the methods of the generated class
occur in Clojure functions, they have no access to the inherited
protected fields of the superclass. This parameter can be used to
generate public getter/setter methods exposing the protected field(s)
for use in the implementation.

:exposes-methods {super-method-name exposed-name, ...}

It is sometimes necessary to call the superclass' implementation of an
overridden method. Those methods may be exposed and referred in
the new method implementation by a local name.

:prefix string

Default: \"-\" Methods called e.g. Foo will be looked up in vars called
prefixFoo in the implementing ns.

:impl-ns name

Default: the name of the current ns. Implementations of methods will be
looked up in this namespace.

:load-impl-ns boolean

Default: true. Causes the static initializer for the generated class
to reference the load code for the implementing namespace. Should be
true when implementing-ns is the default, false if you intend to
load the code via some other method."
  {:added "1.0"}
  
  [& options]
    (when *compile-files*
      (let [options-map (into1 {} (map vec (partition 2 options)))
            [cname bytecode] (generate-class options-map)]
        (clojure.lang.Compiler/writeClassFile cname bytecode))))

;;;;;;;;;;;;;;;;;;;; gen-interface ;;;;;;;;;;;;;;;;;;;;;;
;; based on original contribution by Chris Houser

(defn- ^Type asm-type
  "Returns an asm Type object for c, which may be a primitive class
(such as Integer/TYPE), any other class (such as Double), or a
fully-qualified class name given as a string or symbol
(such as 'java.lang.String)"
  [c]
  (if (or (instance? Class c) (prim->class c))
    (Type/getType (the-class c))
    (let [strx (str c)]
      (Type/getObjectType
       (.replace (if (some #{\. \[} strx)
                   strx
                   (str "java.lang." strx))
                 "." "/")))))

(defn- generate-interface
  [{:keys [name extends methods]}]
  (let [iname (.replace (str name) "." "/")
        cv (ClassWriter. ClassWriter/COMPUTE_MAXS)]
    (. cv visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC
                                Opcodes/ACC_ABSTRACT
                                Opcodes/ACC_INTERFACE)
       iname nil "java/lang/Object"
       (when (seq extends)
         (into-array (map #(.getInternalName (asm-type %)) extends))))
    (add-annotations cv (meta name))
    (doseq [[mname pclasses rclass pmetas] methods]
      (let [mv (. cv visitMethod (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
                  (str mname)
                  (Type/getMethodDescriptor (asm-type rclass)
                                            (if pclasses
                                              (into-array Type (map asm-type pclasses))
                                              (make-array Type 0)))
                  nil nil)]
        (add-annotations mv (meta mname))
        (dotimes [i (count pmetas)]
          (add-annotations mv (nth pmetas i) i))
        (. mv visitEnd)))
    (. cv visitEnd)
    [iname (. cv toByteArray)]))

(defmacro gen-interface
  "When compiling, generates compiled bytecode for an interface with
the given package-qualified :name (which, as all names in these
parameters, can be a string or symbol), and writes the .class file
to the *compile-path* directory. When not compiling, does nothing.
In all subsequent sections taking types, the primitive types can be
referred to by their Java names (int, float etc), and classes in the
java.lang package can be used without a package qualifier. All other
classes must be fully qualified.
Options should be a set of key/value pairs, all except for :name are
optional:

:name aname

The package-qualified name of the class to be generated

:extends [interface ...]

One or more interfaces, which will be extended by this interface.

:methods [ [name [param-types] return-type], ...]

This parameter is used to specify the signatures of the methods of
the generated interface. Do not repeat superinterface signatures
here."
  {:added "1.0"}

  [& options]
    (let [options-map (apply hash-map options)
          [cname bytecode] (generate-interface options-map)]
      (if *compile-files*
        (clojure.lang.Compiler/writeClassFile cname bytecode)
        (.defineClass ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER)
                      (str (:name options-map)) bytecode options))))

(comment

(defn gen-and-load-class
  "Generates and immediately loads the bytecode for the specified
class. Note that a class generated this way can be loaded only once
- the JVM supports only one class with a given name per
classloader. Subsequent to generation you can import it into any
desired namespaces just like any other class. See gen-class for a
description of the options."
  {:added "1.0"}

  [& options]
  (let [options-map (apply hash-map options)
        [cname bytecode] (generate-class options-map)]
    (.. (clojure.lang.RT/getRootClassLoader) (defineClass cname bytecode options))))

)
Something went wrong with that request. Please try again.