Move specials to a lookup table, add call + read pass
This commit is contained in:
parent
f7fd4745b7
commit
58d756cd56
|
@ -1,21 +1,8 @@
|
||||||
(ns tock.compiler.desugar
|
(ns tock.compiler.desugar
|
||||||
(:require [meander.epsilon :as m]
|
(:require [meander.epsilon :as m]
|
||||||
[meander.strategy.epsilon :as r]
|
[meander.strategy.epsilon :as r]
|
||||||
[tock.compiler.meander :refer [meta-split label typed m+]]))
|
[tock.compiler.specials :refer [specials]]
|
||||||
|
[tock.compiler.meander :refer [meta-split typed label preserving-meta]]))
|
||||||
;; desugaring idea:
|
|
||||||
;; - each parameter to a special is decorated with a human-readable descriptor
|
|
||||||
;; as well as the original syntax object it corresponds to
|
|
||||||
|
|
||||||
(defn preserving-meta [strategy]
|
|
||||||
(fn [term]
|
|
||||||
(let [new-term (strategy term)]
|
|
||||||
(m+ (merge (meta new-term) (meta term)) new-term))))
|
|
||||||
|
|
||||||
;; no namespace - source symbol
|
|
||||||
;; l/sym - "lowered" form - special form not directly writable from source
|
|
||||||
;; i/sym - intermediate symbol meant to be recursively expanded into a canonical
|
|
||||||
;; lowered form
|
|
||||||
|
|
||||||
(def leaf-pass
|
(def leaf-pass
|
||||||
(r/bottom-up
|
(r/bottom-up
|
||||||
|
@ -34,41 +21,41 @@
|
||||||
(typed ?form ?symbol)
|
(typed ?form ?symbol)
|
||||||
|
|
||||||
(meta-split {:fn [!type ... '-> ?return-type]} ?form)
|
(meta-split {:fn [!type ... '-> ?return-type]} ?form)
|
||||||
(typed ?form ['fn !type ... ?return-type])
|
(typed ?form ['fn . !type ... ?return-type])
|
||||||
|
|
||||||
(meta-split {:fn [!type ...]} ?form)
|
(meta-split {:fn [!type ...]} ?form)
|
||||||
(typed ?form ['fn !type ... 'void])))))
|
(typed ?form ['fn . !type ... 'void])))))
|
||||||
|
|
||||||
(defn make-desugar-pass [sugars]
|
(defn make-desugar-pass [specials]
|
||||||
(r/top-down
|
(r/top-down
|
||||||
(r/until =
|
(r/until =
|
||||||
(preserving-meta
|
(preserving-meta
|
||||||
(apply r/pipe (map r/attempt sugars))))))
|
(apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))))))
|
||||||
|
|
||||||
(def tock-sugars
|
(defn make-lookup-pass [specials]
|
||||||
[(r/rewrite
|
|
||||||
('if ?cond ?body & ?more) (i/if ?cond ?body & ?more)
|
|
||||||
(i/if) ('do)
|
|
||||||
(i/if ?else) (label ?else "else block")
|
|
||||||
(i/if ?cond ?body & ?more) (l/if (label ?cond "condition")
|
|
||||||
(label ?body "body")
|
|
||||||
(i/if & ?more)))
|
|
||||||
(r/rewrite
|
(r/rewrite
|
||||||
('fn (m/pred symbol? ?name) & ?rest) ('def ?name ('fn & ?rest))
|
(meta-split ?meta (m/pred symbol? ?sym))
|
||||||
('fn [!names ... '-> ?return-type] & ?body) (l/fn [!names ... (label ?return-type "return type")] & ?body)
|
(meta-split ?meta ('l/read ?sym))
|
||||||
('fn [!names ...] & ?body) (l/fn [!names ... 'void] & ?body))
|
|
||||||
])
|
|
||||||
|
|
||||||
(def tock-parse-errors
|
(meta-split ?meta
|
||||||
[(r/rewrite ('if) "if statement needs at least a condition and a body"
|
((m/pred #(and (symbol? %) (get-in specials [% :leaf])) ?special) . !args ...))
|
||||||
('if _) "if statement needs at least one body expression")
|
(meta-split ?meta (?special . !args ...))
|
||||||
])
|
|
||||||
|
(meta-split ?meta
|
||||||
|
((m/pred #(and (symbol? %) (contains? specials %)) ?special) . (m/cata !args) ...))
|
||||||
|
(meta-split ?meta (?special . !args ...))
|
||||||
|
|
||||||
|
(meta-split ?meta
|
||||||
|
((m/pred #(or (not (symbol? %)) (not (contains? specials %))) (m/cata ?head)) . (m/cata !args) ...))
|
||||||
|
(meta-split ?meta ('l/call (label ?head "function") . (label !args "argument") ...))))
|
||||||
|
|
||||||
(defn desugar
|
(defn desugar
|
||||||
([form] (desugar form tock-sugars))
|
([form] (desugar form specials))
|
||||||
([form sugars]
|
([form specials]
|
||||||
(let [desugar-pass (make-desugar-pass sugars)]
|
(let [desugar-pass (make-desugar-pass specials)
|
||||||
|
lookup-pass (make-lookup-pass specials)]
|
||||||
(-> form
|
(-> form
|
||||||
leaf-pass
|
leaf-pass
|
||||||
type-cleanup-pass
|
type-cleanup-pass
|
||||||
desugar-pass))))
|
desugar-pass
|
||||||
|
lookup-pass))))
|
||||||
|
|
|
@ -3,9 +3,14 @@
|
||||||
[meander.syntax.epsilon :as r.syntax]))
|
[meander.syntax.epsilon :as r.syntax]))
|
||||||
|
|
||||||
(defn m+ [more-meta val]
|
(defn m+ [more-meta val]
|
||||||
(if (satisfies? #?(:clj clojure.lang.IObj :cljs IWithMeta) val)
|
(with-meta val (merge (meta val) more-meta)))
|
||||||
(with-meta val (merge (meta val) more-meta))
|
|
||||||
val))
|
(defn preserving-meta [strategy]
|
||||||
|
(fn [term]
|
||||||
|
(let [new-term (strategy term)]
|
||||||
|
(if (satisfies? #?(:clj clojure.lang.IObj :cljs IWithMeta) new-term)
|
||||||
|
(with-meta new-term (merge (meta term) (meta new-term)))
|
||||||
|
new-term))))
|
||||||
|
|
||||||
(m/defsyntax meta-split [meta-pattern pattern]
|
(m/defsyntax meta-split [meta-pattern pattern]
|
||||||
(case (::r.syntax/phase &env)
|
(case (::r.syntax/phase &env)
|
||||||
|
|
61
src/main/tock/compiler/specials.cljc
Normal file
61
src/main/tock/compiler/specials.cljc
Normal file
|
@ -0,0 +1,61 @@
|
||||||
|
(ns tock.compiler.specials
|
||||||
|
(:require [meander.epsilon :as m]
|
||||||
|
[meander.strategy.epsilon :as r]
|
||||||
|
[tock.compiler.meander :refer [meta-split label typed]]))
|
||||||
|
|
||||||
|
;; no namespace - source symbol
|
||||||
|
;; l/sym - "lowered" form - special form not directly writable from source
|
||||||
|
;; i/sym - intermediate symbol meant to be recursively expanded into a canonical
|
||||||
|
;; lowered form
|
||||||
|
(defn left-associative [symbol]
|
||||||
|
(r/rewrite
|
||||||
|
(~symbol ?left ?right . !more ..1) (~symbol (~symbol ?left ?right) !more ...)))
|
||||||
|
|
||||||
|
(defn simple-identity [symbol]
|
||||||
|
(r/rewrite (~symbol ?v) ?v))
|
||||||
|
|
||||||
|
(defn left-binop-desugar [symbol]
|
||||||
|
(r/choice (left-associative symbol) (simple-identity symbol)))
|
||||||
|
|
||||||
|
(def specials
|
||||||
|
{'l/if
|
||||||
|
{:desugar (r/rewrite
|
||||||
|
('if ?cond ?body & ?more) (i/if ?cond ?body & ?more)
|
||||||
|
(i/if) ('do)
|
||||||
|
(i/if ?else) (label ?else "else block")
|
||||||
|
(i/if ?cond ?body & ?more) (l/if (label ?cond "condition")
|
||||||
|
(label ?body "body")
|
||||||
|
(i/if & ?more)))
|
||||||
|
:validate (r/rewrite ('if) "if statement needs at least a condition and a body"
|
||||||
|
('if _) "if statement needs at least one body expression")}
|
||||||
|
|
||||||
|
'l/fn
|
||||||
|
{:desugar (r/rewrite
|
||||||
|
('fn (m/pred symbol? ?name) & ?rest) (meta-split {:name ?name} ('def ('fn & ?rest)))
|
||||||
|
('fn [!names ... '-> ?return-type] & ?body) (i/fn [!names ... (label ?return-type "return type")] & ?body)
|
||||||
|
('fn [!names ...] & ?body) (i/fn [!names ... 'void] & ?body)
|
||||||
|
|
||||||
|
('i/fn [(typed !names !types) ... ?return-type] & ?body)
|
||||||
|
(meta-split {:type ['fn !types ... ?return-type]
|
||||||
|
:params [!names ...]}
|
||||||
|
('l/fn ('do & ?body))))}
|
||||||
|
'+ {:desugar (left-binop-desugar '+)}
|
||||||
|
'-
|
||||||
|
{:desugar (r/choice
|
||||||
|
(r/rewrite ('- ?v) ('- ('l/lit 0) ?v))
|
||||||
|
(left-associative '-))}
|
||||||
|
'* {:desugar (left-binop-desugar '*)}
|
||||||
|
'/ {:desugar (left-binop-desugar '/)}
|
||||||
|
'= {}
|
||||||
|
'not= {}
|
||||||
|
'< {}
|
||||||
|
'<= {}
|
||||||
|
'> {}
|
||||||
|
'>= {}
|
||||||
|
'and {:desugar (left-binop-desugar 'and)}
|
||||||
|
'or {:desugar (left-binop-desugar 'or)}
|
||||||
|
'def {}
|
||||||
|
'do {}
|
||||||
|
'l/lit {:leaf true}
|
||||||
|
'l/read {:leaf true}
|
||||||
|
'l/call {}})
|
Loading…
Reference in a new issue