coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
9b060ef8c575c2ef496803b2908afbbaa4e3bbe6
rose-ash/lib/tree-tools.sx
giles c0665ba58e Adopt Step 7 language features across SX codebase 
112 conversions across 19 .sx files using match, let-match, and pipe operators:

match (17): type/value dispatch replacing cond/if chains
  - lib/vm.sx: HO form dispatch (for-each/map/filter/reduce/some/every?)
  - lib/tree-tools.sx: node-display, node-matches?, rename, count, replace, free-symbols
  - lib/types.sx: narrow-type, substitute-in-type, infer-type, resolve-type
  - web/engine.sx: default-trigger, resolve-target, classify-trigger
  - web/deps.sx: scan-refs-walk, scan-io-refs-walk

let-match (89): dict destructuring replacing (get d "key") patterns
  - shared/page-functions.sx (20), blog/admin.sx (17), pub-api.sx (13)
  - events/ layouts/page/tickets/entries/forms (27 total)
  - specs-explorer.sx (7), federation/social.sx (3), lib/ small files (3)

-> pipes (6): replacing triple-chained gets in lib/vm.sx
  - frame-closure → closure-code → code-bytecode chains

Also: lib/vm.sx accessor upgrades (get vm "sp" → vm-sp vm throughout)

2650/2650 tests pass, zero regressions.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-04-04 20:49:02 +00:00

1366 lines
38 KiB
Plaintext
Raw Blame History

(define
path-str
:effects ()
(fn ((path :as list)) (str "[" (join "," (map str path)) "]")))
(define
annotate-tree
:effects ()
(fn
(exprs)
(let
((nodes (if (list? exprs) exprs (list exprs))))
(let
((result (list)))
(for-each
(fn (i) (annotate-node (nth nodes i) (list i) 0 result))
(range 0 (len nodes)))
(join "\n" result)))))
(define
annotate-node
:effects ()
(fn
(node path depth result)
(let
((indent (join "" (map (fn (_) " ") (range 0 depth))))
(label (path-str path)))
(if
(list? node)
(if
(empty? node)
(append! result (str indent label " ()"))
(let
((head (first node)) (head-str (node-display head)))
(if
(and
(<= (len node) 4)
(not (some (fn (c) (list? c)) (rest node))))
(append!
result
(str
indent
label
" ("
(join " " (map node-display node))
")"))
(do
(append! result (str indent label " (" head-str))
(for-each
(fn
(i)
(annotate-node
(nth node i)
(concat path (list i))
(+ depth 1)
result))
(range 1 (len node)))
(append! result (str indent " )"))))))
(append! result (str indent label " " (node-display node)))))))
(define
node-display
:effects ()
(fn
(node)
(match
(type-of node)
("nil" "nil")
("symbol" (symbol-name node))
("keyword" (str ":" (keyword-name node)))
("string"
(let
((s (if (> (len node) 40) (str (slice node 0 37) "...") node)))
(str "\"" s "\"")))
("number" (str node))
("boolean" (if node "true" "false"))
("list"
(if
(empty? node)
"()"
(str
"("
(node-display (first node))
(if (> (len node) 1) " ..." "")
")")))
("dict" "{...}")
(_ (str node)))))
(define
summarise
:effects ()
(fn
(exprs max-depth)
(let
((nodes (if (list? exprs) exprs (list exprs))) (result (list)))
(for-each
(fn (i) (summarise-node (nth nodes i) (list i) 0 max-depth result))
(range 0 (len nodes)))
(join "\n" result))))
(define
summarise-node
:effects ()
(fn
(node path depth max-depth result)
(let
((indent (join "" (map (fn (_) " ") (range 0 depth))))
(label (path-str path)))
(if
(list? node)
(if
(empty? node)
(append! result (str indent label " ()"))
(let
((head (first node)) (head-str (node-display head)))
(if
(>= depth max-depth)
(append!
result
(str
indent
label
" ("
head-str
(if
(> (len node) 1)
(str " ... " (- (len node) 1) " children")
"")
")"))
(do
(append! result (str indent label " (" head-str))
(for-each
(fn
(i)
(summarise-node
(nth node i)
(concat path (list i))
(+ depth 1)
max-depth
result))
(range 1 (len node)))
(append! result (str indent " )"))))))
(append! result (str indent label " " (node-display node)))))))
(define
read-subtree
:effects ()
(fn
(exprs path)
(let
((node (navigate exprs path)))
(if
(nil? node)
(str "Error: path " (path-str path) " not found")
(annotate-tree (list node))))))
(define
get-context
:effects ()
(fn
(exprs path)
(let
((result (list)) (nodes (if (list? exprs) exprs (list exprs))))
(for-each
(fn
(depth)
(let
((prefix (slice path 0 (+ depth 1)))
(node (navigate nodes prefix)))
(when
(not (nil? node))
(let
((label (path-str prefix))
(indent (join "" (map (fn (_) " ") (range 0 depth))))
(marker (if (= (+ depth 1) (len path)) "→ " " ")))
(if
(list? node)
(append!
result
(str indent marker label " " (node-summary node)))
(append!
result
(str indent marker label " " (node-display node))))))))
(range 0 (len path)))
(join "\n" result))))
(define
node-summary
:effects ()
(fn
(node)
(if
(or (not (list? node)) (empty? node))
(node-display node)
(let
((head (node-display (first node)))
(child-count (- (len node) 1)))
(if
(<= child-count 3)
(str "(" (join " " (map node-display node)) ")")
(str
"("
head
" "
(node-display (nth node 1))
(when (> child-count 1) (str " ... +" (- child-count 1)))
")"))))))
(define
find-all
:effects ()
(fn
(exprs pattern)
(let
((results (list)) (nodes (if (list? exprs) exprs (list exprs))))
(for-each
(fn (i) (find-in-node (nth nodes i) (list i) pattern results))
(range 0 (len nodes)))
results)))
(define
find-in-node
:effects ()
(fn
(node path pattern results)
(when
(node-matches? node pattern)
(append! results (list path (node-summary-short node))))
(when
(list? node)
(for-each
(fn
(i)
(find-in-node (nth node i) (concat path (list i)) pattern results))
(range 0 (len node))))))
(define
node-matches?
:effects ()
(fn
(node pattern)
(match
(type-of node)
("symbol" (contains? (symbol-name node) pattern))
("string" (contains? node pattern))
("list"
(if
(empty? node)
false
(some (fn (child) (node-matches? child pattern)) node)))
(_ false))))
(define
node-summary-short
:effects ()
(fn
(node)
(if
(list? node)
(if
(empty? node)
"()"
(let
((head (node-display (first node))))
(if
(> (len node) 3)
(str "(" head " " (node-display (nth node 1)) " ...)")
(str "(" (join " " (map node-display node)) ")"))))
(node-display node))))
(define
get-siblings
:effects ()
(fn
(exprs path)
(if
(empty? path)
"Error: root has no siblings"
(let
((parent-path (slice path 0 (- (len path) 1)))
(target-idx (last path))
(parent (navigate exprs parent-path)))
(if
(or (nil? parent) (not (list? parent)))
(str
"Error: parent at "
(path-str parent-path)
" not found or not a list")
(let
((result (list)))
(for-each
(fn
(i)
(let
((child (nth parent i))
(child-path (concat parent-path (list i)))
(marker (if (= i target-idx) "→ " " ")))
(append!
result
(str
marker
(path-str child-path)
" "
(if
(list? child)
(node-summary child)
(node-display child))))))
(range 0 (len parent)))
(join "\n" result)))))))
(define
validate
:effects ()
(fn
(exprs)
(let
((errors (list)) (nodes (if (list? exprs) exprs (list exprs))))
(for-each
(fn (i) (validate-node (nth nodes i) (list i) errors))
(range 0 (len nodes)))
(if (empty? errors) "OK" (join "\n" errors)))))
(define
validate-node
:effects ()
(fn
(node path errors)
(when
(list? node)
(when
(not (empty? node))
(let
((head (first node)))
(when
(and
(= (type-of head) "symbol")
(= (symbol-name head) "letrec")
(>= (len node) 2))
(let
((bindings (nth node 1)))
(when
(list? bindings)
(for-each
(fn
(i)
(let
((pair (nth bindings i)))
(when
(not
(and
(list? pair)
(>= (len pair) 2)
(= (type-of (first pair)) "symbol")))
(append!
errors
(str
"WARNING "
(path-str (concat path (list 1 i)))
": letrec binding "
i
" is not a (name value) pair: "
(node-display pair))))))
(range 0 (len bindings))))))
(when
(and
(= (type-of head) "symbol")
(or
(= (symbol-name head) "defisland")
(= (symbol-name head) "defcomp")))
(when
(< (len node) 4)
(append!
errors
(str
"ERROR "
(path-str path)
": "
(symbol-name head)
" has fewer than 3 args (name params body)"))))))
(for-each
(fn
(i)
(validate-node (nth node i) (concat path (list i)) errors))
(range 0 (len node))))))
(define
navigate
:effects ()
(fn
(exprs path)
(let
((nodes (if (list? exprs) exprs (list exprs))))
(reduce
(fn
(current idx)
(if
(or
(nil? current)
(not (list? current))
(>= idx (len current)))
nil
(nth current idx)))
nodes
path))))
(define
resolve-named-path
:effects ()
(fn
(exprs named-path)
(let
((segments (if (string? named-path) (split-path-string named-path) named-path))
(nodes (if (list? exprs) exprs (list exprs))))
(let
((result (reduce (fn (state segment) (if (nil? (get state "node")) state (let ((node (get state "node")) (path (get state "path"))) (if (not (list? node)) {:node nil :path path} (let ((idx (find-child-by-name node segment))) (if (nil? idx) {:node nil :path path} {:node (nth node idx) :path (concat path (list idx))})))))) {:node nodes :path (list)} segments)))
(get result "path")))))
(define
split-path-string
:effects ()
(fn
((s :as string))
(filter (fn (x) (not (= (trim x) ""))) (split s ">"))))
(define
find-child-by-name
:effects ()
(fn
(node name)
(let
((trimmed (trim name)) (result nil))
(for-each
(fn
(i)
(when
(nil? result)
(let
((child (nth node i)))
(when
(or
(and
(= (type-of child) "symbol")
(= (symbol-name child) trimmed))
(and
(list? child)
(not (empty? child))
(= (type-of (first child)) "symbol")
(= (symbol-name (first child)) trimmed)))
(set! result i)))))
(range 0 (len node)))
result)))
(define
replace-node
:effects ()
(fn
(exprs path new-source)
(let
((fragment (sx-parse new-source)))
(if
(empty? fragment)
{:error (str "Fragment parse error: empty result from: " new-source)}
(let
((new-node (if (= (len fragment) 1) (first fragment) (cons (make-symbol "begin") fragment)))
(result (tree-set exprs path new-node)))
(if (nil? result) {:error (str "Path not found: " (path-str path))} {:ok result}))))))
(define
insert-child
:effects ()
(fn
(exprs path index new-source)
(let
((fragment (sx-parse new-source)))
(if
(empty? fragment)
{:error (str "Failed to parse new source: " new-source)}
(let
((parent (navigate exprs path)))
(if
(or (nil? parent) (not (list? parent)))
{:error (str "Parent at " (path-str path) " not found or not a list")}
(if
(or (< index 0) (> index (len parent)))
{:error (str "Index " index " out of range for parent with " (len parent) " children")}
(let
((new-parent (concat (slice parent 0 index) fragment (slice parent index)))
(result (tree-set exprs path new-parent)))
(if (nil? result) {:error (str "Failed to set node at path " (path-str path))} {:ok result})))))))))
(define
delete-node
:effects ()
(fn
(exprs path)
(if
(empty? path)
{:error "Cannot delete root"}
(let
((parent-path (slice path 0 (- (len path) 1)))
(child-idx (last path))
(parent (navigate exprs parent-path)))
(if
(or (nil? parent) (not (list? parent)))
{:error (str "Parent not found or not a list: " (path-str parent-path))}
(if
(or (< child-idx 0) (>= child-idx (len parent)))
{:error (str "Index " child-idx " out of range")}
(let
((new-parent (list-remove parent child-idx))
(result (tree-set exprs parent-path new-parent)))
(if (nil? result) {:error "Failed to update tree"} {:ok result}))))))))
(define
wrap-node
:effects ()
(fn
(exprs path wrapper-source)
(let
((fragment (sx-parse wrapper-source)))
(if
(empty? fragment)
{:error (str "Wrapper parse error: empty result from: " wrapper-source)}
(let
((wrapper (first fragment)) (target (navigate exprs path)))
(if
(nil? target)
{:error (str "Path not found: " (path-str path))}
(let
((filled (replace-placeholder wrapper target)))
(if
(nil? filled)
{:error "Wrapper must contain _ as placeholder for the wrapped node"}
(let
((result (tree-set exprs path filled)))
(if (nil? result) {:error "Failed to update tree"} {:ok result}))))))))))
(define
replace-placeholder
:effects ()
(fn
(node replacement)
(match
(type-of node)
("symbol" (if (= (symbol-name node) "_") replacement nil))
("list"
(let
((found false)
(result
(map
(fn
(child)
(if
found
child
(if
(and
(= (type-of child) "symbol")
(= (symbol-name child) "_"))
(do (set! found true) replacement)
(if
(list? child)
(let
((sub (replace-placeholder child replacement)))
(if (nil? sub) child (do (set! found true) sub)))
child))))
node)))
(if found result nil)))
(_ nil))))
(define
tree-set
:effects ()
(fn
(exprs path new-node)
(let
((nodes (if (list? exprs) exprs (list exprs))))
(if
(empty? path)
(if (list? new-node) new-node (list new-node))
(tree-set-inner nodes path 0 new-node)))))
(define
tree-set-inner
:effects ()
(fn
(node path depth new-node)
(if
(not (list? node))
nil
(let
((idx (nth path depth)))
(if
(or (< idx 0) (>= idx (len node)))
nil
(if
(= depth (- (len path) 1))
(list-replace node idx new-node)
(let
((child (nth node idx))
(new-child (tree-set-inner child path (+ depth 1) new-node)))
(if (nil? new-child) nil (list-replace node idx new-child)))))))))
(define
list-replace
:effects ()
(fn
(lst idx val)
(map-indexed (fn (i item) (if (= i idx) val item)) lst)))
(define
list-insert
:effects ()
(fn (lst idx val) (concat (slice lst 0 idx) (list val) (slice lst idx))))
(define
list-remove
:effects ()
(fn (lst idx) (concat (slice lst 0 idx) (slice lst (+ idx 1)))))
(define
tree-diff
:effects ()
(fn
(exprs-a exprs-b)
(let
((nodes-a (if (list? exprs-a) exprs-a (list exprs-a)))
(nodes-b (if (list? exprs-b) exprs-b (list exprs-b)))
(results (list)))
(diff-children nodes-a nodes-b (list) results)
(if (empty? results) "No differences" (join "\n" results)))))
(define
diff-children
:effects ()
(fn
(list-a list-b path results)
(let
((len-a (len list-a))
(len-b (len list-b))
(min-len (if (< len-a len-b) len-a len-b)))
(for-each
(fn
(i)
(diff-node
(nth list-a i)
(nth list-b i)
(concat path (list i))
results))
(range 0 min-len))
(when
(> len-b min-len)
(for-each
(fn
(i)
(append!
results
(str
"ADDED "
(path-str (concat path (list i)))
" "
(node-summary-short (nth list-b i)))))
(range min-len len-b)))
(when
(> len-a min-len)
(for-each
(fn
(i)
(append!
results
(str
"REMOVED "
(path-str (concat path (list i)))
" "
(node-summary-short (nth list-a i)))))
(range min-len len-a))))))
(define
diff-node
:effects ()
(fn
(a b path results)
(cond
(and (list? a) (list? b))
(diff-children a b path results)
(and (not (list? a)) (not (list? b)))
(when
(not (= (node-display a) (node-display b)))
(append!
results
(str
"CHANGED "
(path-str path)
" "
(node-display a)
" → "
(node-display b))))
:else (append!
results
(str
"CHANGED "
(path-str path)
" "
(node-summary-short a)
" → "
(node-summary-short b))))))
(define
path-prefix?
:effects ()
(fn
(prefix path)
(if
(> (len prefix) (len path))
false
(let
((result true))
(for-each
(fn
(i)
(when
(not (= (nth prefix i) (nth path i)))
(set! result false)))
(range 0 (len prefix)))
result))))
(define
path-on-match-route?
:effects ()
(fn
(path match-paths)
(let
((found false))
(for-each
(fn
(i)
(when
(not found)
(let
((mp (first (nth match-paths i))))
(when
(or (path-prefix? path mp) (path-prefix? mp path))
(set! found true)))))
(range 0 (len match-paths)))
found)))
(define
annotate-focused
:effects ()
(fn
(exprs pattern)
(let
((nodes (if (list? exprs) exprs (list exprs)))
(match-paths (find-all nodes pattern))
(result (list)))
(for-each
(fn
(i)
(annotate-node-focused (nth nodes i) (list i) 0 match-paths result))
(range 0 (len nodes)))
(join "\n" result))))
(define
annotate-node-focused
:effects ()
(fn
(node path depth match-paths result)
(let
((indent (join "" (map (fn (_) " ") (range 0 depth))))
(label (path-str path)))
(if
(list? node)
(if
(empty? node)
(append! result (str indent label " ()"))
(let
((head (first node))
(head-str (node-display head))
(on-route (path-on-match-route? path match-paths)))
(if
on-route
(do
(append! result (str indent label " (" head-str))
(for-each
(fn
(i)
(annotate-node-focused
(nth node i)
(concat path (list i))
(+ depth 1)
match-paths
result))
(range 1 (len node)))
(append! result (str indent " )")))
(append!
result
(str
indent
label
" ("
head-str
(if
(> (len node) 1)
(str " ... " (- (len node) 1) " children")
"")
")")))))
(append! result (str indent label " " (node-display node)))))))
(define
annotate-paginated
:effects ()
(fn
(exprs offset limit)
(let
((nodes (if (list? exprs) exprs (list exprs))) (all-lines (list)))
(for-each
(fn (i) (annotate-node (nth nodes i) (list i) 0 all-lines))
(range 0 (len nodes)))
(let
((total (len all-lines))
(end (if (> (+ offset limit) total) total (+ offset limit)))
(sliced (slice all-lines offset end))
(header
(str
";; Lines "
offset
"-"
end
" of "
total
(if (< end total) " (more available)" " (complete)"))))
(str header "\n" (join "\n" sliced))))))
(define
rename-symbol
:effects ()
(fn
(exprs old-name new-name)
(let
((nodes (if (list? exprs) exprs (list exprs))))
(map (fn (node) (rename-in-node node old-name new-name)) nodes))))
(define
rename-in-node
:effects ()
(fn
(node old-name new-name)
(match
(type-of node)
("symbol"
(if (= (symbol-name node) old-name) (make-symbol new-name) node))
("list"
(map (fn (child) (rename-in-node child old-name new-name)) node))
(_ node))))
(define
count-renames
:effects ()
(fn
(exprs old-name)
(let
((nodes (if (list? exprs) exprs (list exprs))) (hits (list)))
(count-in-node nodes old-name hits)
(len hits))))
(define
count-in-node
:effects ()
(fn
(node old-name hits)
(match
(type-of node)
("symbol" (when (= (symbol-name node) old-name) (append! hits true)))
("list"
(for-each (fn (child) (count-in-node child old-name hits)) node))
(_ nil))))
(define
replace-by-pattern
:effects ()
(fn
(exprs pattern new-source)
(let
((nodes (if (list? exprs) exprs (list exprs)))
(matches (find-all nodes pattern)))
(if
(empty? matches)
{:error (str "No nodes matching pattern: " pattern)}
(let
((target-path (first (first matches)))
(fragment (sx-parse new-source)))
(if
(empty? fragment)
{:error (str "Failed to parse new source: " new-source)}
(let
((new-node (first fragment))
(result (tree-set nodes target-path new-node)))
(if (nil? result) {:error (str "Failed to set node at path " (path-str target-path))} {:ok result :path target-path}))))))))
(define
replace-all-by-pattern
:effects ()
(fn
(exprs pattern new-source)
(let
((nodes (if (list? exprs) exprs (list exprs)))
(matches (find-all nodes pattern))
(fragment (sx-parse new-source)))
(if
(empty? matches)
{:error (str "No nodes matching pattern: " pattern)}
(if
(empty? fragment)
{:error (str "Failed to parse new source: " new-source)}
(let
((new-node (first fragment)) (current nodes) (count 0))
(for-each
(fn
(i)
(let
((idx (- (- (len matches) 1) i))
(match (nth matches idx))
(target-path (first match))
(result (tree-set current target-path new-node)))
(when
(not (nil? result))
(set! current result)
(set! count (+ count 1)))))
(range 0 (len matches)))
{:count count :ok current}))))))
(define
insert-near-pattern
:effects ()
(fn
(exprs pattern position new-source)
(let
((nodes (if (list? exprs) exprs (list exprs)))
(matches (find-all nodes pattern)))
(if
(empty? matches)
{:error (str "No nodes matching pattern: " pattern)}
(let
((match-path (first (first matches)))
(fragment (sx-parse new-source)))
(if
(empty? fragment)
{:error (str "Failed to parse new source: " new-source)}
(if
(empty? match-path)
{:error "Cannot insert near root node"}
(let
((top-idx (first match-path))
(insert-idx
(if (= position "after") (+ top-idx 1) top-idx))
(new-node (first fragment))
(new-tree (list-insert nodes insert-idx new-node)))
{:ok new-tree :path (list insert-idx)}))))))))
(define
lint-file
:effects ()
(fn
(exprs)
(let
((nodes (if (list? exprs) exprs (list exprs))) (warnings (list)))
(for-each
(fn (i) (lint-node (nth nodes i) (list i) warnings))
(range 0 (len nodes)))
warnings)))
(define
lint-node
:effects ()
(fn
(node path warnings)
(when
(list? node)
(when
(not (empty? node))
(let
((head (first node))
(head-name
(if (= (type-of head) "symbol") (symbol-name head) "")))
(when
(or (= head-name "let") (= head-name "letrec"))
(when
(>= (len node) 2)
(let
((bindings (nth node 1)))
(when
(and (list? bindings) (empty? bindings))
(append!
warnings
(str
"WARN "
(path-str path)
": "
head-name
" with empty bindings"))))))
(when
(or (= head-name "defcomp") (= head-name "defisland"))
(when
(< (len node) 4)
(append!
warnings
(str
"ERROR "
(path-str path)
": "
head-name
" needs (name params body), has "
(- (len node) 1)
" args"))))
(when
(= head-name "define")
(let
((effective-len (len (filter (fn (x) (not (= (type-of x) "keyword"))) (rest node)))))
(when
(< effective-len 2)
(append!
warnings
(str "WARN " (path-str path) ": define with no body")))))
(when
(or (= head-name "defcomp") (= head-name "defisland"))
(when
(>= (len node) 3)
(let
((params (nth node 2)))
(when
(list? params)
(let
((seen (list)))
(for-each
(fn
(p)
(when
(= (type-of p) "symbol")
(let
((pname (symbol-name p)))
(when
(and
(not (= pname "&key"))
(not (= pname "&rest"))
(not (starts-with? pname "&")))
(when
(contains? seen pname)
(append!
warnings
(str
"ERROR "
(path-str path)
": duplicate param "
pname)))
(append! seen pname)))))
params))))))
(when
(= head-name "match")
(when
(>= (len node) 3)
(let
((clauses (rest (rest node)))
(patterns (map first clauses))
(has-wildcard
(some
(fn
(p)
(and
(symbol? p)
(not (= (symbol-name p) "true"))
(not (= (symbol-name p) "false"))))
patterns))
(has-else false))
(when
(not has-wildcard)
(append!
warnings
(str
"WARN "
(path-str path)
": match may be non-exhaustive (no catch-all pattern)"))))))
(for-each
(fn
(i)
(lint-node (nth node i) (concat path (list i)) warnings))
(range 0 (len node))))))))
(define
collect-free-symbols
:effects ()
(fn
(node)
(let
((result (list))
(seen (dict))
(special-forms
(dict
"if"
true
"when"
true
"cond"
true
"case"
true
"and"
true
"or"
true
"let"
true
"let*"
true
"letrec"
true
"lambda"
true
"fn"
true
"define"
true
"defcomp"
true
"defisland"
true
"defmacro"
true
"deftest"
true
"begin"
true
"do"
true
"quote"
true
"quasiquote"
true
"set!"
true
"->"
true
"reset"
true
"shift"
true
"deref"
true
"scope"
true
"provide"
true
"context"
true
"emit!"
true
"emitted"
true
"dynamic-wind"
true
"map"
true
"filter"
true
"reduce"
true
"for-each"
true
"some"
true
"every?"
true
"map-indexed"
true
"list"
true
"dict"
true
"str"
true
"cons"
true
"concat"
true)))
(define
add-sym
(fn
(name)
(when
(and
(not (has-key? seen name))
(not (has-key? special-forms name))
(not (starts-with? name ":")))
(dict-set! seen name true)
(append! result name))))
(define
extract-binding-names
(fn
(bindings)
(let
((names (dict)))
(for-each
(fn
(b)
(when
(list? b)
(let
((name (first b)))
(when
(= (type-of name) "symbol")
(dict-set! names (symbol-name name) true)))))
bindings)
names)))
(define
walk
(fn
(node bound)
(cond
(nil? node)
nil
(= (type-of node) "symbol")
(let
((name (symbol-name node)))
(when (not (has-key? bound name)) (add-sym name)))
(= (type-of node) "keyword")
nil
(not (list? node))
nil
(empty? node)
nil
:else (let
((head (first node)) (args (rest node)))
(if
(not (= (type-of head) "symbol"))
(for-each (fn (child) (walk child bound)) node)
(let
((hname (symbol-name head)))
(cond
(or (= hname "define") (= hname "defmacro"))
(when
(>= (len args) 2)
(let
((body-start (if (= (type-of (nth args 1)) "keyword") 3 1)))
(for-each
(fn (child) (walk child bound))
(slice args body-start))))
(or
(= hname "defcomp")
(= hname "defisland")
(= hname "deftest"))
(when
(>= (len args) 2)
(let
((params (nth args 1)) (param-names (dict)))
(when
(list? params)
(for-each
(fn
(p)
(when
(= (type-of p) "symbol")
(dict-set! param-names (symbol-name p) true)))
params))
(let
((new-bound (merge bound param-names)))
(for-each
(fn (child) (walk child new-bound))
(slice args 2)))))
(or (= hname "fn") (= hname "lambda"))
(when
(>= (len args) 2)
(let
((params (first args)) (param-names (dict)))
(when
(list? params)
(for-each
(fn
(p)
(cond
(= (type-of p) "symbol")
(dict-set! param-names (symbol-name p) true)
(list? p)
(when
(= (type-of (first p)) "symbol")
(dict-set!
param-names
(symbol-name (first p))
true))))
params))
(let
((new-bound (merge bound param-names)))
(for-each
(fn (child) (walk child new-bound))
(rest args)))))
(or (= hname "let") (= hname "let*") (= hname "letrec"))
(when
(>= (len args) 2)
(let
((bindings (first args))
(bind-names
(if
(list? (first args))
(extract-binding-names (first args))
(dict))))
(let
((new-bound (merge bound bind-names)))
(when
(list? bindings)
(for-each
(fn
(b)
(when
(and (list? b) (>= (len b) 2))
(walk
(nth b 1)
(if (= hname "letrec") new-bound bound))))
bindings))
(for-each
(fn (child) (walk child new-bound))
(rest args)))))
(= hname "quote")
nil
(= hname "set!")
(when
(>= (len args) 2)
(when
(= (type-of (first args)) "symbol")
(let
((name (symbol-name (first args))))
(when (not (has-key? bound name)) (add-sym name))))
(walk (nth args 1) bound))
:else (do
(when
(not (has-key? special-forms hname))
(when (not (has-key? bound hname)) (add-sym hname)))
(for-each (fn (child) (walk child bound)) args)))))))))
(walk node (dict))
result)))
(define
find-use-declarations
:effects ()
(fn
(nodes)
(let
((uses (list)))
(for-each
(fn
(node)
(when
(and
(list? node)
(>= (len node) 2)
(= (type-of (first node)) "symbol")
(= (symbol-name (first node)) "use"))
(for-each
(fn
(arg)
(cond
(= (type-of arg) "symbol")
(append! uses (symbol-name arg))
(= (type-of arg) "string")
(append! uses arg)))
(rest node))))
(if (list? nodes) nodes (list nodes)))
uses)))
Reference in New Issue View Git Blame Copy Permalink