Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

575 lines (530 sloc) 19.961 kb
;: Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (
;; 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.
"Utilities for host-agnostic analysis of clojure forms"
(:refer-clojure :exclude [macroexpand-1 macroexpand])
(:require [ :refer :all]))
(defmulti -analyze (fn [op form env & _] op))
(defmulti parse (fn [[op & form] & rest] op))
(defn analyze
"Given an environment, a map containing
- :locals (mapping of names to lexical bindings),
- :context (one of :statement, :expr or :return
and form, returns an expression object (a map containing at least :form, :op and :env keys).
- :namespaces
- :ns"
[form {:keys [context] :as env}]
(let [form (if (seq? form)
(or (seq form) ()) ; we need to force evaluation in order to analyze
(symbol? form) (-analyze :symbol form env)
(type? form) (-analyze :const form env :type)
(record? form) (-analyze :const form env :record)
(seq? form) (-analyze :seq form env)
(vector? form) (-analyze :vector form env)
(map? form) (-analyze :map form env)
(set? form) (-analyze :set form env)
:else (-analyze :const form env))))
(defn empty-env []
{:context :expr :locals {} :ns 'user :namespaces (atom {})})
(defn analyze-in-env
"Given an env returns a function that when called with an argument
analyzes that argument in the specified env"
(fn [form] (analyze form env)))
;; platoform specific hooks
(declare ^:dynamic macroexpand-1 ;[form env]
^:dynamic create-var) ;[sym env]
(defn wrapping-meta [{:keys [form env] :as expr}]
(let [meta (meta form)]
(if (and (obj? form)
(seq meta))
{:op :with-meta
:env env
:form form
:meta (analyze meta (ctx env :expr))
:expr (assoc-in expr [:env :context] :expr)
:children [:meta :expr]}
(defmethod -analyze :const
[_ form env & [type]]
(let [type (or type (classify form))
m (meta form)]
{:op :const
:env env
:type type
:literal? true
:form form}
(when (seq m)
(let [quoted? (:quoted? env)
quoted-meta (if quoted? (list 'quote m) m)]
{:meta (analyze quoted-meta (ctx env :expr))})))))
(defmethod -analyze :vector
[_ form env]
(let [items-env (ctx env :expr)
items (mapv (analyze-in-env items-env) form)]
{:op :vector
:env env
:items items
:form form
:children [:items]})))
(defmethod -analyze :map
[_ form env]
(let [kv-env (ctx env :expr)
keys (keys form)
vals (vals form)
[ks vs] (map (partial mapv (analyze-in-env kv-env)) [keys vals])]
{:op :map
:env env
:keys ks
:vals vs
:form form
:children [:keys :vals]})))
(defmethod -analyze :set
[_ form env]
(let [items-env (ctx env :expr)
items (mapv (analyze-in-env items-env) form)]
{:op :set
:env env
:items items
:form form
:children [:items]})))
(def specials
'#{do if new quote set! try
catch throw finally & def .
let* letfn* loop* recur fn*})
(defn macroexpand
[form env]
(let [ex (macroexpand-1 form env)]
(if (identical? ex form)
(recur (with-meta ex (meta form)) env))))
(defmethod -analyze :symbol
[_ sym env]
(let [mform (macroexpand-1 sym env)]
(if (= mform sym)
(merge (if-let [{:keys [init mutable] :as local-binding} (-> env :locals sym)]
(merge local-binding
{:op :local
:assignable? (boolean mutable)}
(when init
{:children [:init]}))
(if-let [var (resolve-var sym env)]
{:op :var
:assignable? (dynamic? var)
:var var}
(if-let [maybe-class (namespace sym)] ;; e.g. js/ or Long/MAX_VALUE
(let [maybe-class (symbol maybe-class)]
(if-not (find-ns maybe-class)
{:op :maybe-host-form
:maybe-class maybe-class
:maybe-field (symbol (name sym))}
(throw (ex-info (str "could not resolve var: " sym)
{:var sym}))))
{:op :maybe-class ;; e.g. java.lang.Integer or Long
:maybe-class sym})))
{:env env
:form sym})
(analyze (if (obj? mform)
(with-meta mform (meta sym))
(defmethod -analyze :seq
[_ form env]
(let [op (first form)]
(if (nil? op)
(ex-info "Can't call nil" {:form form}))
(let [mform (macroexpand-1 form env)]
(if (identical? form mform)
(parse form env) ;; invoke == :default
(analyze (if (obj? mform)
(with-meta mform (meta form))
(defn analyze-block
"returns {:statements .. :ret ..}"
[exprs env]
(let [statements-env (ctx env :statement)
statements (mapv (analyze-in-env statements-env)
(butlast exprs))
ret (analyze (last exprs) env)]
{:statements statements
:ret ret
:children [:statements :ret]}))
(defmethod parse 'do
[[_ & exprs :as form] env]
(into {:op :do
:env env
:form form}
(analyze-block exprs env)))
(defmethod parse 'if
[[_ test then else :as form] env]
{:pre [(or (= 3 (count form))
(= 4 (count form)))]}
(let [test-expr (analyze test (ctx env :expr))
then-expr (analyze then env)
else-expr (analyze else env)]
{:op :if
:form form
:env env
:test test-expr
:then then-expr
:else else-expr
:children `[:test :then :else]}))
(defmethod parse 'new
[[_ class & args :as form] env]
{:pre [(>= (count form) 2)]}
(let [args-env (ctx env :expr)
args (mapv (analyze-in-env args-env) args)]
{:op :new
:env env
:form form
:maybe-class class
:args args
:children [:args]}))
(defmethod parse 'quote
[[_ expr :as form] env]
(let [const (-analyze :const expr (assoc env :quoted? true))]
{:op :quote
:expr const
:form form
:env env
:literal? true
:children [:expr]}))
(defmethod parse 'set!
[[_ target val :as form] env]
{:pre [(= (count form) 3)]}
(let [target (analyze target (ctx env :expr))
val (analyze val (ctx env :expr))]
{:op :set!
:env env
:form form
:target target
:val val
:children [:target :val]}))
(defmethod parse 'try
[[_ & body :as form] {:keys [context] :as env}]
(let [catch? (every-pred seq? #(= (first %) 'catch))
finally? (every-pred seq? #(= (first %) 'finally))
[body tail] (split-with (complement (some-fn catch? finally?)) body)
[cblocks tail] (split-with catch? tail)
[[fblock & fbs :as fblocks] tail] (split-with finally? tail)]
(when-not (empty? tail)
(throw (ex-info "only catch or finally clause can follow catch in try expression"
{:expr tail})))
(when-not (empty? fbs)
(throw (ex-info "only one finally clause allowed in try expression"
{:expr fblocks})))
(let [body (parse (cons 'do body) (assoc env :in-try true)) ;; avoid recur
cenv (ctx env :expr)
cblocks (mapv #(parse % cenv) cblocks)
fblock (when-not (empty? fblock)
(parse (cons 'do (rest fblock)) (ctx env :statement)))]
(merge {:op :try
:env env
:form form
:body body
:catches cblocks}
(when fblock
{:finally fblock})
{:children `[:body :catches ~@(when fblock [:finally])]}))))
(defmethod parse 'catch
[[_ etype ename & body :as form] env]
(if (and (symbol? ename)
(not (namespace ename)))
(let [local {:op :binding
:env env
:form ename
:name ename
:local :catch
:tag etype}]
{:op :catch
:maybe-class etype
:local local
:env env
:form form
:body (parse (cons 'do body) (assoc-in env [:locals ename] local))
:children [:local :body]})
(throw (ex-info (str "invalid binding form: " ename) {:sym ename}))))
(defmethod parse 'throw
[[_ throw :as form] env]
{:op :throw
:env env
:form form
:exception (analyze throw (ctx env :expr))
:children [:exception]})
(defmethod parse 'letfn*
[[_ bindings & body :as form] {:keys [context] :as env}]
{:pre [(vector? bindings)
(even? (count bindings))]}
(let [bindings (apply hash-map bindings)
fns (keys bindings)]
(when-not (every? #(and (symbol? %)
(not (namespace %)))
(throw (ex-info (str "bad binding form: " (first (remove symbol? fns)))
{:form form})))
(let [binds (reduce (fn [binds name]
(assoc binds name
{:op :binding
:env env
:name name
:form name
:local :letfn
:children [:init]}))
{} fns)
e (update-in env [:locals] merge binds)
binds (reduce-kv (fn [binds name bind]
(assoc binds name
(assoc bind :init
(analyze (bindings name) (ctx e :expr)))))
{} binds)
e (update-in env [:locals] merge binds)
body (parse (cons 'do body) e)]
{:op :letfn
:env env
:form form
:bindings (vec (vals binds))
:body body
:children [:bindings :body]})))
(defn analyze-let
[[op bindings & body :as form] {:keys [context] :as env}]
{:pre [(vector? bindings)
(even? (count bindings))]}
(let [loop? (= 'loop* op)]
(loop [bindings (seq (partition 2 bindings))
env (ctx env :expr)
binds []]
(if-let [[name init] (first bindings)]
(if (or (namespace name)
(.contains (str name) "."))
(throw (ex-info (str "invalid binding form: " name)
{:sym name}))
(let [init-expr (analyze init env)
bind-expr {:op :binding
:env env
:name name
:init init-expr
:form name
:local (if loop? :loop :let)
:children [:init]}]
(recur (next bindings)
(assoc-in env [:locals name] bind-expr)
(conj binds bind-expr))))
(let [body-env (assoc env
:context (if loop? :return context))
body (parse (cons 'do body)
(if loop?
(assoc body-env
:loop-locals (count binds))
{:body body
:bindings binds
:children [:bindings :body]})))))
(defmethod parse 'let*
[form env]
(into {:op :let
:form form
:env env}
(analyze-let form env)))
(defmethod parse 'loop*
[form env]
(into {:op :loop
:form form
:env env}
(analyze-let form (dissoc env :in-try))))
(defmethod parse 'recur
[[_ & exprs :as form] {:keys [context loop-locals in-try]
:as env}]
{:pre [(= :return context)
(not in-try)
(= (count exprs) loop-locals)]}
(let [exprs (mapv (analyze-in-env (ctx env :expr))
{:op :recur
:env env
:form form
:exprs exprs
:children [:exprs]}))
(defn analyze-fn-method [[params & body :as form] {:keys [locals local] :as env}]
{:pre [(every? symbol? params)
(not-any? namespace params)]}
(let [variadic? (boolean (some '#{&} params))
params-names (vec (remove '#{&} params))
env (dissoc env :local)
arity (count params-names)
params-expr (mapv (fn [name id]
{:env env
:form name
:name name
:variadic? (and variadic?
(= id (dec arity)))
:op :binding
:arg-id id
:local :arg})
params-names (range))
fixed-arity (if variadic?
(dec arity)
body-env (into (update-in env [:locals]
merge (zipmap params-names params-expr))
{:context :return
:loop-locals arity})
body (parse (cons 'do body) body-env)]
(when variadic?
(let [x (drop-while #(not= % '&) params)]
(when (not= 2 (count x))
(throw (ex-info (str "unexpected parameter: " (first (drop 2 x)))
{:params params})))))
{:op :fn-method
:form form
:env env
:variadic? variadic?
:params params-expr
:fixed-arity fixed-arity
:body body
:children `[:params :body]}
(when local
{:local (dissoc local :env)}))))
(defmethod parse 'fn*
[[op & args :as form] {:keys [name] :as env}]
(let [[n meths] (if (symbol? (first args))
[(first args) (next args)]
[nil (seq args)])
name (or n name)
name-expr {:op :binding
:env env
:form name
:local :fn
:name name}
e (if n (assoc (assoc-in env [:locals name] name-expr) :local name-expr) env)
e (assoc (dissoc e :in-try)
:once (-> op meta :once boolean))
meths (if (vector? (first meths)) (list meths) meths) ;;turn (fn [] ...) into (fn ([]...))
menv (if (> (count meths) 1) (ctx env :expr) e)
methods-exprs (mapv #(analyze-fn-method % menv) meths)
variadic (seq (filter :variadic? methods-exprs))
variadic? (boolean variadic)
fixed-arities (seq (map :fixed-arity (remove :variadic? methods-exprs)))
max-fixed-arity (when fixed-arities (apply max fixed-arities))]
(when (>= (count variadic) 2)
(throw (ex-info "can't have more than 1 variadic overload"
{:variadics (mapv :form variadic)})))
(when (not= (seq (distinct fixed-arities)) fixed-arities)
(throw (ex-info "can't have 2 overloads with the same arity"
{:form form})))
(when (and variadic?
(not-every? #(<= (:fixed-arity %)
(:fixed-arity (first variadic)))
(remove :variadic? methods-exprs)))
(throw (ex-info "Can't have fixed arity function with more params than variadic function"
{:form form})))
(merge {:op :fn
:env env
:form form
:name name
:variadic? variadic?
:max-fixed-arity max-fixed-arity
:methods methods-exprs}
(when n
{:local name-expr})
{:children `[~@(when n [:local]) :methods]})))
(defmethod parse 'def
[[_ sym & expr :as form] {:keys [ns namespaces] :as env}]
{:pre [(symbol? sym)
(or (not (namespace sym))
(= *ns* (the-ns (namespace sym))))]}
(let [pfn (fn
{:init init})
([doc init]
{:pre [(string? doc)]}
{:init init :doc doc}))
args (apply pfn expr)
env (assoc env :name sym)
doc (or (:doc args) (-> sym meta :doc))
arglists (when-let [arglists (:arglists (meta sym))]
(second arglists)) ;; drop quote
meta (merge (meta sym)
(-source-info form env)
(when doc {:doc doc}))
sym (if arglists
(vary-meta sym assoc :arglists arglists)
meta-expr (when meta (analyze meta
(ctx env :expr)))
args (when-let [[_ init] (find args :init)]
{:init (analyze init (ctx env :expr))})
children `[~@(when meta [:meta])
~@(when (:init args) [:init])]
var (create-var sym env)]
(swap! namespaces assoc ns :mappings sym var)
(merge {:op :def
:env env
:form form
:name sym
:var var}
(when meta
{:meta meta-expr}) ;; or meta?
(when-not (empty? children)
{:children children}))))
(defmethod parse '.
[[_ target & [m-or-f & args] :as form] env]
{:pre [(>= (count form) 3)]}
(let [[m-or-f field?] (if (and (symbol? m-or-f)
(= \- (first (name m-or-f))))
[(-> m-or-f name (subs 1) symbol) true]
[(if args (cons m-or-f args) m-or-f) false])
target-expr (analyze target (ctx env :expr))
call? (and (not field?) (seq? m-or-f))
expr (cond
{:op :host-call
:target target-expr
:method (symbol (name (first m-or-f)))
:args (mapv (analyze-in-env (ctx env :expr)) (next m-or-f))
:children [:target :args]}
{:op :host-field
:target target-expr
:field m-or-f
:children [:target]}
{:op :host-interop ;; either field access or single method call
:target target-expr
:m-or-f m-or-f
:children [:target]})]
(merge {:form form
:env env}
;; invoke
(defmethod parse :default
[[f & args :as form] env]
(if-not f
(-analyze :const form env)
(let [e (ctx env :expr)
fn-expr (analyze f e)
args-expr (mapv (analyze-in-env e) args)
m (meta form)]
(merge {:op :invoke
:form form
:env env
:fn fn-expr
:args args-expr}
(when m
{:meta m}) ;; this means it's not going to be evaluated
{:children [:args :fn]}))))
Jump to Line
Something went wrong with that request. Please try again.