951 lines
33 KiB
Clojure
951 lines
33 KiB
Clojure
;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
|
|
;; 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.
|
|
|
|
(ns ^{:doc "A clojure reader in clojure"
|
|
:author "Bronsa"}
|
|
cljs.tools.reader
|
|
(:refer-clojure :exclude [read read-line read-string char read+string
|
|
default-data-readers *default-data-reader-fn*
|
|
*data-readers* *suppress-read*])
|
|
(:require-macros [cljs.tools.reader.reader-types :refer [log-source]])
|
|
(:require [cljs.tools.reader.reader-types :refer
|
|
[read-char unread peek-char indexing-reader?
|
|
get-line-number get-column-number get-file-name
|
|
string-push-back-reader]]
|
|
[cljs.tools.reader.impl.utils :refer
|
|
[char ex-info? whitespace? numeric? desugar-meta next-id namespace-keys second'
|
|
ReaderConditional reader-conditional reader-conditional? char-code]]
|
|
[cljs.tools.reader.impl.commons :refer
|
|
[number-literal? read-past match-number parse-symbol read-comment throwing-reader]]
|
|
[cljs.tools.reader.impl.errors :as err]
|
|
[goog.array :as garray]
|
|
[goog.string :as gstring])
|
|
(:import goog.string.StringBuffer))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; helpers
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(declare ^:private read*
|
|
macros dispatch-macros
|
|
^:dynamic *data-readers*
|
|
^:dynamic *default-data-reader-fn*
|
|
^:dynamic *suppress-read*
|
|
default-data-readers)
|
|
|
|
(defn- ^boolean macro-terminating? [ch]
|
|
(case ch
|
|
(\" \; \@ \^ \` \~ \( \) \[ \] \{ \} \\) true
|
|
false))
|
|
|
|
(def sb (StringBuffer.))
|
|
|
|
(defn- read-token
|
|
"Read in a single logical token from the reader"
|
|
[^not-native rdr kind initch]
|
|
(if (nil? initch)
|
|
(err/throw-eof-at-start rdr kind)
|
|
(do
|
|
(.clear sb)
|
|
(loop [ch initch]
|
|
(if (or (whitespace? ch)
|
|
(macro-terminating? ch)
|
|
(nil? ch))
|
|
(do
|
|
(when-not (nil? ch)
|
|
(unread rdr ch))
|
|
(.toString sb))
|
|
(do
|
|
(.append sb ch)
|
|
(recur (read-char rdr))))))))
|
|
|
|
(declare read-tagged)
|
|
|
|
(defn- read-dispatch
|
|
[^not-native rdr _ opts pending-forms]
|
|
(if-let [ch (read-char rdr)]
|
|
(if-let [dm (dispatch-macros ch)]
|
|
(dm rdr ch opts pending-forms)
|
|
(read-tagged (doto rdr (unread ch)) ch opts pending-forms)) ;; ctor reader is implemented as a tagged literal
|
|
(err/throw-eof-at-dispatch rdr)))
|
|
|
|
(defn- read-unmatched-delimiter
|
|
[rdr ch opts pending-forms]
|
|
(err/throw-unmatch-delimiter rdr ch))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; readers
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defn read-regex
|
|
[^not-native rdr ch opts pending-forms]
|
|
(let [sb (StringBuffer.)]
|
|
(loop [ch (read-char rdr)]
|
|
(if (identical? \" ch)
|
|
(re-pattern (str sb))
|
|
(if (nil? ch)
|
|
(err/throw-eof-reading rdr :regex sb)
|
|
(do
|
|
(.append sb ch )
|
|
(when (identical? \\ ch)
|
|
(let [ch (read-char rdr)]
|
|
(if (nil? ch)
|
|
(err/throw-eof-reading rdr :regex sb))
|
|
(.append sb ch)))
|
|
(recur (read-char rdr))))))))
|
|
|
|
(defn- read-unicode-char
|
|
([token offset length base]
|
|
(let [l (+ offset length)]
|
|
(when-not (== (count token) l)
|
|
(err/throw-invalid-unicode-literal nil token))
|
|
(loop [i offset uc 0]
|
|
(if (== i l)
|
|
(js/String.fromCharCode uc)
|
|
(let [d (char-code (nth token i) base)]
|
|
(if (== d -1)
|
|
(err/throw-invalid-unicode-digit-in-token nil (nth token i) token)
|
|
(recur (inc i) (+ d (* uc base)))))))))
|
|
|
|
([^not-native rdr initch base length exact?]
|
|
(loop [i 1 uc (char-code initch base)]
|
|
(if (== uc -1)
|
|
(err/throw-invalid-unicode-digit rdr initch)
|
|
(if-not (== i length)
|
|
(let [ch (peek-char rdr)]
|
|
(if (or (whitespace? ch)
|
|
(macros ch)
|
|
(nil? ch))
|
|
(if exact?
|
|
(err/throw-invalid-unicode-len rdr i length)
|
|
(js/String.fromCharCode uc))
|
|
(let [d (char-code ch base)]
|
|
(read-char rdr)
|
|
(if (== d -1)
|
|
(err/throw-invalid-unicode-digit rdr ch)
|
|
(recur (inc i) (+ d (* uc base)))))))
|
|
(js/String.fromCharCode uc))))))
|
|
|
|
(def ^:private ^:const upper-limit (.charCodeAt \uD7ff 0))
|
|
(def ^:private ^:const lower-limit (.charCodeAt \uE000 0))
|
|
|
|
(defn- valid-octal? [token base]
|
|
(<= (js/parseInt token base) 0377))
|
|
|
|
(defn- read-char*
|
|
"Read in a character literal"
|
|
[^not-native rdr backslash opts pending-forms]
|
|
(let [ch (read-char rdr)]
|
|
(if-not (nil? ch)
|
|
(let [token (if (or (macro-terminating? ch)
|
|
(whitespace? ch))
|
|
(str ch)
|
|
(read-token rdr :character ch))
|
|
token-len (. token -length)]
|
|
(cond
|
|
|
|
(== 1 token-len) (.charAt token 0) ;;; no char type - so can't ensure/cache char
|
|
|
|
(= token "newline") \newline
|
|
(= token "space") \space
|
|
(= token "tab") \tab
|
|
(= token "backspace") \backspace
|
|
(= token "formfeed") \formfeed
|
|
(= token "return") \return
|
|
|
|
(gstring/startsWith token "u")
|
|
(let [c (read-unicode-char token 1 4 16)
|
|
ic (.charCodeAt c 0)]
|
|
(if (and (> ic upper-limit)
|
|
(< ic lower-limit))
|
|
(err/throw-invalid-character-literal rdr (.toString ic 16))
|
|
c))
|
|
|
|
(gstring/startsWith token "o")
|
|
(let [len (dec token-len)]
|
|
(if (> len 3)
|
|
(err/throw-invalid-octal-len rdr token)
|
|
(let [offset 1
|
|
base 8
|
|
uc (read-unicode-char token offset len base)]
|
|
(if-not (valid-octal? (subs token offset) base)
|
|
(err/throw-bad-octal-number rdr)
|
|
uc))))
|
|
|
|
:else (err/throw-unsupported-character rdr token)))
|
|
(err/throw-eof-in-character rdr))))
|
|
|
|
(defn- starting-line-col-info [^not-native rdr]
|
|
(when (indexing-reader? rdr)
|
|
[(get-line-number rdr) (int (dec (get-column-number rdr)))]))
|
|
|
|
(defn- ending-line-col-info [^not-native rdr]
|
|
(when (indexing-reader? rdr)
|
|
[(get-line-number rdr) (get-column-number rdr)]))
|
|
|
|
(defonce ^:private READ_EOF (js/Object.))
|
|
(defonce ^:private READ_FINISHED (js/Object.))
|
|
|
|
(def ^:dynamic *read-delim* false)
|
|
|
|
(defn- read-delimited-internal [kind delim rdr opts pending-forms]
|
|
(let [[start-line start-column] (starting-line-col-info rdr)
|
|
delim (char delim)]
|
|
(loop [a (transient [])]
|
|
(let [form (read* rdr false READ_EOF delim opts pending-forms)]
|
|
(if (identical? form READ_FINISHED)
|
|
(persistent! a)
|
|
(if (identical? form READ_EOF)
|
|
(err/throw-eof-delimited rdr kind start-line start-column (count a))
|
|
(recur (conj! a form))))))))
|
|
|
|
(defn- read-delimited
|
|
"Reads and returns a collection ended with delim"
|
|
[kind delim rdr opts pending-forms]
|
|
(binding [*read-delim* true]
|
|
(read-delimited-internal kind delim rdr opts pending-forms)))
|
|
|
|
(defn- read-list
|
|
"Read in a list, including its location if the reader is an indexing reader"
|
|
[rdr _ opts pending-forms]
|
|
(let [[start-line start-column] (starting-line-col-info rdr)
|
|
the-list (read-delimited :list \) rdr opts pending-forms)
|
|
[end-line end-column] (ending-line-col-info rdr)]
|
|
(with-meta (if (empty? the-list)
|
|
'()
|
|
(apply list the-list))
|
|
(when start-line
|
|
(merge
|
|
(when-let [file (get-file-name rdr)]
|
|
{:file file})
|
|
{:line start-line
|
|
:column start-column
|
|
:end-line end-line
|
|
:end-column end-column})))))
|
|
|
|
(defn- read-vector
|
|
"Read in a vector, including its location if the reader is an indexing reader"
|
|
[rdr _ opts pending-forms]
|
|
(let [[start-line start-column] (starting-line-col-info rdr)
|
|
the-vector (read-delimited :vector \] rdr opts pending-forms)
|
|
[end-line end-column] (ending-line-col-info rdr)]
|
|
(with-meta the-vector
|
|
(when start-line
|
|
(merge
|
|
(when-let [file (get-file-name rdr)]
|
|
{:file file})
|
|
{:line start-line
|
|
:column start-column
|
|
:end-line end-line
|
|
:end-column end-column})))))
|
|
|
|
(defn- read-map
|
|
"Read in a map, including its location if the reader is an indexing reader"
|
|
[rdr _ opts pending-forms]
|
|
(let [[start-line start-column] (starting-line-col-info rdr)
|
|
the-map (read-delimited :map \} rdr opts pending-forms)
|
|
map-count (count the-map)
|
|
ks (take-nth 2 the-map)
|
|
key-set (set ks)
|
|
[end-line end-column] (ending-line-col-info rdr)]
|
|
(when (odd? map-count)
|
|
(err/throw-odd-map rdr start-line start-column the-map))
|
|
(when-not (= (count key-set) (count ks))
|
|
(err/throw-dup-keys rdr :map ks))
|
|
(with-meta
|
|
(if (<= map-count (* 2 (.-HASHMAP-THRESHOLD cljs.core/PersistentArrayMap)))
|
|
(.fromArray cljs.core/PersistentArrayMap (to-array the-map) true true)
|
|
(.fromArray cljs.core/PersistentHashMap (to-array the-map) true))
|
|
(when start-line
|
|
(merge
|
|
(when-let [file (get-file-name rdr)]
|
|
{:file file})
|
|
{:line start-line
|
|
:column start-column
|
|
:end-line end-line
|
|
:end-column end-column})))))
|
|
|
|
(defn- read-number
|
|
[^not-native rdr initch]
|
|
(loop [sb (doto (StringBuffer.) (.append initch))
|
|
ch (read-char rdr)]
|
|
(if (or (whitespace? ch) (macros ch) (nil? ch))
|
|
(let [s (str sb)]
|
|
(unread rdr ch)
|
|
(or (match-number s)
|
|
(err/throw-invalid-number rdr s)))
|
|
(recur (doto sb (.append ch)) (read-char rdr)))))
|
|
|
|
(defn- escape-char [sb ^not-native 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 (js/parseInt (int ch) 16))
|
|
(err/throw-invalid-unicode-escape rdr ch)
|
|
(read-unicode-char rdr ch 16 4 true)))
|
|
(if (numeric? ch)
|
|
(let [ch (read-unicode-char rdr ch 8 3 false)]
|
|
(if (> (int ch) 0377)
|
|
(err/throw-bad-octal-number rdr)
|
|
ch))
|
|
(err/throw-bad-escape-char rdr ch)))))
|
|
|
|
(defn- read-string*
|
|
[^not-native reader _ opts pending-forms]
|
|
(loop [sb (StringBuffer.)
|
|
ch (read-char reader)]
|
|
(if (nil? ch)
|
|
(err/throw-eof-reading reader :string \" sb)
|
|
(case ch
|
|
\\ (recur (doto sb (.append (escape-char sb reader)))
|
|
(read-char reader))
|
|
\" (str sb)
|
|
(recur (doto sb (.append ch)) (read-char reader))))))
|
|
|
|
(defn- loc-info [rdr line column]
|
|
(when-not (nil? line)
|
|
(let [file (get-file-name rdr)
|
|
filem (when-not (nil? file) {:file file})
|
|
[end-line end-column] (ending-line-col-info rdr)
|
|
lcm {:line line
|
|
:column column
|
|
:end-line end-line
|
|
:end-column end-column}]
|
|
(merge filem lcm))))
|
|
|
|
(defn- read-symbol
|
|
[rdr initch]
|
|
(let [[line column] (starting-line-col-info rdr)
|
|
token (read-token rdr :symbol initch)]
|
|
(when-not (nil? token)
|
|
(case token
|
|
|
|
;; special symbols
|
|
"nil" nil
|
|
"true" true
|
|
"false" false
|
|
"/" '/
|
|
|
|
(let [^not-native p (parse-symbol token)]
|
|
(if-not (nil? p)
|
|
(let [^not-native sym (symbol (-nth p 0) (-nth p 1))]
|
|
(-with-meta sym (loc-info rdr line column)))
|
|
(err/throw-invalid rdr :symbol token)))))))
|
|
|
|
(def ^:dynamic *alias-map*
|
|
"Map from ns alias to ns, if non-nil, it will be used to resolve read-time
|
|
ns aliases.
|
|
|
|
Defaults to nil"
|
|
nil)
|
|
|
|
(defn- resolve-alias [sym]
|
|
(get *alias-map* sym))
|
|
|
|
(defn- resolve-ns [sym]
|
|
(or (resolve-alias sym)
|
|
(when-let [ns (find-ns sym)]
|
|
(symbol (ns-name ns)))))
|
|
|
|
(defn- read-keyword
|
|
[^not-native reader initch opts pending-forms]
|
|
(let [ch (read-char reader)]
|
|
(if-not (whitespace? ch)
|
|
(let [token (read-token reader :keyword ch)
|
|
^not-native s (parse-symbol token)]
|
|
(if-not (nil? s)
|
|
(let [ns (-nth s 0)
|
|
name (-nth s 1)]
|
|
(if (identical? \: (.charAt token 0))
|
|
(if-not (nil? ns)
|
|
(if-let [ns (resolve-alias (symbol (subs ns 1)))]
|
|
(keyword (str ns) name)
|
|
(err/throw-invalid reader :keyword (str \: token)))
|
|
(if-let [ns *ns*]
|
|
(keyword (str ns) (subs name 1))
|
|
(err/reader-error reader "Invalid token: :" token)))
|
|
(keyword ns name)))
|
|
(err/throw-invalid reader :keyword (str \: token))))
|
|
(err/throw-single-colon reader))))
|
|
|
|
(defn- wrapping-reader
|
|
"Returns a function which wraps a reader in a call to sym"
|
|
[sym]
|
|
(fn [rdr _ opts pending-forms]
|
|
(list sym (read* rdr true nil opts pending-forms))))
|
|
|
|
(defn- read-meta
|
|
"Read metadata and return the following object with the metadata applied"
|
|
[rdr _ opts pending-forms]
|
|
(log-source rdr
|
|
(let [[line column] (starting-line-col-info rdr)
|
|
m (desugar-meta (read* rdr true nil opts pending-forms))]
|
|
(when-not (map? m)
|
|
(err/throw-bad-metadata rdr m))
|
|
(let [o (read* rdr true nil opts pending-forms)]
|
|
(if (implements? IMeta o)
|
|
(let [m (if (and line (seq? o))
|
|
(assoc m :line line :column column)
|
|
m)]
|
|
(if (implements? IWithMeta o)
|
|
(with-meta o (merge (meta o) m))
|
|
(reset-meta! o m)))
|
|
(err/throw-bad-metadata-target rdr o))))))
|
|
|
|
(defn- read-set
|
|
[rdr _ opts pending-forms]
|
|
(let [[start-line start-column] (starting-line-col-info rdr)
|
|
;; subtract 1 from start-column so it includes the # in the leading #{
|
|
start-column (if start-column (int (dec start-column)))
|
|
coll (read-delimited :set \} rdr opts pending-forms)
|
|
the-set (set coll)
|
|
[end-line end-column] (ending-line-col-info rdr)]
|
|
(when-not (= (count coll) (count the-set))
|
|
(err/reader-error rdr (err/throw-dup-keys rdr :set coll)))
|
|
(with-meta the-set
|
|
(when start-line
|
|
(merge
|
|
(when-let [file (get-file-name rdr)]
|
|
{:file file})
|
|
{:line start-line
|
|
:column start-column
|
|
:end-line end-line
|
|
:end-column end-column})))))
|
|
|
|
(defn- read-discard
|
|
"Read and discard the first object from rdr"
|
|
[rdr _ opts pending-forms]
|
|
(doto rdr
|
|
(read* true nil opts pending-forms)))
|
|
|
|
(defn- read-symbolic-value
|
|
[rdr _ opts pending-forms]
|
|
(let [sym (read* rdr true nil opts pending-forms)]
|
|
(case sym
|
|
|
|
NaN js/Number.NaN
|
|
-Inf js/Number.NEGATIVE_INFINITY
|
|
Inf js/Number.POSITIVE_INFINITY
|
|
|
|
(err/reader-error rdr (str "Invalid token: ##" sym)))))
|
|
|
|
(def ^:private RESERVED_FEATURES #{:else :none})
|
|
|
|
(defn- has-feature?
|
|
[rdr feature opts]
|
|
(if (keyword? feature)
|
|
(or (= :default feature) (contains? (get opts :features) feature))
|
|
(err/reader-error rdr "Feature should be a keyword: " feature)))
|
|
|
|
(defn- check-eof-error
|
|
[form rdr first-line]
|
|
(when (identical? form READ_EOF)
|
|
(err/throw-eof-error rdr (and (< first-line 0) first-line))))
|
|
|
|
(defn- check-reserved-features
|
|
[rdr form]
|
|
(when (get RESERVED_FEATURES form)
|
|
(err/reader-error rdr "Feature name " form " is reserved")))
|
|
|
|
(defn- check-invalid-read-cond
|
|
[form rdr first-line]
|
|
(when (identical? form READ_FINISHED)
|
|
(if (< first-line 0)
|
|
(err/reader-error rdr "read-cond requires an even number of forms")
|
|
(err/reader-error rdr "read-cond starting on line " first-line " requires an even number of forms"))))
|
|
|
|
(defn- read-suppress
|
|
"Read next form and suppress. Return nil or READ_FINISHED."
|
|
[first-line rdr opts pending-forms]
|
|
(binding [*suppress-read* true]
|
|
(let [form (read* rdr false READ_EOF \) opts pending-forms)]
|
|
(check-eof-error form rdr first-line)
|
|
(when (identical? form READ_FINISHED)
|
|
READ_FINISHED))))
|
|
|
|
(defonce ^:private NO_MATCH (js/Object.))
|
|
|
|
(defn- match-feature
|
|
"Read next feature. If matched, read next form and return.
|
|
Otherwise, read and skip next form, returning READ_FINISHED or nil."
|
|
[first-line rdr opts pending-forms]
|
|
(let [feature (read* rdr false READ_EOF \) opts pending-forms)]
|
|
(check-eof-error feature rdr first-line)
|
|
(if (= feature READ_FINISHED)
|
|
READ_FINISHED
|
|
(do
|
|
(check-reserved-features rdr feature)
|
|
(if (has-feature? rdr feature opts)
|
|
;; feature matched, read selected form
|
|
(doto (read* rdr false READ_EOF \) opts pending-forms)
|
|
(check-eof-error rdr first-line)
|
|
(check-invalid-read-cond rdr first-line))
|
|
;; feature not matched, ignore next form
|
|
(or (read-suppress first-line rdr opts pending-forms)
|
|
NO_MATCH))))))
|
|
|
|
(defn- read-cond-delimited
|
|
[rdr splicing opts pending-forms]
|
|
(let [first-line (if (indexing-reader? rdr) (get-line-number rdr) -1)
|
|
result (loop [matched NO_MATCH
|
|
finished nil]
|
|
(cond
|
|
;; still looking for match, read feature+form
|
|
(identical? matched NO_MATCH)
|
|
(let [match (match-feature first-line rdr opts pending-forms)]
|
|
(if (identical? match READ_FINISHED)
|
|
READ_FINISHED
|
|
(recur match nil)))
|
|
|
|
;; found match, just read and ignore the rest
|
|
(not (identical? finished READ_FINISHED))
|
|
(recur matched (read-suppress first-line rdr opts pending-forms))
|
|
|
|
:else
|
|
matched))]
|
|
(if (identical? result READ_FINISHED)
|
|
rdr
|
|
(if splicing
|
|
(do
|
|
(if (implements? ISequential result)
|
|
(do
|
|
(garray/insertArrayAt pending-forms (to-array result) 0)
|
|
rdr)
|
|
(err/reader-error rdr "Spliced form list in read-cond-splicing must implement ISequential")))
|
|
result))))
|
|
|
|
(defn- read-cond
|
|
[^not-native rdr _ opts pending-forms]
|
|
(when (not (and opts (#{:allow :preserve} (:read-cond opts))))
|
|
(throw (ex-info "Conditional read not allowed"
|
|
{:type :runtime-exception})))
|
|
(if-let [ch (read-char rdr)]
|
|
(let [splicing (= ch \@)
|
|
ch (if splicing (read-char rdr) ch)]
|
|
(when splicing
|
|
(when-not *read-delim*
|
|
(err/reader-error rdr "cond-splice not in list")))
|
|
(if-let [ch (if (whitespace? ch) (read-past whitespace? rdr) ch)]
|
|
(if (not= ch \()
|
|
(throw (ex-info "read-cond body must be a list"
|
|
{:type :runtime-exception}))
|
|
(binding [*suppress-read* (or *suppress-read* (= :preserve (:read-cond opts)))]
|
|
(if *suppress-read*
|
|
(reader-conditional (read-list rdr ch opts pending-forms) splicing)
|
|
(read-cond-delimited rdr splicing opts pending-forms))))
|
|
(err/throw-eof-in-character rdr)))
|
|
(err/throw-eof-in-character rdr)))
|
|
|
|
(def ^:private ^:dynamic arg-env nil)
|
|
|
|
(defn- garg
|
|
"Get a symbol for an anonymous ?argument?"
|
|
[n]
|
|
(symbol (str (if (== -1 n) "rest" (str "p" n))
|
|
"__" (next-id) "#")))
|
|
|
|
(defn- read-fn
|
|
[rdr _ opts pending-forms]
|
|
(if arg-env
|
|
(throw (ex-info "Nested #()s are not allowed" {:type :illegal-state})))
|
|
(binding [arg-env (sorted-map)]
|
|
(let [form (read* (doto rdr (unread \()) true nil opts pending-forms) ;; this sets bindings
|
|
rargs (rseq arg-env)
|
|
args (if rargs
|
|
(let [higharg (key (first rargs))]
|
|
(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))
|
|
args)]
|
|
args))
|
|
[])]
|
|
(list 'fn* args form))))
|
|
|
|
(defn- register-arg
|
|
"Registers an argument to the arg-env"
|
|
[n]
|
|
(if arg-env
|
|
(if-let [ret (arg-env n)]
|
|
ret
|
|
(let [g (garg n)]
|
|
(set! arg-env (assoc arg-env n g))
|
|
g))
|
|
(throw (ex-info "Arg literal not in #()"
|
|
{:type :illegal-state})))) ;; should never hit this
|
|
|
|
(declare read-symbol)
|
|
|
|
(defn- read-arg
|
|
[^not-native rdr pct opts pending-forms]
|
|
(if (nil? arg-env)
|
|
(read-symbol rdr pct)
|
|
(let [ch (peek-char rdr)]
|
|
(cond
|
|
(or (whitespace? ch)
|
|
(macro-terminating? ch)
|
|
(nil? ch))
|
|
(register-arg 1)
|
|
|
|
(= ch \&)
|
|
(do (read-char rdr)
|
|
(register-arg -1))
|
|
|
|
:else
|
|
(let [n (read* rdr true nil opts pending-forms)]
|
|
(if-not (integer? n)
|
|
(throw (ex-info "Arg literal must be %, %& or %integer"
|
|
{:type :illegal-state}))
|
|
(register-arg n)))))))
|
|
|
|
(def ^:private ^:dynamic gensym-env nil)
|
|
|
|
(defn- read-unquote
|
|
[^not-native rdr comma opts pending-forms]
|
|
(if-let [ch (peek-char rdr)]
|
|
(if (= \@ ch)
|
|
((wrapping-reader 'clojure.core/unquote-splicing) (doto rdr read-char) \@ opts pending-forms)
|
|
((wrapping-reader 'clojure.core/unquote) rdr \~ opts pending-forms))))
|
|
|
|
(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
|
|
"Expand a list by resolving its syntax quotes and unquotes"
|
|
[s]
|
|
(loop [s (seq s) r (transient [])]
|
|
(if s
|
|
(let [item (first s)
|
|
ret (conj! r
|
|
(cond
|
|
(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
|
|
"Flatten a map into a seq of alternate keys and values"
|
|
[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 (ex-info "Gensym literal not in syntax-quote"
|
|
{:type :illegal-state})))
|
|
(or (get gensym-env sym)
|
|
(let [gs (symbol (str (subs (name sym)
|
|
0 (dec (count (name sym))))
|
|
"__" (next-id) "__auto__"))]
|
|
(set! gensym-env (assoc gensym-env sym gs))
|
|
gs)))
|
|
|
|
(defn- add-meta [form ret]
|
|
(if (and (implements? IWithMeta form)
|
|
(seq (dissoc (meta form) :line :column :end-line :end-column :file :source)))
|
|
(list 'cljs.core/with-meta ret (syntax-quote* (meta form)))
|
|
ret))
|
|
|
|
(defn- syntax-quote-coll [type coll]
|
|
(let [res (list 'cljs.core/sequence
|
|
(cons 'cljs.core/concat
|
|
(expand-list coll)))]
|
|
(if type
|
|
(list 'cljs.core/apply type res)
|
|
res)))
|
|
|
|
(defn map-func
|
|
"Decide which map type to use, array-map if less than 16 elements"
|
|
[coll]
|
|
(if (>= (count coll) 16)
|
|
'cljs.core/hash-map
|
|
'cljs.core/array-map))
|
|
|
|
(defn bool? [x]
|
|
(or (instance? js/Boolean x)
|
|
(true? x)
|
|
(false? x)))
|
|
|
|
(defn ^:dynamic resolve-symbol
|
|
"Resolve a symbol s into its fully qualified namespace version"
|
|
[s]
|
|
(throw (ex-info "resolve-symbol is not implemented" {:sym s})))
|
|
|
|
(defn- syntax-quote* [form]
|
|
(->>
|
|
(cond
|
|
(special-symbol? form) (list 'quote form)
|
|
|
|
(symbol? form)
|
|
(list 'quote
|
|
(if (and (not (namespace form))
|
|
(gstring/endsWith (name form) "#"))
|
|
(register-gensym form)
|
|
(let [sym (str form)]
|
|
(if (gstring/endsWith sym ".")
|
|
(let [csym (symbol (subs sym 0 (dec (count sym))))]
|
|
(symbol (str (resolve-symbol csym) ".")))
|
|
(resolve-symbol form)))))
|
|
|
|
(unquote? form) (second form)
|
|
(unquote-splicing? form) (throw (ex-info "unquote-splice not in list"
|
|
{:type :illegal-state}))
|
|
|
|
(coll? form)
|
|
(cond
|
|
|
|
(implements? IRecord form) form
|
|
(map? form) (syntax-quote-coll (map-func form) (flatten-map form))
|
|
(vector? form) (list 'cljs.core/vec (syntax-quote-coll nil form))
|
|
(set? form) (syntax-quote-coll 'cljs.core/hash-set form)
|
|
(or (seq? form) (list? form))
|
|
(let [seq (seq form)]
|
|
(if seq
|
|
(syntax-quote-coll nil seq)
|
|
'(cljs.core/list)))
|
|
|
|
:else (throw (ex-info "Unknown Collection type"
|
|
{:type :unsupported-operation})))
|
|
|
|
(or (keyword? form)
|
|
(number? form)
|
|
(string? form)
|
|
(nil? form)
|
|
(bool? form)
|
|
(instance? js/RegExp form))
|
|
form
|
|
|
|
:else (list 'quote form))
|
|
(add-meta form)))
|
|
|
|
(defn- read-syntax-quote
|
|
[rdr backquote opts pending-forms]
|
|
(binding [gensym-env {}]
|
|
(-> (read* rdr true nil opts pending-forms)
|
|
syntax-quote*)))
|
|
|
|
(defn- read-namespaced-map
|
|
[rdr _ opts pending-forms]
|
|
(let [token (read-token rdr :namespaced-map (read-char rdr))]
|
|
(if-let [ns (cond
|
|
(= token ":")
|
|
(ns-name *ns*)
|
|
|
|
(= \: (first token))
|
|
(some-> token (subs 1) parse-symbol second' symbol resolve-ns)
|
|
|
|
:else
|
|
(some-> token parse-symbol second'))]
|
|
|
|
(let [ch (read-past whitespace? rdr)]
|
|
(if (identical? ch \{)
|
|
(let [items (read-delimited :namespaced-map \} rdr opts pending-forms)]
|
|
(when (odd? (count items))
|
|
(err/throw-odd-map rdr nil nil items))
|
|
(let [keys (namespace-keys (str ns) (take-nth 2 items))
|
|
vals (take-nth 2 (rest items))]
|
|
(when-not (= (count (set keys)) (count keys))
|
|
(err/throw-dup-keys rdr :namespaced-map keys))
|
|
(zipmap keys vals)))
|
|
(err/throw-ns-map-no-map rdr token)))
|
|
(err/throw-bad-ns rdr token))))
|
|
|
|
(defn- macros [ch]
|
|
(case ch
|
|
\" read-string*
|
|
\: read-keyword
|
|
\; read-comment
|
|
\' (wrapping-reader 'quote)
|
|
\@ (wrapping-reader 'clojure.core/deref)
|
|
\^ read-meta
|
|
\` read-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
|
|
nil))
|
|
|
|
(defn- dispatch-macros [ch]
|
|
(case ch
|
|
\^ read-meta ;; deprecated
|
|
\' (wrapping-reader 'var)
|
|
\( read-fn
|
|
\{ read-set
|
|
\< (throwing-reader "Unreadable form")
|
|
\= (throwing-reader "read-eval not supported")
|
|
\" read-regex
|
|
\! read-comment
|
|
\_ read-discard
|
|
\? read-cond
|
|
\: read-namespaced-map
|
|
\# read-symbolic-value
|
|
nil))
|
|
|
|
(defn- read-tagged [^not-native rdr initch opts pending-forms]
|
|
(let [tag (read* rdr true nil opts pending-forms)]
|
|
(if-not (symbol? tag)
|
|
(err/throw-bad-reader-tag rdr tag))
|
|
(if *suppress-read*
|
|
(tagged-literal tag (read* rdr true nil opts pending-forms))
|
|
(if-let [f (or (*data-readers* tag)
|
|
(default-data-readers tag))]
|
|
(f (read* rdr true nil opts pending-forms))
|
|
(if-let [f *default-data-reader-fn*]
|
|
(f tag (read* rdr true nil opts pending-forms))
|
|
(err/throw-unknown-reader-tag rdr tag))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Public API
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(def ^:dynamic *data-readers*
|
|
"Map from reader tag symbols to data reader Vars.
|
|
Reader tags without namespace qualifiers are reserved for Clojure.
|
|
This light version of tools.reader has no implementation for default
|
|
reader tags such as #inst and #uuid."
|
|
{})
|
|
|
|
(def ^:dynamic *default-data-reader-fn*
|
|
"When no data reader is found for a tag and *default-data-reader-fn*
|
|
is non-nil, it will be called with two arguments, the tag and the value.
|
|
If *default-data-reader-fn* is nil (the default value), an exception
|
|
will be thrown for the unknown tag."
|
|
nil)
|
|
|
|
(def ^:dynamic *suppress-read* false)
|
|
|
|
(def default-data-readers
|
|
"Default map of data reader functions provided by Clojure.
|
|
May be overridden by binding *data-readers*"
|
|
{})
|
|
|
|
(defn- read*-internal
|
|
[^not-native reader ^boolean eof-error? sentinel return-on opts pending-forms]
|
|
(loop []
|
|
(log-source reader
|
|
(if-not ^boolean (garray/isEmpty pending-forms)
|
|
(let [form (aget pending-forms 0)]
|
|
(garray/removeAt pending-forms 0)
|
|
form)
|
|
(let [ch (read-char reader)]
|
|
(cond
|
|
(whitespace? ch) (recur)
|
|
(nil? ch) (if eof-error? (err/throw-eof-error reader nil) sentinel)
|
|
(identical? ch return-on) READ_FINISHED
|
|
(number-literal? reader ch) (read-number reader ch)
|
|
:else (let [f (macros ch)]
|
|
(if-not (nil? f)
|
|
(let [res (f reader ch opts pending-forms)]
|
|
(if (identical? res reader)
|
|
(recur)
|
|
res))
|
|
(read-symbol reader ch)))))))))
|
|
|
|
(defn- read*
|
|
([reader eof-error? sentinel opts pending-forms]
|
|
(read* reader eof-error? sentinel nil opts pending-forms))
|
|
([^not-native reader eof-error? sentinel return-on opts pending-forms]
|
|
(try
|
|
(read*-internal reader eof-error? sentinel return-on opts pending-forms)
|
|
(catch js/Error e
|
|
(if (ex-info? e)
|
|
(let [d (ex-data e)]
|
|
(if (= :reader-exception (:type d))
|
|
(throw e)
|
|
(throw (ex-info (.-message e)
|
|
(merge {:type :reader-exception}
|
|
d
|
|
(if (indexing-reader? reader)
|
|
{:line (get-line-number reader)
|
|
:column (get-column-number reader)
|
|
:file (get-file-name reader)}))
|
|
e))))
|
|
(throw (ex-info (.-message e)
|
|
(merge {:type :reader-exception}
|
|
(if (indexing-reader? reader)
|
|
{:line (get-line-number reader)
|
|
:column (get-column-number reader)
|
|
:file (get-file-name reader)}))
|
|
e)))))))
|
|
|
|
(defn read
|
|
"Reads the first object from an IPushbackReader.
|
|
Returns the object read. If EOF, throws if eof-error? is true.
|
|
Otherwise returns sentinel. If no stream is providen, *in* will be used.
|
|
|
|
Opts is a persistent map with valid keys:
|
|
:read-cond - :allow to process reader conditionals, or
|
|
:preserve to keep all branches
|
|
:features - persistent set of feature keywords for reader conditionals
|
|
:eof - on eof, return value unless :eofthrow, then throw.
|
|
if not specified, will throw
|
|
|
|
To read data structures only, use clojure.tools.reader.edn/read
|
|
|
|
Note that the function signature of clojure.tools.reader/read and
|
|
clojure.tools.reader.edn/read is not the same for eof-handling"
|
|
{:arglists '([reader] [opts reader] [reader eof-error? eof-value])}
|
|
([reader] (read reader true nil))
|
|
([{eof :eof :as opts :or {eof :eofthrow}} reader] (read* reader (= eof :eofthrow) eof nil opts (to-array [])))
|
|
([reader eof-error? sentinel] (read* reader eof-error? sentinel nil {} (to-array []))))
|
|
|
|
(defn read-string
|
|
"Reads one object from the string s.
|
|
Returns nil when s is nil or empty.
|
|
|
|
To read data structures only, use clojure.tools.reader.edn/read-string
|
|
|
|
Note that the function signature of clojure.tools.reader/read-string and
|
|
clojure.tools.reader.edn/read-string is not the same for eof-handling"
|
|
([s]
|
|
(read-string {} s))
|
|
([opts s]
|
|
(when (and s (not (identical? s "")))
|
|
(read opts (string-push-back-reader s)))))
|
|
|
|
(defn read+string
|
|
"Like read, and taking the same args. reader must be a SourceLoggingPushbackReader.
|
|
Returns a vector containing the object read and the (whitespace-trimmed) string read."
|
|
([reader & args]
|
|
(let [buf (fn [reader] (str (:buffer @(.-frames reader))))
|
|
offset (count (buf reader))
|
|
o (log-source reader (if (= 1 (count args))
|
|
(read (first args) reader)
|
|
(apply read reader args)))
|
|
s (.trim (subs (buf reader) offset))]
|
|
[o s])))
|