Fixup bindings correctly
This commit is contained in:
parent
21ced785bd
commit
f7eee74e2d
|
@ -9,13 +9,14 @@
|
||||||
ctx (if scope (new-scope ctx scope) ctx)
|
ctx (if scope (new-scope ctx scope) ctx)
|
||||||
new-bindings (:new-bindings special)
|
new-bindings (:new-bindings special)
|
||||||
bindings (if new-bindings (new-bindings form ctx) {})
|
bindings (if new-bindings (new-bindings form ctx) {})
|
||||||
new-form (m/rewrite form
|
marker (or (:mark-bound-subexpressions special) identity)
|
||||||
('l/lookup ?m) ('l/lookup {:ctx ~ctx & ?m})
|
form (marker form)
|
||||||
(m/and ?form ~new-bindings) (m+ {:bindings ~bindings} ?form)
|
form (if new-bindings (merge-metafield form {:bindings bindings}) form)
|
||||||
?form ?form)]
|
add-ctx? (or (= (first form) 'l/lookup) (:binding (second form)) new-bindings)
|
||||||
|
form (if add-ctx? (merge-metafield form {:ctx ctx}) form)]
|
||||||
(doseq [[symbol binding] bindings]
|
(doseq [[symbol binding] bindings]
|
||||||
(bind! ctx symbol binding))
|
(bind! ctx symbol binding))
|
||||||
((all-subexpressions (partial decorate-ctx specials ctx)) new-form)))
|
((all-subexpressions (partial decorate-ctx specials ctx)) form)))
|
||||||
|
|
||||||
(def perform-lookups
|
(def perform-lookups
|
||||||
(bottom-up
|
(bottom-up
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
(ns tock.compiler.specials
|
(ns tock.compiler.specials
|
||||||
(:require [meander.epsilon :as m]
|
(:require [meander.epsilon :as m]
|
||||||
[meander.strategy.epsilon :as r]
|
[meander.strategy.epsilon :as r]
|
||||||
[tock.compiler.meander :refer [parse-type to-sym label] :include-macros true]
|
[tock.compiler.meander :refer [parse-type to-sym label m+] :include-macros true]
|
||||||
[tock.compiler.util :refer [get-meta]]))
|
[tock.compiler.util :refer [get-meta]]))
|
||||||
|
|
||||||
;; no namespace - source symbol
|
;; no namespace - source symbol
|
||||||
|
@ -84,8 +84,11 @@
|
||||||
:typecheck (comparitor-typecheck logical-type?)}
|
:typecheck (comparitor-typecheck logical-type?)}
|
||||||
'or {:desugar (left-binop-desugar 'or)
|
'or {:desugar (left-binop-desugar 'or)
|
||||||
:typecheck (comparitor-typecheck logical-type?)}
|
:typecheck (comparitor-typecheck logical-type?)}
|
||||||
'def {:typecheck (r/rewrite (_ ?t) [[?t ?t]])
|
'def {:desugar (r/rewrite
|
||||||
:new-bindings (fn [form _ctx] (m/match form ('def {:name ?symbol} ?expr) {?symbol (list 'l/global {:name ?symbol})}))}
|
('def (m/pred symbol? ?name) ?expr) ('def {:name ?name} ?expr))
|
||||||
|
:typecheck (r/rewrite (_ ?t) [[?t ?t]])
|
||||||
|
:new-bindings (fn [form _ctx] (m/match form ('def {:name ?symbol} ?expr) {?symbol (list 'l/global {:name ?symbol})}))
|
||||||
|
:mark-bound-subexpressions (r/rewrite ('def (m/and ?m {:name ?symbol}) ?expr) ('def ?m (m+ {:binding ?symbol} ?expr)))}
|
||||||
'do {:typecheck (r/rewrite (_) [['void]]
|
'do {:typecheck (r/rewrite (_) [['void]]
|
||||||
(_ . !stmt ... ?last) [[?last . (m/app (constantly 'void) !stmt) ... ?last]])
|
(_ . !stmt ... ?last) [[?last . (m/app (constantly 'void) !stmt) ... ?last]])
|
||||||
:scope {}}
|
:scope {}}
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
(ns tock.compiler.type
|
(ns tock.compiler.type
|
||||||
(:require [meander.epsilon :as m]
|
(:require [meander.epsilon :as m]
|
||||||
[meander.strategy.epsilon :as r]
|
[meander.strategy.epsilon :as r]
|
||||||
[tock.compiler.meander :refer [bottom-up m+] :include-macros true]
|
[tock.compiler.meander :refer [bottom-up m+ merge-metafield] :include-macros true]
|
||||||
[tock.compiler.util :refer [lookup get-meta get-special lookup update-binding!]]))
|
[tock.compiler.util :refer [lookup get-meta get-special lookup update-binding!]]))
|
||||||
|
|
||||||
; typechecking happens bottom-up. by the time a node is called to be typechecked, the system has verified that all of the children
|
; typechecking happens bottom-up. by the time a node is called to be typechecked, the system has verified that all of the children
|
||||||
|
@ -45,8 +45,8 @@
|
||||||
|
|
||||||
; propogate type back to binding
|
; propogate type back to binding
|
||||||
(m/match rewrite
|
(m/match rewrite
|
||||||
(m+ {:ctx ?ctx :name ?name :type ?type} _)
|
(_ {:ctx (m/some ?ctx) :binding (m/some ?name) :type (m/some ?type)} . _ ...)
|
||||||
(update-binding! ?ctx ?name assoc :type ?type)
|
(update-binding! ?ctx ?name merge-metafield {:type ?type})
|
||||||
|
|
||||||
_ nil)
|
_ nil)
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue