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

Fix "if", cleanup clj-kondo warnings, pointless indirection

Browse source
This commit is contained in:
Jeremy Penner 2024-08-06 22:30:42 -04:00
parent 7bf14eb508
commit 56299b20c3
8 changed files with 63 additions and 53 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
.vscode/settings.json vendored Normal file
View file

@ -0,0 +1,14 @@
{
"calva.replConnectSequences": [
{
"name": "Experiment",
"autoSelectForJackIn": true,
"projectType": "shadow-cljs",
"cljsType": "shadow-cljs",
"menuSelections": {
"cljsDefaultBuild": "experiment",
"cljsLaunchBuilds": ["experiment"]
}
}
]
}

4
src/main/tock/compiler.cljc
View file

@ -49,8 +49,8 @@
(typecheck specials)
(collect-definitions program))))
(defn compile
([forms] (compile forms specials))
(defn compile-wasm
([forms] (compile-wasm forms specials))
([forms specials]
(-> (reduce compile-form (make-empty-program specials) forms)
generate-wasm)))

2
src/main/tock/compiler/bind.cljc
View file

@ -1,7 +1,7 @@
(ns tock.compiler.bind
(:require [meander.epsilon :as m]
[tock.compiler.util :refer [get-special new-scope bind! lookup]]
[tock.compiler.meander :refer [bottom-up all-subexpressions m+ merge-metafield]]))
[tock.compiler.meander :refer [bottom-up all-subexpressions merge-metafield]]))
(defn decorate-ctx [specials ctx form]
(let [special (get-special specials form)

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

@ -1,7 +1,6 @@
(ns tock.compiler.desugar
(:require [meander.epsilon :as m]
[meander.strategy.epsilon :as r]
[tock.compiler.specials :refer [specials]]
[tock.compiler.meander :refer [parse-type to-sym label]]))
(def leaf-pass
@ -23,35 +22,32 @@
; [vectors] and {maps} are _not_ expressions and are parsed by special form's desugaring only
?syntax ?syntax)))
(defn make-desugar-pass [specials]
(let [desugar-strat (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))]
(r/until =
(r/rewrite
((m/cata ?special) ?m . (m/cata !args) ...)
(m/app desugar-strat (?special ?m . !args ...))
?form ?form))))
(defn desugar-pass [form specials]
(let [desugar-strat (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))
pass (r/until =
(r/rewrite
((m/cata ?special) ?m . (m/cata !args) ...)
(m/app desugar-strat (?special ?m . !args ...))
?form ?form))]
(pass form)))
(defn make-call-pass [specials]
(let [special? (fn [key] (and (symbol? key) (contains? specials key)))]
(r/rewrite
(m/and (m/pred symbol? ?sym) (m/app meta ?m)) ('l/lookup {:name ?sym & ?m})
(defn call-pass [form specials]
(let [special? (fn [key] (and (symbol? key) (contains? specials key)))
pass (r/rewrite
(m/and (m/pred symbol? ?sym) (m/app meta ?m)) ('l/lookup {:name ?sym & ?m})
((m/pred special? ?special) ?m . (m/cata !args) ...)
(?special ?m . !args ...)
((m/cata ?func) ?m . (m/cata !args) ...)
('l/call ?m (label ?func "function") . (label !args "argument") ...)
?unknown ('l/compile-error {:form ?unknown :error "Unrecognized form"}))]
(pass form)))
((m/pred special? ?special) ?m . (m/cata !args) ...)
(?special ?m . !args ...)
((m/cata ?func) ?m . (m/cata !args) ...)
('l/call ?m (label ?func "function") . (label !args "argument") ...)
?unknown ('l/compile-error {:form ?unknown :error "Unrecognized form"}))))
(defn desugar
([form] (desugar form specials))
([form specials]
(let [desugar-pass (make-desugar-pass specials)
call-pass (make-call-pass specials)]
(-> form
leaf-pass
desugar-pass
call-pass
))))
(defn desugar [form specials]
(-> form
leaf-pass
(desugar-pass specials)
(call-pass specials)))

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

@ -10,6 +10,8 @@
(list? form) (apply list (first form) (merge (second form) m) (rest (rest form)))
:else (do (print "m+ " form meta "\n") form)))
(declare m+ label typed)
(m/defsyntax m+
[meta-pattern pattern]
(case (::r.syntax/phase &env)

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

@ -2,7 +2,8 @@
(:require [meander.epsilon :as m]
[meander.strategy.epsilon :as r]
[helins.wasm.bin :as op]
[tock.compiler.meander :refer [parse-type to-sym label m+]]))
[tock.compiler.meander :refer [parse-type to-sym label m+]]
[tock.compiler.wasm :refer [type-to-wasmtype]]))
;; no namespace - source symbol
;; l/sym - "lowered" form - special form not directly writable from source
@ -45,7 +46,7 @@
(m/match form
('l/if {:type ?type} ?cond ?l ?r)
(concat (emit ?cond)
[[op/if- [:wasm/valtype ?type] (emit ?l) (emit ?r)]])))}
[[op/if- [:wasm/valtype (type-to-wasmtype ?type)] (emit ?l) (emit ?r)]])))}
'l/fn
{:desugar (r/rewrite

6
src/main/tock/compiler/util.cljs → src/main/tock/compiler/util.cljc
View file

@ -1,9 +1,5 @@
(ns tock.compiler.util)
(defn compile-error [term message]
; todo: extract location of error term
(js/Error. [term message]))
; ctx is a vector of atoms of maps
(defn new-scope
([ctx base] (conj ctx (atom base)))
@ -26,4 +22,4 @@
(apply swap! (peek ctx) update key f rest))
(defn get-special [specials form] (get specials (first form)))
(defn get-meta [form key] (get (second form) key))
(defn get-meta [form key] (get (second form) key))

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

@ -1,24 +1,25 @@
(ns tock.experiment
(:require [helins.wasm :as wasm]
[helins.binf :as binf]
[tock.compiler :refer [compile]]
[cljs.pprint :as pp]))
[tock.compiler :refer [compile-wasm]]))
;; ; https://github.com/kalai-transpiler/kalai
(def test-wasm
(compile
(compile-wasm
'[(fn add [^f64 left ^f64 right -> f64] (+ left right))
(fn double [^f64 val -> f64] (* val 2))
(fn add_double [^f64 left ^f64 right -> f64] (double (add left right)))]))
(fn add_double [^bool add-first? ^f64 left ^f64 right -> f64]
(if add-first?
(double (add left right))
(add (double left) right)))]))
(defn decompile-url [url]
(-> (js/fetch url)
(.then #(.arrayBuffer %))
(.then #(let [v (binf/view %)]
(binf/endian-set v :little-endian)
(wasm/decompile v)))))
;; (defn decompile-url [url]
;; (-> (js/fetch url)
;; (.then #(.arrayBuffer %))
;; (.then #(let [v (binf/view %)]
;; (binf/endian-set v :little-endian)
;; (wasm/decompile v)))))
(defn instantiate-wasm [wasm importObject]
(-> (wasm/compile wasm)
@ -29,7 +30,7 @@
(defn main []
(js/console.log test-wasm)
(-> (instantiate-wasm test-wasm #js {})
(.then #(js/console.log (-> % (.-instance) (.-exports) (.add-double 2 3)))))
(.then (fn [^js x] (js/console.log (-> x (.-instance) (.-exports) (.add-double false 2 3))))))
;; (-> (decompile-url "release.wasm")
;; (.then #(js/console.log (-> % :wasm/exportsec :wasm.export/func (get 0)))))
)