coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Step 10d: fix scope form compilation for non-keyword args

Browse Source 
compile-expr args instead of keyword-name — handles (context "name"),
(context var), and (context :name) uniformly. Fixes freeze.sx .sxbc
compilation (was failing with "keyword-name: expected keyword").

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-05 13:28:17 +00:00
parent 2cf4c73ab3
commit a74c983615
6 changed files with 1882 additions and 1314 deletions
Download Patch File Download Diff File Expand all files Collapse all files

215
shared/static/wasm/sx/compiler.sx
View File

@@ -303,6 +303,62 @@
(compile-letrec em args scope tail?)
(= name "match")
(compile-match em args scope tail?)
(= name "guard")
(compile-guard em args scope tail?)
(= name "raise")
(do
(compile-expr em (first args) scope false)
(emit-op em 37))
(= name "scope")
(compile-scope em args scope tail?)
(= name "provide")
(compile-provide em args scope tail?)
(= name "context")
(do
(compile-expr em (first args) scope false)
(if
(> (len args) 1)
(do
(compile-expr em (nth args 1) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "context"))
(emit-byte em 2))
(do
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "context"))
(emit-byte em 1))))
(= name "peek")
(do
(compile-expr em (first args) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-peek"))
(emit-byte em 1))
(= name "provide!")
(do
(compile-expr em (first args) scope false)
(compile-expr em (nth args 1) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "provide-set!"))
(emit-byte em 2))
(= name "bind")
(do
(compile-expr em (first args) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "bind"))
(emit-byte em 1))
(= name "emit!")
(do
(compile-expr em (first args) scope false)
(compile-expr em (nth args 1) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-emit!"))
(emit-byte em 2))
(= name "emitted")
(do
(compile-expr em (first args) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-emitted"))
(emit-byte em 1))
(= name "perform")
(let
()
@@ -455,8 +511,8 @@
(args)
(let
((first-arg (first args)))
(if (dict? first-arg)
;; Variant 2: (let-match {:k v} expr body...)
(if
(dict? first-arg)
(let
((pattern first-arg)
(expr (nth args 1))
@@ -465,28 +521,36 @@
(bindings (list)))
(append! bindings (list src-sym expr))
(for-each
(fn (k)
(append! bindings
(list (get pattern k)
(fn
(k)
(append!
bindings
(list
(get pattern k)
(list (make-symbol "get") src-sym (str k)))))
(keys pattern))
(cons bindings body))
;; Variant 1: (let-match name expr {:k v} body...)
(let
((name-sym first-arg)
(expr (nth args 1))
(pattern (nth args 2))
(body (slice args 3))
(src-sym (if (= (str name-sym) "_")
(make-symbol "__lm_tmp")
name-sym))
(src-sym
(if
(= (str name-sym) "_")
(make-symbol "__lm_tmp")
name-sym))
(bindings (list)))
(append! bindings (list src-sym expr))
(when (dict? pattern)
(when
(dict? pattern)
(for-each
(fn (k)
(append! bindings
(list (get pattern k)
(fn
(k)
(append!
bindings
(list
(get pattern k)
(list (make-symbol "get") src-sym (str k)))))
(keys pattern)))
(cons bindings body))))))
@@ -925,4 +989,129 @@
{:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))))) ;; end define-library
;; Re-export to global namespace for backward compatibility
(define
compile-provide
(fn
(em args scope tail?)
(let
((first-arg (first args))
(name
(cond
(= (type-of first-arg) "keyword")
(keyword-name first-arg)
(= (type-of first-arg) "string")
first-arg
:else (symbol-name first-arg)))
(val-expr (nth args 1))
(body (slice args 2))
(name-idx (pool-add (get em "pool") name)))
(emit-op em 1)
(emit-u16 em name-idx)
(compile-expr em val-expr scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if (empty? body) (emit-op em 2) (compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))))
(define
compile-scope
(fn
(em args scope tail?)
(let
((first-arg (first args))
(name
(if
(= (type-of first-arg) "keyword")
(keyword-name first-arg)
(symbol-name first-arg)))
(rest-args (rest args))
(name-idx (pool-add (get em "pool") name)))
(if
(and
(>= (len rest-args) 2)
(= (type-of (first rest-args)) "keyword")
(= (keyword-name (first rest-args)) "value"))
(let
((val-expr (nth rest-args 1)) (body (slice rest-args 2)))
(emit-op em 1)
(emit-u16 em name-idx)
(compile-expr em val-expr scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))
(let
((body rest-args))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 2)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))))))
(define
compile-guard-clauses
(fn
(em clauses scope var-slot tail?)
(if
(empty? clauses)
(do (emit-op em 16) (emit-byte em var-slot) (emit-op em 37))
(let
((clause (first clauses))
(rest-clauses (rest clauses))
(test (first clause))
(body (rest clause)))
(if
(or
(and
(= (type-of test) "keyword")
(= (keyword-name test) "else"))
(= test true))
(compile-begin em body scope tail?)
(do
(compile-expr em test scope false)
(emit-op em 33)
(let
((skip (current-offset em)))
(emit-i16 em 0)
(compile-begin em body scope tail?)
(emit-op em 32)
(let
((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
(compile-guard-clauses em rest-clauses scope var-slot tail?)
(patch-i16
em
end-jump
(- (current-offset em) (+ end-jump 2)))))))))))
(import (sx compiler))