SpindleyQ/tock
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Move specials to a lookup table, add call + read pass

Browse source
This commit is contained in:
Jeremy Penner 2024-07-14 21:48:38 -04:00
parent f7fd4745b7
commit 58d756cd56
3 changed files with 97 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
src/main/tock/compiler/desugar.cljc
View file

@ -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)))
(defn make-lookup-pass [specials]
(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))
])
(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))))

11
src/main/tock/compiler/meander.cljc
View file

@ -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
View 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 {}})