/
analyzer.clj
1030 lines (936 loc) · 43.7 KB
/
analyzer.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
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
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
; 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.
(set! *warn-on-reflection* true)
(ns cljs.analyzer
(:refer-clojure :exclude [macroexpand-1])
(:require [clojure.java.io :as io]
[clojure.string :as string]
[cljs.tagged-literals :as tags])
(:import java.lang.StringBuilder))
(declare resolve-var)
(declare resolve-existing-var)
(declare warning)
(def ^:dynamic *cljs-warn-on-undeclared* false)
(declare confirm-bindings)
(declare ^:dynamic *cljs-file*)
;; to resolve keywords like ::foo - the namespace
;; must be determined during analysis - the reader
;; did not know
;; TODO: probably remove, see bottom of file - David
(def ^:dynamic *reader-ns-name* (gensym))
(def ^:dynamic *reader-ns* (create-ns *reader-ns-name*))
(defonce namespaces (atom '{cljs.core {:name cljs.core}
cljs.user {:name cljs.user}}))
(defn reset-namespaces! []
(reset! namespaces
'{cljs.core {:name cljs.core}
cljs.user {:name cljs.user}}))
(defn get-namespace [key]
(@namespaces key))
(defn set-namespace [key val]
(swap! namespaces assoc key val))
(def ^:dynamic *cljs-ns* 'cljs.user)
(def ^:dynamic *cljs-file* nil)
(def ^:dynamic *cljs-warn-on-redef* true)
(def ^:dynamic *cljs-warn-on-dynamic* true)
(def ^:dynamic *cljs-warn-on-fn-var* true)
(def ^:dynamic *cljs-warn-fn-arity* true)
(def ^:dynamic *cljs-warn-fn-deprecated* true)
(def ^:dynamic *cljs-warn-protocol-deprecated* true)
(def ^:dynamic *unchecked-if* (atom false))
(def ^:dynamic *cljs-static-fns* false)
(def ^:dynamic *cljs-macros-path* "/cljs/core")
(def ^:dynamic *cljs-macros-is-classpath* true)
(def -cljs-macros-loaded (atom false))
(defmacro no-warn [& body]
`(binding [*cljs-warn-on-undeclared* false
*cljs-warn-on-redef* false
*cljs-warn-on-dynamic* false
*cljs-warn-on-fn-var* false
*cljs-warn-fn-arity* false
*cljs-warn-fn-deprecated* false]
~@body))
(defn get-line [x env]
(or (-> x meta :line) (:line env)))
(defn get-col [x env]
(or (-> x meta :column) (:column env)))
(defn load-core []
(when (not @-cljs-macros-loaded)
(reset! -cljs-macros-loaded true)
(if *cljs-macros-is-classpath*
(load *cljs-macros-path*)
(load-file *cljs-macros-path*))))
(defmacro with-core-macros
[path & body]
`(do
(when (not= *cljs-macros-path* ~path)
(reset! -cljs-macros-loaded false))
(binding [*cljs-macros-path* ~path]
~@body)))
(defmacro with-core-macros-file
[path & body]
`(do
(when (not= *cljs-macros-path* ~path)
(reset! -cljs-macros-loaded false))
(binding [*cljs-macros-path* ~path
*cljs-macros-is-classpath* false]
~@body)))
(defn empty-env []
{:ns (@namespaces *cljs-ns*) :context :statement :locals {}})
(defmacro ^:private debug-prn
[& args]
`(.println System/err (str ~@args)))
(defn source-info
([env]
(when-let [line (:line env)]
{:file *cljs-file*
:line (get-line name env)
:column (get-col name env)}))
([name env]
{:file *cljs-file*
:line (get-line name env)
:column (get-col name env)}))
(defn message [env s]
(str s (when (:line env)
(str " at line " (:line env) " " *cljs-file*))))
(defn warning [env s]
(binding [*out* *err*]
(println (message env s))))
(defn error
([env s] (error env s nil))
([env s cause]
(ex-info (message env s)
(assoc (source-info env) :tag :cljs/analysis-error)
cause)))
(defn analysis-error? [ex]
(= :cljs/analysis-error (:tag (ex-data ex))))
(defmacro wrapping-errors [env & body]
`(try
~@body
(catch Throwable err#
(if (analysis-error? err#)
(throw err#)
(throw (error ~env (.getMessage err#) err#))))))
(defn confirm-var-exists [env prefix suffix]
(when *cljs-warn-on-undeclared*
(let [crnt-ns (-> env :ns :name)]
(when (= prefix crnt-ns)
(when-not (-> @namespaces crnt-ns :defs suffix)
(warning env
(str "WARNING: Use of undeclared Var " prefix "/" suffix)))))))
(defn resolve-ns-alias [env name]
(let [sym (symbol name)]
(get (:requires (:ns env)) sym sym)))
(defn core-name?
"Is sym visible from core in the current compilation namespace?"
[env sym]
(and (get (:defs (@namespaces 'cljs.core)) sym)
(not (contains? (-> env :ns :excludes) sym))))
(defn resolve-var
"Resolve a var. Accepts a side-effecting confirm fn for producing
warnings about unresolved vars."
([env sym] (resolve-var env sym nil))
([env sym confirm]
(if (= (namespace sym) "js")
{:name sym :ns 'js}
(let [s (str sym)
lb (-> env :locals sym)]
(cond
lb lb
(namespace sym)
(let [ns (namespace sym)
ns (if (= "clojure.core" ns) "cljs.core" ns)
full-ns (resolve-ns-alias env ns)]
(when confirm
(confirm env full-ns (symbol (name sym))))
(merge (get-in @namespaces [full-ns :defs (symbol (name sym))])
{:name (symbol (str full-ns) (str (name sym)))
:ns full-ns}))
(.contains s ".")
(let [idx (.indexOf s ".")
prefix (symbol (subs s 0 idx))
suffix (subs s (inc idx))
lb (-> env :locals prefix)]
(if lb
{:name (symbol (str (:name lb) suffix))}
(merge (get-in @namespaces [prefix :defs (symbol suffix)])
{:name (if (= "" prefix) (symbol suffix) (symbol (str prefix) suffix))
:ns prefix})))
(get-in @namespaces [(-> env :ns :name) :uses sym])
(let [full-ns (get-in @namespaces [(-> env :ns :name) :uses sym])]
(merge
(get-in @namespaces [full-ns :defs sym])
{:name (symbol (str full-ns) (str sym))
:ns (-> env :ns :name)}))
(get-in @namespaces [(-> env :ns :name) :imports sym])
(recur env (get-in @namespaces [(-> env :ns :name) :imports sym]) confirm)
:else
(let [full-ns (if (core-name? env sym)
'cljs.core
(-> env :ns :name))]
(when confirm
(confirm env full-ns sym))
(merge (get-in @namespaces [full-ns :defs sym])
{:name (symbol (str full-ns) (str sym))
:ns full-ns})))))))
(defn resolve-existing-var [env sym]
(resolve-var env sym confirm-var-exists))
(defn confirm-bindings [env names]
(doseq [name names]
(let [env (merge env {:ns (@namespaces *cljs-ns*)})
ev (resolve-existing-var env name)]
(when (and *cljs-warn-on-dynamic*
ev (not (-> ev :dynamic)))
(warning env
(str "WARNING: " (:name ev) " not declared ^:dynamic"))))))
(declare analyze analyze-symbol analyze-seq)
(def specials '#{if def fn* do let* loop* letfn* throw try* recur new set! ns deftype* defrecord* . js* & quote})
(def ^:dynamic *recur-frames* nil)
(def ^:dynamic *loop-lets* nil)
(defmacro disallowing-recur [& body]
`(binding [*recur-frames* (cons nil *recur-frames*)] ~@body))
(defn analyze-keyword
[env sym]
{:op :constant :env env
:form (if (= (namespace sym) (name *reader-ns-name*))
(keyword (-> env :ns :name name) (name sym))
sym)})
(defmulti parse (fn [op & rest] op))
(defmethod parse 'if
[op env [_ test then else :as form] name]
(assert (>= (count form) 3) "Too few arguments to if")
(let [test-expr (disallowing-recur (analyze (assoc env :context :expr) test))
then-expr (analyze env then)
else-expr (analyze env else)]
{:env env :op :if :form form
:test test-expr :then then-expr :else else-expr
:unchecked @*unchecked-if*
:children [test-expr then-expr else-expr]}))
(defmethod parse 'throw
[op env [_ throw :as form] name]
(let [throw-expr (disallowing-recur (analyze (assoc env :context :expr) throw))]
{:env env :op :throw :form form
:throw throw-expr
:children [throw-expr]}))
(defmethod parse 'try*
[op env [_ & body :as form] name]
(let [body (vec body)
catchenv (update-in env [:context] #(if (= :expr %) :return %))
tail (peek body)
fblock (when (and (seq? tail) (= 'finally (first tail)))
(rest tail))
finally (when fblock
(analyze (assoc env :context :statement) `(do ~@fblock)))
body (if finally (pop body) body)
tail (peek body)
cblock (when (and (seq? tail)
(= 'catch (first tail)))
(rest tail))
name (first cblock)
locals (:locals catchenv)
locals (if name
(assoc locals name
{:name name
:line (get-line name env)
:column (get-col name env)})
locals)
catch (when cblock
(analyze (assoc catchenv :locals locals) `(do ~@(rest cblock))))
body (if name (pop body) body)
try (analyze (if (or name finally) catchenv env) `(do ~@body))]
(when name (assert (not (namespace name)) "Can't qualify symbol in catch"))
{:env env :op :try* :form form
:try try
:finally finally
:name name
:catch catch
:children [try catch finally]}))
(defmethod parse 'def
[op env form name]
(let [pfn (fn
([_ sym] {:sym sym})
([_ sym init] {:sym sym :init init})
([_ sym doc init] {:sym sym :doc doc :init init}))
args (apply pfn form)
sym (:sym args)
sym-meta (meta sym)
tag (-> sym meta :tag)
protocol (-> sym meta :protocol)
dynamic (-> sym meta :dynamic)
ns-name (-> env :ns :name)]
(assert (not (namespace sym)) "Can't def ns-qualified name")
(let [env (if (or (and (not= ns-name 'cljs.core)
(core-name? env sym))
(get-in @namespaces [ns-name :uses sym]))
(let [ev (resolve-existing-var (dissoc env :locals) sym)]
(when *cljs-warn-on-redef*
(warning env
(str "WARNING: " sym " already refers to: " (symbol (str (:ns ev)) (str sym))
" being replaced by: " (symbol (str ns-name) (str sym)))))
(swap! namespaces update-in [ns-name :excludes] conj sym)
(update-in env [:ns :excludes] conj sym))
env)
name (:name (resolve-var (dissoc env :locals) sym))
var-expr (assoc (analyze (-> env (dissoc :locals)
(assoc :context :expr)
(assoc :def-var true))
sym)
:op :var)
init-expr (when (contains? args :init)
(disallowing-recur
(analyze (assoc env :context :expr) (:init args) sym)))
fn-var? (and init-expr (= (:op init-expr) :fn))
export-as (when-let [export-val (-> sym meta :export)]
(if (= true export-val) name export-val))
doc (or (:doc args) (-> sym meta :doc))]
(when-let [v (get-in @namespaces [ns-name :defs sym])]
(when (and *cljs-warn-on-fn-var*
(not (-> sym meta :declared))
(and (:fn-var v) (not fn-var?)))
(warning env
(str "WARNING: " (symbol (str ns-name) (str sym))
" no longer fn, references are stale"))))
(swap! namespaces assoc-in [ns-name :defs sym]
(merge
{:name name}
sym-meta
(when doc {:doc doc})
(when dynamic {:dynamic true})
(source-info name env)
;; the protocol a protocol fn belongs to
(when protocol
{:protocol protocol})
;; symbol for reified protocol
(when-let [protocol-symbol (-> sym meta :protocol-symbol)]
{:protocol-symbol protocol-symbol})
(when fn-var?
{:fn-var true
;; protocol implementation context
:protocol-impl (:protocol-impl init-expr)
;; inline protocol implementation context
:protocol-inline (:protocol-inline init-expr)
:variadic (:variadic init-expr)
:max-fixed-arity (:max-fixed-arity init-expr)
:method-params (map :params (:methods init-expr))})))
(merge {:env env :op :def :form form
:name name :var var-expr :doc doc :init init-expr}
(when tag {:tag tag})
(when dynamic {:dynamic true})
(when export-as {:export export-as})
(when init-expr {:children [init-expr]})))))
(defn- analyze-fn-method [env locals form type]
(let [param-names (first form)
variadic (boolean (some '#{&} param-names))
param-names (vec (remove '#{&} param-names))
body (next form)
[locals params] (reduce (fn [[locals params] name]
(let [param {:name name
:line (get-line name env)
:column (get-col name env)
:tag (-> name meta :tag)
:shadow (when locals (locals name))}]
[(assoc locals name param) (conj params param)]))
[locals []] param-names)
fixed-arity (count (if variadic (butlast params) params))
recur-frame {:params params :flag (atom nil)}
expr (binding [*recur-frames* (cons recur-frame *recur-frames*)]
(analyze (assoc env :context :return :locals locals) `(do ~@body)))]
{:env env :variadic variadic :params params :max-fixed-arity fixed-arity
:type type :form form :recurs @(:flag recur-frame) :expr expr}))
(defmethod parse 'fn*
[op env [_ & args :as form] name]
(let [[name meths] (if (symbol? (first args))
[(first args) (next args)]
[name (seq args)])
;;turn (fn [] ...) into (fn ([]...))
meths (if (vector? (first meths)) (list meths) meths)
locals (:locals env)
locals (if (and locals name) (assoc locals name {:name name :shadow (locals name)}) locals)
type (-> form meta ::type)
fields (-> form meta ::fields)
protocol-impl (-> form meta :protocol-impl)
protocol-inline (-> form meta :protocol-inline)
locals (reduce (fn [m fld]
(assoc m fld
{:name fld
:line (get-line fld env)
:column (get-col fld env)
:field true
:mutable (-> fld meta :mutable)
:unsynchronized-mutable (-> fld meta :unsynchronized-mutable)
:volatile-mutable (-> fld meta :volatile-mutable)
:tag (-> fld meta :tag)
:shadow (m fld)}))
locals fields)
menv (if (> (count meths) 1) (assoc env :context :expr) env)
menv (merge menv
{:protocol-impl protocol-impl
:protocol-inline protocol-inline})
methods (map #(analyze-fn-method menv locals % type) meths)
max-fixed-arity (apply max (map :max-fixed-arity methods))
variadic (boolean (some :variadic methods))
locals (if name
(update-in locals [name] assoc
:fn-var true
:variadic variadic
:max-fixed-arity max-fixed-arity
:method-params (map :params methods))
locals)
methods (if name
;; a second pass with knowledge of our function-ness/arity
;; lets us optimize self calls
(no-warn (doall (map #(analyze-fn-method menv locals % type) meths)))
methods)]
;;todo - validate unique arities, at most one variadic, variadic takes max required args
{:env env :op :fn :form form :name name :methods methods :variadic variadic
:recur-frames *recur-frames* :loop-lets *loop-lets*
:jsdoc [(when variadic "@param {...*} var_args")]
:max-fixed-arity max-fixed-arity
:protocol-impl protocol-impl
:protocol-inline protocol-inline
:children (mapv :expr methods)}))
(defmethod parse 'letfn*
[op env [_ bindings & exprs :as form] name]
(assert (and (vector? bindings) (even? (count bindings))) "bindings must be vector of even number of elements")
(let [n->fexpr (into {} (map (juxt first second) (partition 2 bindings)))
names (keys n->fexpr)
context (:context env)
[meth-env bes]
(reduce (fn [[{:keys [locals] :as env} bes] n]
(let [be {:name n
:line (get-line n env)
:column (get-col n env)
:tag (-> n meta :tag)
:local true
:shadow (locals n)}]
[(assoc-in env [:locals n] be)
(conj bes be)]))
[env []] names)
meth-env (assoc meth-env :context :expr)
bes (vec (map (fn [{:keys [name shadow] :as be}]
(let [env (assoc-in meth-env [:locals name] shadow)]
(assoc be :init (analyze env (n->fexpr name)))))
bes))
expr (analyze (assoc meth-env :context (if (= :expr context) :return context)) `(do ~@exprs))]
{:env env :op :letfn :bindings bes :expr expr :form form
:children (conj (vec (map :init bes)) expr)}))
(defmethod parse 'do
[op env [_ & exprs :as form] _]
(let [statements (disallowing-recur
(seq (map #(analyze (assoc env :context :statement) %) (butlast exprs))))
ret (if (<= (count exprs) 1)
(analyze env (first exprs))
(analyze (assoc env :context (if (= :statement (:context env)) :statement :return)) (last exprs)))]
{:env env :op :do :form form
:statements statements :ret ret
:children (conj (vec statements) ret)}))
(defn analyze-let
[encl-env [_ bindings & exprs :as form] is-loop]
(assert (and (vector? bindings) (even? (count bindings))) "bindings must be vector of even number of elements")
(let [context (:context encl-env)
[bes env]
(disallowing-recur
(loop [bes []
env (assoc encl-env :context :expr)
bindings (seq (partition 2 bindings))]
(if-let [[name init] (first bindings)]
(do
(assert (not (or (namespace name) (.contains (str name) "."))) (str "Invalid local name: " name))
(let [init-expr (binding [*loop-lets* (cons {:params bes} (or *loop-lets* ()))]
(analyze env init))
be {:name name
:line (get-line name env)
:column (get-col name env)
:init init-expr
:tag (or (-> name meta :tag)
(-> init-expr :tag)
(-> init-expr :info :tag))
:local true
:shadow (-> env :locals name)}
be (if (= (:op init-expr) :fn)
(merge be
{:fn-var true
:variadic (:variadic init-expr)
:max-fixed-arity (:max-fixed-arity init-expr)
:method-params (map :params (:methods init-expr))})
be)]
(recur (conj bes be)
(assoc-in env [:locals name] be)
(next bindings))))
[bes env])))
recur-frame (when is-loop {:params bes :flag (atom nil)})
expr
(binding [*recur-frames* (if recur-frame (cons recur-frame *recur-frames*) *recur-frames*)
*loop-lets* (cond
is-loop (or *loop-lets* ())
*loop-lets* (cons {:params bes} *loop-lets*))]
(analyze (assoc env :context (if (= :expr context) :return context)) `(do ~@exprs)))]
{:env encl-env :op (if is-loop :loop :let)
:bindings bes :expr expr :form form
:children (conj (vec (map :init bes)) expr)}))
(defmethod parse 'let*
[op encl-env form _]
(analyze-let encl-env form false))
(defmethod parse 'loop*
[op encl-env form _]
(analyze-let encl-env form true))
(defmethod parse 'recur
[op env [_ & exprs :as form] _]
(let [context (:context env)
frame (first *recur-frames*)
exprs (disallowing-recur (vec (map #(analyze (assoc env :context :expr) %) exprs)))]
(assert frame "Can't recur here")
(assert (= (count exprs) (count (:params frame))) "recur argument count mismatch")
(reset! (:flag frame) true)
(assoc {:env env :op :recur :form form}
:frame frame
:exprs exprs
:children exprs)))
(defmethod parse 'quote
[_ env [_ x] _]
(analyze (assoc env :quoted? true) x))
(defmethod parse 'new
[_ env [_ ctor & args :as form] _]
(assert (symbol? ctor) "First arg to new must be a symbol")
(disallowing-recur
(let [enve (assoc env :context :expr)
ctorexpr (analyze enve ctor)
argexprs (vec (map #(analyze enve %) args))
known-num-fields (:num-fields (resolve-existing-var env ctor))
argc (count args)]
(when (and known-num-fields (not= known-num-fields argc))
(warning env
(str "WARNING: Wrong number of args (" argc ") passed to " ctor)))
{:env env :op :new :form form :ctor ctorexpr :args argexprs
:children (into [ctorexpr] argexprs)})))
(defmethod parse 'set!
[_ env [_ target val alt :as form] _]
(let [[target val] (if alt
;; (set! o -prop val)
[`(. ~target ~val) alt]
[target val])]
(disallowing-recur
(let [enve (assoc env :context :expr)
targetexpr (cond
;; TODO: proper resolve
(= target '*unchecked-if*)
(do
(reset! *unchecked-if* val)
::set-unchecked-if)
(symbol? target)
(do
(let [local (-> env :locals target)]
(assert (or (nil? local)
(and (:field local)
(or (:mutable local)
(:unsynchronized-mutable local)
(:volatile-mutable local))))
"Can't set! local var or non-mutable field"))
(analyze-symbol enve target))
:else
(when (seq? target)
(let [targetexpr (analyze-seq enve target nil)]
(when (:field targetexpr)
targetexpr))))
valexpr (analyze enve val)]
(assert targetexpr "set! target must be a field or a symbol naming a var")
(cond
(= targetexpr ::set-unchecked-if) {:env env :op :no-op}
:else {:env env :op :set! :form form :target targetexpr :val valexpr
:children [targetexpr valexpr]})))))
(defn munge-path [ss]
(clojure.lang.Compiler/munge (str ss)))
(defn ns->relpath [s]
(str (string/replace (munge-path s) \. \/) ".cljs"))
(declare analyze-file)
(defn analyze-deps [deps]
(doseq [dep deps]
(when-not (contains? @namespaces dep)
(let [relpath (ns->relpath dep)]
(when (io/resource relpath)
(analyze-file relpath))))))
(defmethod parse 'ns
[_ env [_ name & args :as form] _]
(assert (symbol? name) "Namespaces must be named by a symbol.")
(let [docstring (if (string? (first args)) (first args) nil)
args (if docstring (next args) args)
excludes
(reduce (fn [s [k exclude xs]]
(if (= k :refer-clojure)
(do
(assert (= exclude :exclude) "Only [:refer-clojure :exclude (names)] form supported")
(assert (not (seq s)) "Only one :refer-clojure form is allowed per namespace definition")
(into s xs))
s))
#{} args)
deps (atom #{})
aliases (atom {:fns #{} :macros #{}})
valid-forms (atom #{:use :use-macros :require :require-macros :import})
error-msg (fn [spec msg] (str msg "; offending spec: " (pr-str spec)))
parse-require-spec (fn parse-require-spec [macros? spec]
(assert (or (symbol? spec) (vector? spec))
(error-msg spec "Only [lib.ns & options] and lib.ns specs supported in :require / :require-macros"))
(when (vector? spec)
(assert (symbol? (first spec))
(error-msg spec "Library name must be specified as a symbol in :require / :require-macros"))
(assert (odd? (count spec))
(error-msg spec "Only :as alias and :refer (names) options supported in :require"))
(assert (every? #{:as :refer} (map first (partition 2 (next spec))))
(error-msg spec "Only :as and :refer options supported in :require / :require-macros"))
(assert (let [fs (frequencies (next spec))]
(and (<= (fs :as 0) 1)
(<= (fs :refer 0) 1)))
(error-msg spec "Each of :as and :refer options may only be specified once in :require / :require-macros")))
(if (symbol? spec)
(recur macros? [spec])
(let [[lib & opts] spec
{alias :as referred :refer :or {alias lib}} (apply hash-map opts)
[rk uk] (if macros? [:require-macros :use-macros] [:require :use])]
(when alias
;; we need to create a fake namespace so the reader knows about aliases
;; for resolving keywords like ::f/bar
(binding [*ns* (create-ns name)]
(let [^clojure.lang.Namespace ns (create-ns lib)]
(clojure.core/alias alias (.name ns))))
(let [alias-type (if macros? :macros :fns)]
(assert (not (contains? (alias-type @aliases)
alias))
(error-msg spec ":as alias must be unique"))
(swap! aliases
update-in [alias-type]
conj alias)))
(assert (or (symbol? alias) (nil? alias))
(error-msg spec ":as must be followed by a symbol in :require / :require-macros"))
(assert (or (and (sequential? referred) (every? symbol? referred))
(nil? referred))
(error-msg spec ":refer must be followed by a sequence of symbols in :require / :require-macros"))
(when-not macros?
(swap! deps conj lib))
(merge (when alias {rk {alias lib}})
(when referred {uk (apply hash-map (interleave referred (repeat lib)))})))))
use->require (fn use->require [[lib kw referred :as spec]]
(assert (and (symbol? lib) (= :only kw) (sequential? referred) (every? symbol? referred))
(error-msg spec "Only [lib.ns :only (names)] specs supported in :use / :use-macros"))
[lib :refer referred])
parse-import-spec (fn parse-import-spec [spec]
(assert (and (symbol? spec) (nil? (namespace spec)))
(error-msg spec "Only lib.Ctor specs supported in :import"))
(swap! deps conj spec)
(let [ctor-sym (symbol (last (string/split (str spec) #"\.")))]
{:import {ctor-sym spec}
:require {ctor-sym spec}}))
spec-parsers {:require (partial parse-require-spec false)
:require-macros (partial parse-require-spec true)
:use (comp (partial parse-require-spec false) use->require)
:use-macros (comp (partial parse-require-spec true) use->require)
:import parse-import-spec}
{uses :use requires :require uses-macros :use-macros requires-macros :require-macros imports :import :as params}
(reduce (fn [m [k & libs]]
(assert (#{:use :use-macros :require :require-macros :import} k)
"Only :refer-clojure, :require, :require-macros, :use and :use-macros libspecs supported")
(assert (@valid-forms k)
(str "Only one " k " form is allowed per namespace definition"))
(swap! valid-forms disj k)
(apply merge-with merge m (map (spec-parsers k) libs)))
{} (remove (fn [[r]] (= r :refer-clojure)) args))]
(when (seq @deps)
(analyze-deps @deps))
(set! *cljs-ns* name)
(load-core)
(doseq [nsym (concat (vals requires-macros) (vals uses-macros))]
(clojure.core/require nsym))
(swap! namespaces #(-> %
(assoc-in [name :name] name)
(assoc-in [name :doc] docstring)
(assoc-in [name :excludes] excludes)
(assoc-in [name :uses] uses)
(assoc-in [name :requires] requires)
(assoc-in [name :uses-macros] uses-macros)
(assoc-in [name :requires-macros]
(into {} (map (fn [[alias nsym]]
[alias (find-ns nsym)])
requires-macros)))
(assoc-in [name :imports] imports)))
{:env env :op :ns :form form :name name :doc docstring :uses uses :requires requires :imports imports
:uses-macros uses-macros :requires-macros requires-macros :excludes excludes}))
(defmethod parse 'deftype*
[_ env [_ tsym fields pmasks :as form] _]
(let [t (:name (resolve-var (dissoc env :locals) tsym))]
(swap! namespaces update-in [(-> env :ns :name) :defs tsym]
(fn [m]
(let [m (assoc (or m {})
:name t
:type true
:num-fields (count fields))]
(merge m
{:protocols (-> tsym meta :protocols)}
(source-info tsym env)))))
{:env env :op :deftype* :form form :t t :fields fields :pmasks pmasks}))
(defmethod parse 'defrecord*
[_ env [_ tsym fields pmasks :as form] _]
(let [t (:name (resolve-var (dissoc env :locals) tsym))]
(swap! namespaces update-in [(-> env :ns :name) :defs tsym]
(fn [m]
(let [m (assoc (or m {}) :name t :type true)]
(merge m
{:protocols (-> tsym meta :protocols)}
(source-info tsym env)))))
{:env env :op :defrecord* :form form :t t :fields fields :pmasks pmasks}))
;; dot accessor code
(def ^:private property-symbol? #(boolean (and (symbol? %) (re-matches #"^-.*" (name %)))))
(defn- classify-dot-form
[[target member args]]
[(cond (nil? target) ::error
:default ::expr)
(cond (property-symbol? member) ::property
(symbol? member) ::symbol
(seq? member) ::list
:default ::error)
(cond (nil? args) ()
:default ::expr)])
(defmulti build-dot-form #(classify-dot-form %))
;; (. o -p)
;; (. (...) -p)
(defmethod build-dot-form [::expr ::property ()]
[[target prop _]]
{:dot-action ::access :target target :field (-> prop name (.substring 1) symbol)})
;; (. o -p <args>)
(defmethod build-dot-form [::expr ::property ::list]
[[target prop args]]
(throw (Error. (str "Cannot provide arguments " args " on property access " prop))))
(defn- build-method-call
"Builds the intermediate method call map used to reason about the parsed form during
compilation."
[target meth args]
(if (symbol? meth)
{:dot-action ::call :target target :method meth :args args}
{:dot-action ::call :target target :method (first meth) :args args}))
;; (. o m 1 2)
(defmethod build-dot-form [::expr ::symbol ::expr]
[[target meth args]]
(build-method-call target meth args))
;; (. o m)
(defmethod build-dot-form [::expr ::symbol ()]
[[target meth args]]
(build-method-call target meth args))
;; (. o (m))
;; (. o (m 1 2))
(defmethod build-dot-form [::expr ::list ()]
[[target meth-expr _]]
(build-method-call target (first meth-expr) (rest meth-expr)))
(defmethod build-dot-form :default
[dot-form]
(throw (Error. (str "Unknown dot form of " (list* '. dot-form) " with classification " (classify-dot-form dot-form)))))
(defmethod parse '.
[_ env [_ target & [field & member+] :as form] _]
(disallowing-recur
(let [{:keys [dot-action target method field args]} (build-dot-form [target field member+])
enve (assoc env :context :expr)
targetexpr (analyze enve target)]
(case dot-action
::access {:env env :op :dot :form form
:target targetexpr
:field field
:children [targetexpr]
:tag (-> form meta :tag)}
::call (let [argexprs (map #(analyze enve %) args)]
{:env env :op :dot :form form
:target targetexpr
:method method
:args argexprs
:children (into [targetexpr] argexprs)
:tag (-> form meta :tag)})))))
(defmethod parse 'js*
[op env [_ jsform & args :as form] _]
(assert (string? jsform))
(if args
(disallowing-recur
(let [seg (fn seg [^String s]
(let [idx (.indexOf s "~{")]
(if (= -1 idx)
(list s)
(let [end (.indexOf s "}" idx)]
(cons (subs s 0 idx) (seg (subs s (inc end))))))))
enve (assoc env :context :expr)
argexprs (vec (map #(analyze enve %) args))]
{:env env :op :js :segs (seg jsform) :args argexprs
:tag (-> form meta :tag) :form form :children argexprs}))
(let [interp (fn interp [^String s]
(let [idx (.indexOf s "~{")]
(if (= -1 idx)
(list s)
(let [end (.indexOf s "}" idx)
inner (:name (resolve-existing-var env (symbol (subs s (+ 2 idx) end))))]
(cons (subs s 0 idx) (cons inner (interp (subs s (inc end)))))))))]
{:env env :op :js :form form :code (apply str (interp jsform))
:tag (-> form meta :tag)})))
(defn parse-invoke
[env [f & args :as form]]
(disallowing-recur
(let [enve (assoc env :context :expr)
fexpr (analyze enve f)
argexprs (vec (map #(analyze enve %) args))
argc (count args)]
(if (and *cljs-warn-fn-arity* (-> fexpr :info :fn-var))
(let [{:keys [variadic max-fixed-arity method-params name]} (:info fexpr)]
(when (and (not (some #{argc} (map count method-params)))
(or (not variadic)
(and variadic (< argc max-fixed-arity))))
(warning env
(str "WARNING: Wrong number of args (" argc ") passed to " name)))))
(if (and *cljs-warn-fn-deprecated* (-> fexpr :info :deprecated)
(not (-> form meta :deprecation-nowarn)))
(warning env
(str "WARNING: " (-> fexpr :info :name) " is deprecated.")))
{:env env :op :invoke :form form :f fexpr :args argexprs
:tag (or (-> fexpr :info :tag) (-> form meta :tag)) :children (into [fexpr] argexprs)})))
(defn analyze-symbol
"Finds the var associated with sym"
[env sym]
(if (:quoted? env)
{:op :constant :env env :form sym}
(let [ret {:env env :form sym}
lb (-> env :locals sym)]
(if lb
(assoc ret :op :var :info lb)
(if-not (:def-var env)
(assoc ret :op :var :info (resolve-existing-var env sym))
(assoc ret :op :var :info (resolve-var env sym)))))))
(defn get-expander [sym env]
(let [mvar
(when-not (or (-> env :locals sym) ;locals hide macros
(and (or (-> env :ns :excludes sym)
(get-in @namespaces [(-> env :ns :name) :excludes sym]))
(not (or (-> env :ns :uses-macros sym)
(get-in @namespaces [(-> env :ns :name) :uses-macros sym])))))
(if-let [nstr (namespace sym)]
(when-let [ns (cond
(= "clojure.core" nstr) (find-ns 'cljs.core)
(.contains nstr ".") (find-ns (symbol nstr))
:else
(-> env :ns :requires-macros (get (symbol nstr))))]
(.findInternedVar ^clojure.lang.Namespace ns (symbol (name sym))))
(if-let [nsym (-> env :ns :uses-macros sym)]
(.findInternedVar ^clojure.lang.Namespace (find-ns nsym) sym)
(.findInternedVar ^clojure.lang.Namespace (find-ns 'cljs.core) sym))))]
(when (and mvar (.isMacro ^clojure.lang.Var mvar))
@mvar)))
(defn macroexpand-1 [env form]
(let [op (first form)]
(if (specials op)
form
(if-let [mac (and (symbol? op) (get-expander op env))]
(binding [*ns* (create-ns *cljs-ns*)]
(apply mac form env (rest form)))
(if (symbol? op)
(let [opname (str op)]
(cond
(= (first opname) \.) (let [[target & args] (next form)]
(with-meta (list* '. target (symbol (subs opname 1)) args)
(meta form)))
(= (last opname) \.) (with-meta
(list* 'new (symbol (subs opname 0 (dec (count opname)))) (next form))
(meta form))
:else form))
form)))))
(declare analyze-list)
(defn analyze-seq
[env form name]
(if (:quoted? env)
(analyze-list env form name)
(let [env (assoc env
:line (or (-> form meta :line)
(:line env))
:column (or (-> form meta :column)
(:column env)))]
(let [op (first form)]
(assert (not (nil? op)) "Can't call nil")
(let [mform (macroexpand-1 env form)]
(if (identical? form mform)
(wrapping-errors env
(if (specials op)
(parse op env form name)
(parse-invoke env form)))
(analyze env mform name)))))))
(declare analyze-wrap-meta)
(defn analyze-map
[env form name]
(let [expr-env (assoc env :context :expr)
ks (disallowing-recur (vec (map #(analyze expr-env % name) (keys form))))
vs (disallowing-recur (vec (map #(analyze expr-env % name) (vals form))))]
(analyze-wrap-meta {:op :map :env env :form form
:keys ks :vals vs
:children (vec (interleave ks vs))}
name)))
(defn analyze-list
[env form name]
(let [expr-env (assoc env :context :expr)
items (disallowing-recur (doall (map #(analyze expr-env % name) form)))]
(analyze-wrap-meta {:op :list :env env :form form :items items :children items} name)))
(defn analyze-vector
[env form name]
(let [expr-env (assoc env :context :expr)
items (disallowing-recur (vec (map #(analyze expr-env % name) form)))]
(analyze-wrap-meta {:op :vector :env env :form form :items items :children items} name)))
(defn analyze-set
[env form name]
(let [expr-env (assoc env :context :expr)
items (disallowing-recur (vec (map #(analyze expr-env % name) form)))]
(analyze-wrap-meta {:op :set :env env :form form :items items :children items} name)))
(defn analyze-wrap-meta [expr name]
(let [form (:form expr)
m (dissoc (meta form) :line :column)]
(if (seq m)
(let [env (:env expr) ; take on expr's context ourselves
expr (assoc-in expr [:env :context] :expr) ; change expr to :expr
meta-expr (analyze-map (:env expr) m name)]
{:op :meta :env env :form form
:meta meta-expr :expr expr :children [meta-expr expr]})
expr)))
(defn analyze
"Given an environment, a map containing {:locals (mapping of names to bindings), :context
(one of :statement, :expr, :return), :ns (a symbol naming the
compilation ns)}, and form, returns an expression object (a map
containing at least :form, :op and :env keys). If expr has any (immediately)
nested exprs, must have :children [exprs...] entry. This will
facilitate code walking without knowing the details of the op set."
([env form] (analyze env form nil))
([env form name]
(wrapping-errors env
(let [form (if (instance? clojure.lang.LazySeq form)
(or (seq form) ())
form)]
(load-core)