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

desugar specials into maps

Browse source
This commit is contained in:
Jeremy Penner 2024-07-14 22:45:34 -04:00
parent 58d756cd56
commit a362729acc
3 changed files with 27 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -9,16 +9,17 @@
(preserving-meta (preserving-meta
(r/attempt (r/attempt
(r/rewrite (r/rewrite
(m/pred symbol? ?sym) (m/app #(symbol (name %)) ?sym) (m/pred symbol? ?sym) (m/app #(symbol (name %)) ?sym)
(m/pred number? ?num) ('l/lit ?num) (m/pred integer? ?num) (typed (l/lit ?num) 'i64)
(m/pred boolean? ?b) (typed ('l/lit ?b) 'bool)))))) (m/pred double? ?num) (typed (l/lit ?num) 'f64)
(m/pred boolean? ?b) (typed (l/lit ?b) 'bool))))))
(def type-cleanup-pass (def type-cleanup-pass
(r/bottom-up (r/bottom-up
(r/attempt (r/attempt
(r/rewrite (r/rewrite
(meta-split {:tag (m/some ?symbol)} ?form) (meta-split {:tag (m/some ?symbol)} ?form)
(typed ?form ?symbol) (typed ?form (m/app #(symbol (name %)) ?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])
@ -32,30 +33,29 @@
(preserving-meta (preserving-meta
(apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials)))))) (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))))))
(defn make-lookup-pass [specials] (defn make-structure-pass [specials]
(r/rewrite (let [special? (fn [key] (and (symbol? key) (contains? specials key)))]
(meta-split ?meta (m/pred symbol? ?sym)) (r/rewrite
(meta-split ?meta ('l/read ?sym)) (meta-split ?meta (m/pred symbol? ?sym))
(m/app merge ?meta {:special 'l/read :name ?sym})
(meta-split ?meta
((m/pred #(and (symbol? %) (get-in specials [% :leaf])) ?special) . !args ...)) (meta-split ?meta ('l/lit ?val))
(meta-split ?meta (?special . !args ...)) (m/app merge ?meta {:special 'l/lit :val ?val})
(meta-split ?meta (meta-split ?meta ((m/pred special? ?special) . (m/cata !args) ...))
((m/pred #(and (symbol? %) (contains? specials %)) ?special) . (m/cata !args) ...)) (m/app merge ?meta {:special ?special :args [!args ...]})
(meta-split ?meta (?special . !args ...))
(meta-split ?meta ((m/pred #(not (special? %)) (m/cata ?func)) . (m/cata !args) ...))
(meta-split ?meta (m/app merge ?meta {:special 'l/call :args [(label ?func "function") . (label !args "argument") ...]}))))
((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 specials)) ([form] (desugar form specials))
([form specials] ([form specials]
(let [desugar-pass (make-desugar-pass specials) (let [desugar-pass (make-desugar-pass specials)
lookup-pass (make-lookup-pass specials)] structure-pass (make-structure-pass specials)]
(-> form (-> form
leaf-pass leaf-pass
type-cleanup-pass type-cleanup-pass
desugar-pass desugar-pass
lookup-pass)))) structure-pass
))))

9
src/main/tock/compiler/specials.cljc
View file

@ -36,14 +36,14 @@
('fn [!names ...] & ?body) (i/fn [!names ... 'void] & ?body) ('fn [!names ...] & ?body) (i/fn [!names ... 'void] & ?body)
('i/fn [(typed !names !types) ... ?return-type] & ?body) ('i/fn [(typed !names !types) ... ?return-type] & ?body)
(meta-split {:type ['fn !types ... ?return-type] (meta-split {:type ['fn . !types ... ?return-type]
:params [!names ...]} :params [!names ...]}
('l/fn ('do & ?body))))} ('l/fn ('do & ?body))))}
'+ {:desugar (left-binop-desugar '+)} '+ {:desugar (left-binop-desugar '+)}
'- '-
{:desugar (r/choice {:desugar (r/choice
(r/rewrite ('- ?v) ('- ('l/lit 0) ?v)) (r/rewrite ('- ?v) ('- 0 ?v))
(left-associative '-))} (left-associative '-))}
'* {:desugar (left-binop-desugar '*)} '* {:desugar (left-binop-desugar '*)}
'/ {:desugar (left-binop-desugar '/)} '/ {:desugar (left-binop-desugar '/)}
'= {} '= {}
@ -56,6 +56,5 @@
'or {:desugar (left-binop-desugar 'or)} 'or {:desugar (left-binop-desugar 'or)}
'def {} 'def {}
'do {} 'do {}
'l/lit {:leaf true} 'l/lit {}
'l/read {:leaf true}
'l/call {}}) 'l/call {}})

2
src/main/tock/experiment.cljs
View file

@ -27,7 +27,7 @@
#_{:clj-kondo/ignore [:clojure-lsp/unused-public-var]} #_{:clj-kondo/ignore [:clojure-lsp/unused-public-var]}
(defn main [] (defn main []
(js/console.log (desugar `(if true (thing bloop) false (blarp poop))))) (js/console.log (desugar `(fn add [^f64 left ^f64 right -> f64] (+ left right)))))
;; (js/console.log test-wasm) ;; (js/console.log test-wasm)
;; (-> (instantiate-wasm test-wasm #js {}) ;; (-> (instantiate-wasm test-wasm #js {})
;; (.then #(js/console.log (-> % (.-instance) (.-exports) (.add-double 2 3))))) ;; (.then #(js/console.log (-> % (.-instance) (.-exports) (.add-double 2 3)))))