Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

658 lines (587 sloc) 22.53 kb
(:refer-clojure :exclude [read read-line read-string char])
(:require [ :refer :all]
[utils :refer :all]
[commons :refer :all]])
(:import (clojure.lang PersistentHashSet IMeta
RT Symbol Reflector Var IObj
PersistentVector IRecord Namespace)
;; helpers
(declare read macros dispatch-macros)
(defn macro-terminating? [ch]
(and (not (identical? \# ch))
(not (identical? \' ch))
(not (identical? \% ch))
(not (identical? \: ch))
(macros ch)))
(defn ^String read-token
[rdr initch]
(if-not initch
(reader-error rdr "EOF while reading")
(loop [sb (doto (StringBuilder.) (.append initch))
ch (peek-char rdr)]
(if (or (whitespace? ch)
(macro-terminating? ch)
(nil? ch))
(str sb)
(recur (doto sb (.append (read-char rdr))) (peek-char rdr))))))
(declare read-tagged)
(defn read-dispatch
[rdr _]
(if-let [ch (read-char rdr)]
(if-let [dm (dispatch-macros ch)]
(dm rdr ch)
(if-let [obj (read-tagged (doto rdr (unread ch)) ch)] ;; ctor reader is implemented as a taggged literal
(reader-error rdr "No dispatch macro for " ch)))
(reader-error rdr "EOF while reading character")))
(defn read-unmatched-delimiter
[rdr ch]
(reader-error rdr "Unmatched delimiter " ch))
;; readers
(defn read-unicode-char
([^String token offset length base]
(let [l (+ offset length)]
(when-not (== (count token) l)
(throw (IllegalArgumentException. (str "Invalid unicode character: \\" token))))
(loop [i offset uc 0]
(if (== i l)
(char uc)
(let [d (Character/digit ^char (nth token i) ^int base)]
(if (== d -1)
(throw (IllegalArgumentException. (str "Invalid digit: " (nth token i))))
(recur (inc i) (long (+ d (* uc base))))))))))
([rdr initch base length exact?]
(loop [i 1 uc (Character/digit ^char initch ^int base)]
(if (== uc -1)
(throw (IllegalArgumentException. (str "Invalid digit: " initch)))
(if-not (== i length)
(let [ch (peek-char rdr)]
(if (or (whitespace? ch)
(macros ch)
(nil? ch))
(if exact?
(throw (IllegalArgumentException.
(str "Invalid character length: " i ", should be: " length)))
(char uc))
(let [d (Character/digit ^char ch ^int base)]
(read-char rdr)
(if (== d -1)
(throw (IllegalArgumentException. (str "Invalid digit: " ch)))
(recur (inc i) (long (+ d (* uc base))))))))
(char uc))))))
(let [upper-limit (int \uD7ff)
lower-limit (int \uE000)]
(defn read-char*
[rdr backslash]
(let [ch (read-char rdr)]
(if-not (nil? ch)
(let [token (read-token rdr ch)
token-len (count token)]
(== 1 token-len) (Character/valueOf (nth token 0))
(= token "newline") \newline
(= token "space") \space
(= token "tab") \tab
(= token "backspace") \backspace
(= token "formfeed") \formfeed
(= token "return") \return
(.startsWith token "u")
(let [c (read-unicode-char token 1 4 16)
ic (int c)]
(if (and (> ic upper-limit)
(< ic lower-limit))
(reader-error rdr "Invalid character constant: \\u" (Integer/toString ic 16))
(.startsWith token "x")
(read-unicode-char token 1 2 16)
(.startsWith token "o")
(let [len (dec token-len)]
(if (> len 3)
(reader-error rdr "Invalid octal escape sequence length: " len)
(let [uc (read-unicode-char token 1 len 8)]
(if (> (int uc) 0377)
(reader-error rdr "Octal escape sequence must be in range [0, 377]")
:else (reader-error rdr "Unsupported character: \\" token)))
(reader-error rdr "EOF while reading character")))))
(defn ^PersistentVector read-delimited
[delim rdr recursive?]
(let [first-line (when (indexing-reader? rdr)
(get-line-number rdr))
delim ^char delim]
(loop [a (transient [])]
(let [ch (read-past whitespace? rdr)]
(when-not ch
(reader-error rdr "EOF while reading"
(if first-line
(str ", starting at line" first-line))))
(if (identical? delim ^char ch)
(persistent! a)
(if-let [macrofn (macros ch)]
(let [mret (macrofn rdr ch)]
(recur (if-not (identical? mret rdr) (conj! a mret) a)))
(let [o (read (doto rdr (unread ch)) true nil recursive?)]
(recur (if-not (identical? o rdr) (conj! a o) a)))))))))
(defn read-list
[rdr _]
(let [[line column] (when (indexing-reader? rdr)
[(get-line-number rdr) (dec (get-column-number rdr))])
the-list (read-delimited \) rdr true)]
(if (empty? the-list)
(with-meta (clojure.lang.PersistentList/create the-list)
(when line
{:line line :column column})))))
(defn read-vector
[rdr _]
(let [[line column] (when (indexing-reader? rdr)
[(get-line-number rdr) (dec (get-column-number rdr))])
the-vector (read-delimited \] rdr true)]
(with-meta the-vector
(when line
{:line line :column column}))))
(defn read-map
[rdr _]
(let [[line column] (when (indexing-reader? rdr)
[(get-line-number rdr) (dec (get-column-number rdr))])
l (to-array (read-delimited \} rdr true))]
(when (== 1 (bit-and (alength l) 1))
(reader-error rdr "Map literal must contain an even number of forms"))
(with-meta (RT/map l)
(when line
{:line line :column column}))))
(defn read-number
[reader initch]
(loop [sb (doto (StringBuilder.) (.append initch))
ch (read-char reader)]
(if (or (whitespace? ch) (macros ch) (nil? ch))
(let [s (str sb)]
(unread reader ch)
(or (match-number s)
(reader-error reader "Invalid number format [" s "]")))
(recur (doto sb (.append ch)) (read-char reader)))))
(defn escape-char [sb rdr]
(let [ch (read-char rdr)]
(case ch
\t "\t"
\r "\r"
\n "\n"
\\ "\\"
\" "\""
\b "\b"
\f "\f"
\u (let [ch (read-char rdr)]
(if (== -1 (Character/digit ^char ch 16))
(reader-error rdr "Invalid unicode escape: \\u" ch)
(read-unicode-char rdr ch 16 4 true)))
\x (let [ch (read-char rdr)]
(if (== -1 (Character/digit ^char ch 16))
(reader-error rdr "Invalid unicode escape: \\x" ch)
(read-unicode-char rdr ch 16 2 true)))
(if (numeric? ch)
(let [ch (read-unicode-char rdr ch 8 3 false)]
(if (> (int ch) 0337)
(reader-error rdr "Octal escape sequence must be in range [0, 377]")
(reader-error rdr "Unsupported escape character: \\" ch)))))
(defn read-string*
[reader _]
(loop [sb (StringBuilder.)
ch (read-char reader)]
(case ch
nil (reader-error reader "EOF while reading string")
\\ (recur (doto sb (.append (escape-char sb reader)))
(read-char reader))
\" (str sb)
(recur (doto sb (.append ch)) (read-char reader)))))
(defn read-symbol
[rdr initch]
(when-let [token (read-token rdr initch)]
(let [[line column] (when (indexing-reader? rdr)
[(get-line-number rdr) (dec (get-column-number rdr))])]
(case token
;; special symbols
"nil" nil
"true" true
"false" false
"/" '/
"NaN" Double/NaN
"-Infinity" Double/NEGATIVE_INFINITY
("Infinity" "+Infinity") Double/POSITIVE_INFINITY
(or (when-let [p (parse-symbol token)]
(with-meta (symbol (p 0) (p 1))
(when line
{:line line :column column})))
(reader-error rdr "Invalid token: " token))))))
(defn- resolve-ns [sym]
(or ((ns-aliases *ns*) sym)
(find-ns sym)))
(defn read-keyword
[reader initch]
(let [ch (read-char reader)]
(if-not (whitespace? ch)
(let [token (read-token reader ch)
s (parse-symbol token)]
(if (and s (== -1 (.indexOf token "::")))
(let [^String ns (s 0)
^String name (s 1)]
(if (identical? \: (nth token 0))
(if ns
(let [ns (resolve-ns (symbol (subs ns 1)))]
(if ns
(keyword (str ns) name)
(reader-error reader "Invalid token: :" token)))
(keyword (str *ns*) (subs name 1)))
(keyword ns name)))
(reader-error reader "Invalid token: :" token)))
(reader-error reader "Invalid token: :"))))
(defn wrapping-reader
(fn [rdr _]
(list sym (read rdr true nil true))))
(defn read-meta
[rdr _]
(let [[line column] (when (indexing-reader? rdr)
[(get-line-number rdr) (dec (get-column-number rdr))])
m (desugar-meta (read rdr true nil true))]
(when-not (map? m)
(reader-error rdr "Metadata must be Symbol, Keyword, String or Map"))
(let [o (read rdr true nil true)]
(if (instance? IMeta o)
(let [m (if (and line
(seq? o))
(assoc m :line line
:column column)
(if (instance? IObj o)
(with-meta o (merge (meta o) m))
(reset-meta! o m)))
(reader-error rdr "Metadata can only be applied to IMetas")))))
(defn read-set
[rdr _]
(PersistentHashSet/createWithCheck (read-delimited \} rdr true)))
(defn read-discard
[rdr _]
(read rdr true nil true)
(def ^:private ^:dynamic arg-env nil)
(defn- garg [n]
(symbol (str (if (== -1 n) "rest" (str "p" n))
"__" (RT/nextID) "#")))
(defn read-fn
[rdr _]
(if arg-env
(throw (IllegalStateException. "Nested #()s are not allowed")))
(with-bindings {#'arg-env (sorted-map)}
(unread rdr \()
(let [form (read rdr true nil true) ;; this sets bindings
rargs (rseq arg-env)
args (if rargs
(let [higharg (key (first rargs))]
(if (pos? higharg)
(let [args (loop [i 1 args (transient [])]
(if (> i higharg)
(persistent! args)
(recur (inc i) (conj! args (or (get arg-env i)
(garg i))))))
args (if (arg-env -1)
(conj args '& (arg-env -1))
(list 'fn* args form))))
(defn register-arg [n]
(if arg-env
(if-let [ret (arg-env n)]
(let [g (garg n)]
(set! arg-env (assoc arg-env n g))
(throw (IllegalStateException. "Arg literal not in #()")))) ;; should never hit this
(declare read-symbol)
(defn read-arg
[rdr pct]
(if-not arg-env
(read-symbol rdr pct)
(let [ch (peek-char rdr)]
(if (or (whitespace? ch)
(macro-terminating? ch)
(nil? ch))
(register-arg 1)
(let [n (read rdr true nil true)]
(if (= n '&)
(register-arg -1)
(if-not (number? n)
(throw (IllegalStateException. "Arg literal must be %, %& or %integer"))
(register-arg n))))))))
(defn read-eval
[rdr _]
(when-not *read-eval*
(reader-error rdr "#= not allowed when *read-eval* is false"))
(let [o (read rdr true nil true)]
(if (symbol? o)
(RT/classForName (str ^Symbol o))
(if (list? o)
(let [fs (first o)
o (rest o)
fs-name (name fs)]
(= fs 'var) (let [vs (first o)]
(RT/var (namespace vs) (name vs)))
(.endsWith fs-name ".")
(let [args (to-array o)]
(-> fs-name (subs 0 (dec (count fs-name)))
RT/classForName (Reflector/invokeConstructor args)))
(Compiler/namesStaticMember fs)
(let [args (to-array o)]
(Reflector/invokeStaticMethod (namespace fs) fs-name args))
(let [v (Compiler/maybeResolveIn *ns* fs)]
(if (var? v)
(apply v o)
(reader-error rdr "Can't resolve " fs)))))
(throw (IllegalArgumentException. "Unsupported #= form"))))))
(def ^:private ^:dynamic gensym-env nil)
(defn read-unquote
[rdr comma]
(if-let [ch (peek-char rdr)]
(if (identical? \@ ch)
((wrapping-reader 'clojure.core/unquote-splicing) (doto rdr read-char) \@)
((wrapping-reader 'clojure.core/unquote) rdr \~))))
(declare syntax-quote)
(defn unquote-splicing? [form]
(and (seq? form)
(= (first form) 'clojure.core/unquote-splicing)))
(defn unquote? [form]
(and (seq? form)
(= (first form) 'clojure.core/unquote)))
(defn- expand-list [s]
(loop [s (seq s) r (transient [])]
(if s
(let [item (first s)
ret (conj! r
(unquote? item) (list 'clojure.core/list (second item))
(unquote-splicing? item) (second item)
:else (list 'clojure.core/list (syntax-quote item))))]
(recur (next s) ret))
(seq (persistent! r)))))
(defn- flatten-map [form]
(loop [s (seq form) key-vals (transient [])]
(if s
(let [e (first s)]
(recur (next s) (-> key-vals
(conj! (key e))
(conj! (val e)))))
(seq (persistent! key-vals)))))
(defn- register-gensym [sym]
(if-not gensym-env
(throw (IllegalStateException. "Gensym literal not in syntax-quote")))
(or (get gensym-env sym)
(let [gs (symbol (str (subs (name sym)
0 (dec (count (name sym))))
"__" (RT/nextID) "__auto__"))]
(set! gensym-env (assoc gensym-env sym gs))
(defn- resolve-symbol [s]
(if (pos? (.indexOf (name s) "."))
(if-let [ns-str (namespace s)]
(let [^Namespace ns (resolve-ns (symbol ns-str))]
(if (or (nil? ns)
(= (name (ns-name ns)) ns-str)) ;; not an alias
(symbol (name (.name ns)) (name s))))
(if-let [o ((ns-map *ns*) s)]
(if (class? o)
(symbol (.getName ^Class o))
(if (var? o)
(symbol (-> ^Var o .ns .name name) (-> ^Var o .sym name))))
(symbol (name (ns-name *ns*)) (name s))))))
(defn- add-meta [form ret]
(if (and (instance? IObj form)
(dissoc (meta form) :line :column))
(list 'clojure.core/with-meta ret (syntax-quote (meta form)))
(defn- syntax-quote-coll [type coll]
(let [res (list 'clojure.core/seq
(cons 'clojure.core/concat
(expand-list coll)))]
(if type
(list 'clojure.core/apply type res)
(defn syntax-quote [form]
(special-symbol? form) (list 'quote form)
(symbol? form)
(list 'quote
(if (namespace form)
(let [maybe-class ((ns-map *ns*)
(symbol (namespace form)))]
(if (class? class)
(symbol (.getName ^Class maybe-class) (name form))
(resolve-symbol form)))
(let [sym (name form)]
(.endsWith sym "#")
(register-gensym form)
(.startsWith sym ".")
(.endsWith sym ".")
(let [csym (symbol (subs sym 0 (dec (count sym))))]
(symbol (.concat (name (resolve-symbol csym)) ".")))
:else (resolve-symbol form)))))
(unquote? form) (second form)
(unquote-splicing? form) (throw (IllegalStateException. "splice not in list"))
(coll? form)
(instance? IRecord form) form
(map? form) (syntax-quote-coll 'clojure.core/hash-map (flatten-map form))
(vector? form) (syntax-quote-coll 'clojure.core/vector form)
(set? form) (syntax-quote-coll 'clojure.core/hash-set form)
(or (seq? form) (list? form))
(let [seq (seq form)]
(if seq
(syntax-quote-coll nil seq)
:else (throw (UnsupportedOperationException. "Unknown Collection type")))
(or (keyword? form)
(number? form)
(char? form)
(string? form))
:else (list 'quote form))
(add-meta form)))
(defn read-syntax-quote
[rdr backquote]
(with-bindings {#'gensym-env {}}
(-> (read rdr true nil true)
(defn macros [ch]
(case ch
\" read-string*
\: read-keyword
\; read-comment
\' (wrapping-reader 'quote)
\@ (wrapping-reader 'clojure.core/deref)
\^ read-meta
\` read-syntax-quote ;;(wrapping-reader 'syntax-quote)
\~ read-unquote
\( read-list
\) read-unmatched-delimiter
\[ read-vector
\] read-unmatched-delimiter
\{ read-map
\} read-unmatched-delimiter
\\ read-char*
\% read-arg
\# read-dispatch
(defn dispatch-macros [ch]
(case ch
\^ read-meta ;deprecated
\' (wrapping-reader 'var)
\( read-fn
\= read-eval
\{ read-set
\< (throwing-reader "Unreadable form")
\" read-regex
\! read-comment
\_ read-discard
(defn read-tagged* [rdr tag f]
(let [o (read rdr true nil true)]
(f o)))
(defn read-ctor [rdr class-name]
(when-not *read-eval*
(reader-error "Record construction syntax can only be used when *read-eval* == true"))
(let [class (Class/forName (name class-name) false (RT/baseLoader))
ch (read-past whitespace? rdr)] ;; differs from clojure
(if-let [[end-ch form] (case ch
\[ [\] :short]
\{ [\} :extended]
(let [entries (to-array (read-delimited end-ch rdr true))
all-ctors (.getConstructors class)
ctors-num (count all-ctors)]
(case form
(loop [i 0]
(if (> i ctors-num)
(reader-error rdr "Unexpected number of constructor arguments to " (str class)
": got" (count entries))
(if (== (count (.getParameterTypes ^Constructor (aget all-ctors i)))
(Reflector/invokeConstructor class entries)
(recur (inc i)))))
(let [vals (RT/map entries)]
(loop [s (keys vals)]
(if s
(if-not (keyword? (first s))
(reader-error rdr "Unreadable ctor form: key must be of type clojure.lang.Keyword")
(recur (next s)))))
(Reflector/invokeStaticMethod class "create" (object-array [vals])))))
(reader-error rdr "Invalid reader constructor form"))))
(def default-data-reader-fn
(when >=clojure-1-5-alpha*?
(resolve '*default-data-reader-fn*)))
(defn read-tagged [rdr initch]
(let [tag (read rdr true nil false)]
(if-not (symbol? tag)
(reader-error rdr "Reader tag must be a symbol"))
(if-let [f (or (*data-readers* tag)
(default-data-readers tag))]
(read-tagged* rdr tag f)
(if (.contains (name tag) ".")
(read-ctor rdr tag)
(if-let [f @default-data-reader-fn]
(f tag (read rdr true nil true))
(reader-error rdr "No reader function for tag " (name tag)))))))
;; Public API
(defn read
"Reads the first object from an IPushbackReader or a
Returns the object read. If EOF, throws if eof-error? is true. Otherwise returns sentinel."
([] (read *in*))
([reader] (read reader true nil))
([reader eof-error? sentinel] (read reader eof-error? sentinel false))
([reader eof-error? sentinel recursive?]
(when (= :unknown *read-eval*)
(reader-error "Reading disallowed - *read-eval* bound to :unknown"))
(let [ch (read-char reader)]
(whitespace? ch) (read reader eof-error? sentinel recursive?)
(nil? ch) (if eof-error? (reader-error reader "EOF") sentinel)
(number-literal? reader ch) (read-number reader ch)
(comment-prefix? ch) (read (read-comment reader ch) eof-error? sentinel recursive?)
:else (let [f (macros ch)]
(if f
(let [res (f reader ch)]
(if (identical? res reader)
(read reader eof-error? sentinel recursive?)
(read-symbol reader ch)))))
(catch Exception e
(if (instance? clojure.lang.ExceptionInfo e)
(throw e)
(throw (ex-info (.getMessage e)
(merge {:type :reader-exception}
(if (indexing-reader? reader)
{:line (get-line-number reader)
:column (get-column-number reader)}))
(defn read-string
"Reads one object from the string s"
(read (string-push-back-reader s) true nil false))
Jump to Line
Something went wrong with that request. Please try again.