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
|
||||
(:require [meander.epsilon :as m]
|
||||
[meander.strategy.epsilon :as r]
|
||||
[tock.compiler.meander :refer [meta-split label typed m+]]))
|
||||
|
||||
;; 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
|
||||
[tock.compiler.specials :refer [specials]]
|
||||
[tock.compiler.meander :refer [meta-split typed label preserving-meta]]))
|
||||
|
||||
(def leaf-pass
|
||||
(r/bottom-up
|
||||
|
@ -34,41 +21,41 @@
|
|||
(typed ?form ?symbol)
|
||||
|
||||
(meta-split {:fn [!type ... '-> ?return-type]} ?form)
|
||||
(typed ?form ['fn !type ... ?return-type])
|
||||
(typed ?form ['fn . !type ... ?return-type])
|
||||
|
||||
(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/until =
|
||||
(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
|
||||
[(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
|
||||
('fn (m/pred symbol? ?name) & ?rest) ('def ?name ('fn & ?rest))
|
||||
('fn [!names ... '-> ?return-type] & ?body) (l/fn [!names ... (label ?return-type "return type")] & ?body)
|
||||
('fn [!names ...] & ?body) (l/fn [!names ... 'void] & ?body))
|
||||
])
|
||||
(defn make-lookup-pass [specials]
|
||||
(r/rewrite
|
||||
(meta-split ?meta (m/pred symbol? ?sym))
|
||||
(meta-split ?meta ('l/read ?sym))
|
||||
|
||||
(def tock-parse-errors
|
||||
[(r/rewrite ('if) "if statement needs at least a condition and a body"
|
||||
('if _) "if statement needs at least one body expression")
|
||||
])
|
||||
(meta-split ?meta
|
||||
((m/pred #(and (symbol? %) (get-in specials [% :leaf])) ?special) . !args ...))
|
||||
(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
|
||||
([form] (desugar form tock-sugars))
|
||||
([form sugars]
|
||||
(let [desugar-pass (make-desugar-pass sugars)]
|
||||
([form] (desugar form specials))
|
||||
([form specials]
|
||||
(let [desugar-pass (make-desugar-pass specials)
|
||||
lookup-pass (make-lookup-pass specials)]
|
||||
(-> form
|
||||
leaf-pass
|
||||
type-cleanup-pass
|
||||
desugar-pass))))
|
||||
desugar-pass
|
||||
lookup-pass))))
|
||||
|
|
|
@ -3,9 +3,14 @@
|
|||
[meander.syntax.epsilon :as r.syntax]))
|
||||
|
||||
(defn m+ [more-meta val]
|
||||
(if (satisfies? #?(:clj clojure.lang.IObj :cljs IWithMeta) val)
|
||||
(with-meta val (merge (meta val) more-meta))
|
||||
val))
|
||||
(with-meta val (merge (meta val) more-meta)))
|
||||
|
||||
(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]
|
||||
(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