git » blacktide.git » master » tree

[master] / src / com / tailrecursion / blacktide / compiler / passes / source_host.clj 

 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
(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.source-host
  "Recognize native JVM syntax in the caller namespace. Return host
  descriptors and ordered source operands; none of those operands is evaluated."
  (:require [com.tailrecursion.nanopass :as np]
            [com.tailrecursion.blacktide.compiler.languages :as l]
            [com.tailrecursion.blacktide.compiler.jvm :as jvm]
            [typed.clojure :as-alias t]))

(np/defpass tags {:from [l/JVM Raw] :to [l/JVM Tags] :body true}
  [symbol]
  (let [tags (:param-tags (meta symbol))]
    (if (or (nil? tags) (vector? tags)) tags
        (throw (IllegalArgumentException. "param-tags must be a vector")))))

(np/defpass qualified
  {:from [l/JVM Raw] :to (t/Option l/JVM-Operation) :body true}
  [symbol]
  (when (and (symbol? symbol) (namespace symbol))
    (when-let [class (jvm/resolved-class (clojure.core/symbol (or (namespace symbol) "")))]
      (let [member (name symbol) tags (tags symbol)]
        (cond (= member "new") {:op :constructor :class class :tags tags}
              (.startsWith member ".") {:op :instance :class class :member (clojure.core/symbol (subs member 1))
                                         :mode :method :tags tags}
              (and (clojure.lang.Reflector/getField class member true)
                   (not (jvm/static-method? class member)))
              {:op :static-field :class class :member (clojure.core/symbol member)}
              :else {:op :static :class class :member (clojure.core/symbol member) :tags tags})))))

(np/defpass syntax
  {:from [l/Bound Forms] :to (t/Option l/JVM-Syntax) :body true}
  [forms]
  (let [op (first forms) args (subvec forms 1)]
    (cond
      (= op 'new)
      (if-let [class (jvm/resolved-class (first args))]
        {:operation {:op :constructor :class class :tags nil} :operands (vec (rest args))}
        (throw (IllegalArgumentException. "new requires a class name")))
      (= op '.)
      (let [[target member & extra] args
            _ (when (< (count forms) 3) (throw (IllegalArgumentException. "Malformed member expression")))
            class (jvm/resolved-class target)
            method? (seq? member)
            values (if method? (vec (rest member)) (vec extra))
            member (if method? (first member) member)]
        (when-not (symbol? member) (throw (IllegalArgumentException. "Expected a Java member name")))
        (let [field? (.startsWith (name member) "-")
              member (symbol (if field? (subs (name member) 1) (name member)))
              mode (cond field? :field (or method? (seq values)) :method :else :member)]
          (if class
            (if (and (not= mode :method)
                     (or field? (empty? (jvm/methods class 0 true member))))
              {:operation {:op :static-field :class class :member member} :operands []}
              {:operation {:op :static :class class :member member :tags nil} :operands values})
            {:operation {:op :instance :class nil :member member :mode mode :tags nil}
             :operands (into [target] values)})))
      (symbol? op)
      (cond
        (and (nil? (namespace op)) (.startsWith (name op) "."))
        (let [target (first args)
              target (if (jvm/resolved-class target)
                       (with-meta (list 'clojure.core/identity target) {:tag 'java.lang.Class}) target)]
          (when (empty? args) (throw (IllegalArgumentException. "Instance member requires a receiver")))
          (syntax (into ['. target (symbol (subs (name op) 1))] (rest args))))
        (.endsWith (name op) ".")
        (syntax (into ['new (symbol (subs (str op) 0 (dec (count (str op)))))] args))
        :else (when-let [operation (qualified op)]
                (when (and (= :instance (:op operation)) (empty? args))
                  (throw (IllegalArgumentException. "Qualified instance call requires a receiver")))
                (when (and (= :static-field (:op operation)) (seq args))
                  (throw (IllegalArgumentException. "Cannot invoke a static field with arguments")))
                {:operation operation :operands args})))))