This repository has been archived by the owner. It is now read-only.
Permalink
Browse files

Add let and others to CLJS

  • Loading branch information...
frenchy64 committed Nov 19, 2012
1 parent 733a2e0 commit 48756cc1bc94e182fee74d1000df4748a9088f93
Showing with 137 additions and 31 deletions.
  1. +29 −17 src/typed/check.clj
  2. +104 −12 src/typed/check_cljs.clj
  3. +4 −2 src/typed/core.clj
View
@@ -728,7 +728,8 @@
[{:keys [var] :as expr} & [expected]]
(let [id (var->symbol var)]
(assoc expr
- expr-type (ret (lookup-Var (var->symbol var))
+ expr-type (ret (binding [*var-annotations* VAR-ANNOTATIONS]
+ (lookup-Var (var->symbol var)))
(-FS -top -top)
-empty))))
@@ -1924,7 +1925,8 @@
(defmethod check :local-binding-expr
[{:keys [local-binding] :as expr} & [expected]]
(let [sym (:sym local-binding)
- t (type-of sym)
+ t (binding [*var-annotations* VAR-ANNOTATIONS]
+ (type-of sym))
_ (assert (or (not expected)
(subtype? t (ret-t expected)))
(error-msg "Local binding " sym " expected type " (unparse-type (ret-t expected))
@@ -2166,16 +2168,18 @@
(assoc expr
expr-type (ret (Un)))))
-(defn check-let [{:keys [binding-inits body is-loop] :as expr} expected & {:keys [expected-bnds]}]
+(def ^:dynamic *check-let-checkfn*)
+
+(defn check-let [binding-inits body expr is-loop expected & {:keys [expected-bnds]}]
(assert (or (not is-loop) expected-bnds) (error-msg "Loop requires more annotations"))
(let [env (reduce (fn [env [{{:keys [sym init]} :local-binding} expected-bnd]]
{:pre [(PropEnv? env)]
:post [(PropEnv? env)]}
(let [{:keys [t fl o]} (->
(expr-type
(with-lexical-env env
- (check init (when is-loop
- (ret expected-bnd)))))
+ (*check-let-checkfn* init (when is-loop
+ (ret expected-bnd)))))
;substitute previous references to sym with an empty object,
;as old binding is shadowed
(update-in [:t] subst-type sym -empty true)
@@ -2213,8 +2217,8 @@
cbody (with-lexical-env env
(if is-loop
(binding [*recur-target* (->RecurTarget expected-bnds nil nil nil)]
- (check body expected))
- (check body expected)))
+ (*check-let-checkfn* body expected))
+ (*check-let-checkfn* body expected)))
;now we return a result to the enclosing scope, so we
;erase references to any bindings this scope introduces
@@ -2234,10 +2238,14 @@
(defmethod check :let
[expr & [expected]]
{:post [(-> % expr-type TCResult?)]}
- (if-let [expected-bnds (and (:is-loop expr) *loop-bnd-anns*)]
- (binding [*loop-bnd-anns* nil]
- (check-let expr expected :expected-bnds expected-bnds))
- (check-let expr expected)))
+ (binding [*check-let-checkfn* check]
+ (let [is-loop (:is-loop expr)
+ binding-inits (:binding-inits expr)
+ body (:body expr)]
+ (if-let [expected-bnds (and is-loop *loop-bnd-anns*)]
+ (binding [*loop-bnd-anns* nil]
+ (check-let binding-inits body expr true expected :expected-bnds expected-bnds))
+ (check-let binding-inits body expr false expected)))))
(defn resolve* [atoms prop]
{:pre [(every? Filter? atoms)
@@ -2456,6 +2464,8 @@
(def object-equal? =)
+(def ^:dynamic *check-if-checkfn*)
+
(defn check-if [tst thn els & [expected]]
{:pre [(TCResult? tst)
((some-fn TCResult? nil?) expected)]
@@ -2468,12 +2478,12 @@
;; if reachable? is #f, then we don't want to verify that this branch has the appropriate type
;; in particular, it might be (void)
(and expected reachable?)
- (-> (check expr (-> expected
- (update-in [:fl] #(map (constantly (->NoFilter)) %))
- (update-in [:o] #(map (constantly (->NoObject)) %))))
+ (-> (*check-if-checkfn* expr (-> expected
+ (update-in [:fl] #(map (constantly (->NoFilter)) %))
+ (update-in [:o] #(map (constantly (->NoObject)) %))))
expr-type)
;; this code is reachable, but we have no expected type
- reachable? (-> (check expr) expr-type)
+ reachable? (-> (*check-if-checkfn* expr) expr-type)
;; otherwise, this code is unreachable
;; and the resulting type should be the empty type
:else (do (prn (error-msg "Not checking unreachable code"))
@@ -2559,7 +2569,8 @@
{:post [(-> % expr-type TCResult?)]}
(let [ctest (check test)]
(assoc expr
- expr-type (check-if (expr-type ctest) then else))))
+ expr-type (binding [*check-if-checkfn* check]
+ (check-if (expr-type ctest) then else)))))
(defmethod check :def
[{:keys [var init init-provided env] :as expr} & [expected]]
@@ -2570,7 +2581,8 @@
(cond
;ignore macro definitions
(not (.isMacro ^Var var))
- (let [t (type-of (var->symbol var))
+ (let [t (binding [*var-annotations* VAR-ANNOTATIONS]
+ (type-of (var->symbol var)))
cexpr (cond
(not init-provided) expr ;handle `declare`
:else (check init (ret t)))
View
@@ -3,7 +3,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Modify CLJS specials
-(def new-specials '#{defprotocol typed.core/ann-form-cljs})
+(def new-specials '#{defprotocol #_deftype typed.core/ann-form-cljs
+ cljs.core/extend-type})
(.doReset #'cljs.analyzer/specials (set/union cljs/specials new-specials))
@@ -27,12 +28,6 @@
(swap! CLJS-VAR-ENV assoc vname vtype)
[vname (unparse-type vtype)]))
-(defn type-of [vname]
- (let [t (@CLJS-VAR-ENV vname)]
- (if t
- t
- (throw (Exception. (str "Untyped var: " vname))))))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Types
@@ -89,11 +84,30 @@
;; Parsing new special forms
(defmethod cljs/parse 'defprotocol
- [op env [psym & doc+methods :as form] name]
+ [op env [_ psym & doc+methods :as form] name]
{:op :defprotocol
:env env
:form form})
+(defmethod cljs/parse 'cljs.core/extend-type
+ [op env [_ t & impls :as form] name]
+ (let [parse-impl (fn [m] {:name (first m)
+ :method (cljs/analyze env `(~'fn ~@(rest m)))
+ :form m})
+ impl-map-syn ;from cljs/core.clj
+ (loop [ret {} s impls]
+ (if (seq s)
+ (recur (assoc ret (first s) (take-while seq? (next s)))
+ (drop-while seq? (next s)))
+ ret))
+ impl-map (into {} (for [[k v] impl-map-syn]
+ [k (map parse-impl v)]))]
+ {:op :extend-type
+ :t t
+ :impl-map impl-map
+ :form form
+ :env env}))
+
(defmethod cljs/parse 'typed.core/ann-form-cljs
[op env [_ form tsyn :as as] name]
(assert (= 3 (count as)))
@@ -139,7 +153,8 @@
[{:keys [init] vname :name :as expr} & [expected]]
(assert init "declare NYI")
(assert (not expected))
- (let [ann-type (type-of vname)
+ (let [ann-type (binding [*var-annotations* CLJS-VAR-ENV]
+ (type-of vname))
cinit (check-cljs init expected)
_ (assert (subtype? (-> cinit expr-type ret-t)
ann-type)
@@ -181,10 +196,12 @@
(defmethod check-cljs :var
[{{vname :name} :info :as expr} & [expected]]
(assoc expr
- expr-type (ret (type-of vname))))
+ expr-type (ret (binding [*var-annotations* CLJS-VAR-ENV]
+ (type-of vname)))))
(defmethod check-cljs :do
[{:keys [ret statements] :as expr} & [expected]]
+ (prn ret)
(let [cstatements (mapv check-cljs statements)
cret (check-cljs ret expected)]
(assoc expr
@@ -211,6 +228,51 @@
(ret (make-FnIntersection
(make-Function [] -any -any))))))))
+(defmethod check-cljs :deftype*
+ [expr & [expected]]
+ (assert (not expected))
+ (assoc expr
+ expr-type (ret -any)))
+
+(defmethod check-cljs :set!
+ [{:keys [target val] :as expr} & [expected]]
+ (assert (not expected))
+ (let [ctarget (check-cljs target)
+ cval (check-cljs val)]
+ (assoc expr
+ expr-type (ret -any))))
+
+(defn check-field
+ [{:keys [target field val] :as expr} & [expected]]
+ (assert false))
+
+(defmethod check-cljs :dot
+ [{:keys [field method] :as expr} & [expected]]
+ #_((if field check-field (throw (Exception. "NYI")))
+ expr expected)
+ (assoc expr
+ expr-type (ret -any)))
+
+(defmethod check-cljs :if
+ [{:keys [test then else] :as expr} & [expected]]
+ (let [ctest (check-cljs test)]
+ (assoc expr
+ expr-type (binding [*check-if-checkfn* check-cljs]
+ (check-if (expr-type ctest) then else)))))
+
+(defmethod check-cljs :let
+ [{:keys [loop bindings statements ret env] :as expr} & [expected]]
+ (let [;; conform to Clojure `analyze` for now
+ bindings (mapv #(let [n (:name %)]
+ {:local-binding (-> % (dissoc :name) (assoc :sym n))})
+ bindings)
+ body {:op :do, :statements statements, :ret ret :env env}]
+ (binding [*check-let-checkfn* check-cljs]
+ (if loop
+ (assert false) #_(check-let bindings body expr true expected)
+ (check-let bindings body expr false expected)))))
+
+
;; Debug
(defn ana-cljs [env form]
@@ -230,8 +292,8 @@
(cljs/analyze denv {:a 1})
(cf-cljs {:a 1})
-(cljs-ann user/a Any)
- (@CLJS-VAR-ENV 'user/a)
+(cljs-ann cljs.user/a Any)
+ (@CLJS-VAR-ENV 'cljs.user/a)
(cljs/analyze denv '(def a 1))
(cf-cljs (def a 1))
@@ -261,5 +323,35 @@
(cf-cljs (fn [a b c]))
(cf-cljs (fn [a b c]) [BooleanCLJS BooleanCLJS Any -> nil])
+(ana-cljs denv '(fn [a] a))
(cf-cljs (fn [a b c] a) [BooleanCLJS BooleanCLJS Any -> BooleanCLJS])
+
+; deftype
+(ana-cljs denv '(deftype A [b] cljs.core/ASeq))
+(cljs/macroexpand-1 denv '(deftype A [b]
+ cljs.core/ASeq
+ cljs.core/IFn
+ (invoke [this a b] a)))
+(ana-cljs denv '(deftype A [b]
+ cljs.core/ASeq
+ cljs.core/IFn
+ (invoke [this a b] a)))
+ (cf-cljs (deftype A [b]
+ cljs.core/ASeq
+ cljs.core/IFn
+ (invoke [this a b] a)))
+(ana-cljs denv '(set! o -a 1))
+(ana-cljs denv '(set! o 1))
+(cf-cljs (set! o -a 1))
+(ana-cljs denv '(.-cljs$lang$type 1))
+(cf-cljs (.-cljs$lang$type 1))
+(ana-cljs denv '(.-cljs$lang$type 1))
+(cf-cljs (set! cljs.core/symbol? 1))
+
+
+ (ana-cljs denv '(if 1 2 3))
+ (cf-cljs (if 1 2 3))
+
+ (ana-cljs denv '(let [a 2] a))
+ (cf-cljs (let [a 2] a))
)
View
@@ -482,12 +482,14 @@
:post [(symbol? %)]}
(symbol (.getName cls)))
+(def ^:dynamic *var-annotations*)
+
(defn lookup-Var [nsym]
- (assert (contains? @VAR-ANNOTATIONS nsym)
+ (assert (contains? @*var-annotations* nsym)
(str (when *current-env*
(str (:line *current-env*) ": "))
"Untyped var reference: " nsym))
- (@VAR-ANNOTATIONS nsym))
+ (@*var-annotations* nsym))
(defn merge-locals [env new]
(-> env

0 comments on commit 48756cc

Please sign in to comment.