giles
9b060ef8c5
The bytecode compiler now handles let-match (both variants):
- Variant 1: (let-match name expr {:k v} body...) — named binding + destructure
- Variant 2: (let-match {:k v} expr body...) — pattern-only destructure
Desugars to sequential let + get calls — no new opcodes needed.
This was the last blocker for SPA navigation. The bytecoded orchestration
and router modules used let-match which compiled to CALL_PRIM "let-match"
(undefined at runtime). Now desugared at compile time.
Also synced dist/sx/ sources with web/ and recompiled all 26 .sxbc modules.
2650/2650 tests pass.
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
929 lines
35 KiB
Plaintext
929 lines
35 KiB
Plaintext
;; ==========================================================================
|
|
;; compiler.sx — SX bytecode compiler
|
|
;;
|
|
;; Compiles SX AST to bytecode for the platform-native VM.
|
|
;; Written in SX — runs on any platform with an SX evaluator.
|
|
;;
|
|
;; Architecture:
|
|
;; Pass 1: Scope analysis — resolve variables, detect tail positions
|
|
;; Pass 2: Code generation — emit bytecode
|
|
;;
|
|
;; The compiler produces Code objects (bytecode + constant pool).
|
|
;; The VM executes them with a stack machine model.
|
|
;; ==========================================================================
|
|
;; --------------------------------------------------------------------------
|
|
;; Constant pool builder
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-library
|
|
(sx compiler)
|
|
(export
|
|
make-pool
|
|
pool-add
|
|
make-scope
|
|
scope-define-local
|
|
scope-resolve
|
|
make-emitter
|
|
emit-byte
|
|
emit-u16
|
|
emit-i16
|
|
emit-op
|
|
emit-const
|
|
current-offset
|
|
patch-i16
|
|
compile-expr
|
|
compile-symbol
|
|
compile-dict
|
|
compile-list
|
|
compile-if
|
|
compile-when
|
|
compile-and
|
|
compile-or
|
|
compile-begin
|
|
compile-let
|
|
desugar-let-match
|
|
compile-letrec
|
|
compile-lambda
|
|
compile-define
|
|
compile-set
|
|
compile-quote
|
|
compile-cond
|
|
compile-case
|
|
compile-case-clauses
|
|
compile-match
|
|
compile-thread
|
|
compile-thread-step
|
|
compile-defcomp
|
|
compile-defmacro
|
|
compile-quasiquote
|
|
compile-qq-expr
|
|
compile-qq-list
|
|
compile-call
|
|
compile
|
|
compile-module)
|
|
(begin
|
|
(define make-pool (fn () {:entries (if (primitive? "mutable-list") (mutable-list) (list)) :index {:_count 0}}))
|
|
(define
|
|
pool-add
|
|
(fn
|
|
(pool value)
|
|
"Add a value to the constant pool, return its index. Deduplicates."
|
|
(let
|
|
((key (serialize value)) (idx-map (get pool "index")))
|
|
(if
|
|
(has-key? idx-map key)
|
|
(get idx-map key)
|
|
(let
|
|
((idx (get idx-map "_count")))
|
|
(dict-set! idx-map key idx)
|
|
(dict-set! idx-map "_count" (+ idx 1))
|
|
(append! (get pool "entries") value)
|
|
idx)))))
|
|
(define make-scope (fn (parent) {:next-slot 0 :upvalues (list) :locals (list) :parent parent :is-function false}))
|
|
(define
|
|
scope-define-local
|
|
(fn
|
|
(scope name)
|
|
"Add a local variable, return its slot index.\n Idempotent: if name already has a slot, return it."
|
|
(let
|
|
((existing (first (filter (fn (l) (= (get l "name") name)) (get scope "locals")))))
|
|
(if
|
|
existing
|
|
(get existing "slot")
|
|
(let
|
|
((slot (get scope "next-slot")))
|
|
(append! (get scope "locals") {:mutable false :slot slot :name name})
|
|
(dict-set! scope "next-slot" (+ slot 1))
|
|
slot)))))
|
|
(define
|
|
scope-resolve
|
|
(fn
|
|
(scope name)
|
|
"Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.\n Upvalue captures only happen at function boundaries (is-function=true).\n Let scopes share the enclosing function's frame — their locals are\n accessed directly without upvalue indirection."
|
|
(if
|
|
(nil? scope)
|
|
{:index name :type "global"}
|
|
(let
|
|
((locals (get scope "locals"))
|
|
(found (some (fn (l) (= (get l "name") name)) locals)))
|
|
(if
|
|
found
|
|
(let
|
|
((local (first (filter (fn (l) (= (get l "name") name)) locals))))
|
|
{:index (get local "slot") :type "local"})
|
|
(let
|
|
((upvals (get scope "upvalues"))
|
|
(uv-found
|
|
(some (fn (u) (= (get u "name") name)) upvals)))
|
|
(if
|
|
uv-found
|
|
(let
|
|
((uv (first (filter (fn (u) (= (get u "name") name)) upvals))))
|
|
{:index (get uv "uv-index") :type "upvalue"})
|
|
(let
|
|
((parent (get scope "parent")))
|
|
(if
|
|
(nil? parent)
|
|
{:index name :type "global"}
|
|
(let
|
|
((parent-result (scope-resolve parent name)))
|
|
(if
|
|
(= (get parent-result "type") "global")
|
|
parent-result
|
|
(if
|
|
(get scope "is-function")
|
|
(let
|
|
((uv-idx (len (get scope "upvalues"))))
|
|
(append! (get scope "upvalues") {:index (get parent-result "index") :is-local (= (get parent-result "type") "local") :uv-index uv-idx :name name})
|
|
{:index uv-idx :type "upvalue"})
|
|
parent-result))))))))))))
|
|
(define make-emitter (fn () {:pool (make-pool) :bytecode (if (primitive? "mutable-list") (mutable-list) (list))}))
|
|
(define emit-byte (fn (em byte) (append! (get em "bytecode") byte)))
|
|
(define
|
|
emit-u16
|
|
(fn
|
|
(em value)
|
|
(emit-byte em (mod value 256))
|
|
(emit-byte em (mod (floor (/ value 256)) 256))))
|
|
(define
|
|
emit-i16
|
|
(fn
|
|
(em value)
|
|
(let
|
|
((v (if (< value 0) (+ value 65536) value)))
|
|
(emit-u16 em v))))
|
|
(define emit-op (fn (em opcode) (emit-byte em opcode)))
|
|
(define
|
|
emit-const
|
|
(fn
|
|
(em value)
|
|
(let
|
|
((idx (pool-add (get em "pool") value)))
|
|
(emit-op em 1)
|
|
(emit-u16 em idx))))
|
|
(define current-offset (fn (em) (len (get em "bytecode"))))
|
|
(define
|
|
patch-i16
|
|
(fn
|
|
(em offset value)
|
|
"Patch a previously emitted i16 at the given bytecode offset."
|
|
(let
|
|
((v (if (< value 0) (+ value 65536) value))
|
|
(bc (get em "bytecode")))
|
|
(set-nth! bc offset (mod v 256))
|
|
(set-nth! bc (+ offset 1) (mod (floor (/ v 256)) 256)))))
|
|
(define
|
|
compile-expr
|
|
(fn
|
|
(em expr scope tail?)
|
|
"Compile an expression. tail? indicates tail position for TCO."
|
|
(cond
|
|
(nil? expr)
|
|
(emit-op em 2)
|
|
(= (type-of expr) "number")
|
|
(emit-const em expr)
|
|
(= (type-of expr) "string")
|
|
(emit-const em expr)
|
|
(= (type-of expr) "boolean")
|
|
(emit-op em (if expr 3 4))
|
|
(= (type-of expr) "keyword")
|
|
(emit-const em (keyword-name expr))
|
|
(= (type-of expr) "symbol")
|
|
(compile-symbol em (symbol-name expr) scope)
|
|
(= (type-of expr) "list")
|
|
(if
|
|
(empty? expr)
|
|
(do (emit-op em 64) (emit-u16 em 0))
|
|
(compile-list em expr scope tail?))
|
|
(= (type-of expr) "dict")
|
|
(compile-dict em expr scope)
|
|
:else (emit-const em expr))))
|
|
(define
|
|
compile-symbol
|
|
(fn
|
|
(em name scope)
|
|
(let
|
|
((resolved (scope-resolve scope name)))
|
|
(cond
|
|
(= (get resolved "type") "local")
|
|
(do (emit-op em 16) (emit-byte em (get resolved "index")))
|
|
(= (get resolved "type") "upvalue")
|
|
(do (emit-op em 18) (emit-byte em (get resolved "index")))
|
|
:else (let
|
|
((idx (pool-add (get em "pool") name)))
|
|
(emit-op em 20)
|
|
(emit-u16 em idx))))))
|
|
(define
|
|
compile-dict
|
|
(fn
|
|
(em expr scope)
|
|
(let
|
|
((ks (keys expr)) (count (len ks)))
|
|
(for-each
|
|
(fn
|
|
(k)
|
|
(emit-const em k)
|
|
(compile-expr em (get expr k) scope false))
|
|
ks)
|
|
(emit-op em 65)
|
|
(emit-u16 em count))))
|
|
(define
|
|
compile-list
|
|
(fn
|
|
(em expr scope tail?)
|
|
(let
|
|
((head (first expr)) (args (rest expr)))
|
|
(if
|
|
(not (= (type-of head) "symbol"))
|
|
(compile-call em head args scope tail?)
|
|
(let
|
|
((name (symbol-name head)))
|
|
(cond
|
|
(= name "if")
|
|
(compile-if em args scope tail?)
|
|
(= name "when")
|
|
(compile-when em args scope tail?)
|
|
(= name "and")
|
|
(compile-and em args scope tail?)
|
|
(= name "or")
|
|
(compile-or em args scope tail?)
|
|
(= name "let")
|
|
(compile-let em args scope tail?)
|
|
(= name "let*")
|
|
(compile-let em args scope tail?)
|
|
(= name "let-match")
|
|
(compile-let em (desugar-let-match args) scope tail?)
|
|
(= name "begin")
|
|
(compile-begin em args scope tail?)
|
|
(= name "do")
|
|
(compile-begin em args scope tail?)
|
|
(= name "lambda")
|
|
(compile-lambda em args scope)
|
|
(= name "fn")
|
|
(compile-lambda em args scope)
|
|
(= name "define")
|
|
(compile-define em args scope)
|
|
(= name "set!")
|
|
(compile-set em args scope)
|
|
(= name "quote")
|
|
(compile-quote em args)
|
|
(= name "cond")
|
|
(compile-cond em args scope tail?)
|
|
(= name "case")
|
|
(compile-case em args scope tail?)
|
|
(= name "->")
|
|
(compile-thread em args scope tail?)
|
|
(= name "defcomp")
|
|
(compile-defcomp em args scope)
|
|
(= name "defisland")
|
|
(compile-defcomp em args scope)
|
|
(= name "defmacro")
|
|
(compile-defmacro em args scope)
|
|
(= name "defstyle")
|
|
(do (emit-op em 2) nil)
|
|
(= name "defhandler")
|
|
(do (emit-op em 2) nil)
|
|
(= name "defpage")
|
|
(do (emit-op em 2) nil)
|
|
(= name "defquery")
|
|
(do (emit-op em 2) nil)
|
|
(= name "defaction")
|
|
(do (emit-op em 2) nil)
|
|
(= name "defrelation")
|
|
(do (emit-op em 2) nil)
|
|
(= name "deftype")
|
|
(do (emit-op em 2) nil)
|
|
(= name "defeffect")
|
|
(do (emit-op em 2) nil)
|
|
(= name "defisland")
|
|
(compile-defcomp em args scope)
|
|
(= name "quasiquote")
|
|
(compile-quasiquote em (first args) scope)
|
|
(= name "letrec")
|
|
(compile-letrec em args scope tail?)
|
|
(= name "match")
|
|
(compile-match em args scope tail?)
|
|
(= name "perform")
|
|
(let
|
|
()
|
|
(compile-expr em (first args) scope false)
|
|
(emit-op em 112)
|
|
nil)
|
|
(= name "import")
|
|
(let () (emit-const em {:library (first args) :op "import"}) (emit-op em 112) nil)
|
|
(= name "define-library")
|
|
(let
|
|
((body (filter (fn (a) (and (list? a) (not (empty? a)) (= (first a) (quote begin)))) args)))
|
|
(when
|
|
(not (empty? body))
|
|
(let
|
|
((forms (rest (first body))))
|
|
(for-each
|
|
(fn
|
|
(expr)
|
|
(compile-expr em expr scope false)
|
|
(emit-op em 5))
|
|
(init forms))
|
|
(compile-expr em (last forms) scope false))))
|
|
:else (compile-call em head args scope tail?)))))))
|
|
(define
|
|
compile-if
|
|
(fn
|
|
(em args scope tail?)
|
|
(let
|
|
((test (first args))
|
|
(then-expr (nth args 1))
|
|
(else-expr (if (> (len args) 2) (nth args 2) nil)))
|
|
(compile-expr em test scope false)
|
|
(emit-op em 33)
|
|
(let
|
|
((else-jump (current-offset em)))
|
|
(emit-i16 em 0)
|
|
(compile-expr em then-expr scope tail?)
|
|
(emit-op em 32)
|
|
(let
|
|
((end-jump (current-offset em)))
|
|
(emit-i16 em 0)
|
|
(patch-i16
|
|
em
|
|
else-jump
|
|
(- (current-offset em) (+ else-jump 2)))
|
|
(if
|
|
(nil? else-expr)
|
|
(emit-op em 2)
|
|
(compile-expr em else-expr scope tail?))
|
|
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
|
|
(define
|
|
compile-when
|
|
(fn
|
|
(em args scope tail?)
|
|
(let
|
|
((test (first args)) (body (rest args)))
|
|
(compile-expr em test scope false)
|
|
(emit-op em 33)
|
|
(let
|
|
((skip-jump (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-jump
|
|
(- (current-offset em) (+ skip-jump 2)))
|
|
(emit-op em 2)
|
|
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
|
|
(define
|
|
compile-and
|
|
(fn
|
|
(em args scope tail?)
|
|
(if
|
|
(empty? args)
|
|
(emit-op em 3)
|
|
(if
|
|
(= (len args) 1)
|
|
(compile-expr em (first args) scope tail?)
|
|
(do
|
|
(compile-expr em (first args) scope false)
|
|
(emit-op em 6)
|
|
(emit-op em 33)
|
|
(let
|
|
((skip (current-offset em)))
|
|
(emit-i16 em 0)
|
|
(emit-op em 5)
|
|
(compile-and em (rest args) scope tail?)
|
|
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
|
|
(define
|
|
compile-or
|
|
(fn
|
|
(em args scope tail?)
|
|
(if
|
|
(empty? args)
|
|
(emit-op em 4)
|
|
(if
|
|
(= (len args) 1)
|
|
(compile-expr em (first args) scope tail?)
|
|
(do
|
|
(compile-expr em (first args) scope false)
|
|
(emit-op em 6)
|
|
(emit-op em 34)
|
|
(let
|
|
((skip (current-offset em)))
|
|
(emit-i16 em 0)
|
|
(emit-op em 5)
|
|
(compile-or em (rest args) scope tail?)
|
|
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
|
|
(define
|
|
compile-begin
|
|
(fn
|
|
(em exprs scope tail?)
|
|
(when
|
|
(and (not (empty? exprs)) (not (nil? (get scope "parent"))))
|
|
(for-each
|
|
(fn
|
|
(expr)
|
|
(when
|
|
(and
|
|
(= (type-of expr) "list")
|
|
(>= (len expr) 2)
|
|
(= (type-of (first expr)) "symbol")
|
|
(= (symbol-name (first expr)) "define"))
|
|
(let
|
|
((name-expr (nth expr 1))
|
|
(name
|
|
(if
|
|
(= (type-of name-expr) "symbol")
|
|
(symbol-name name-expr)
|
|
name-expr)))
|
|
(scope-define-local scope name))))
|
|
exprs))
|
|
(if
|
|
(empty? exprs)
|
|
(emit-op em 2)
|
|
(if
|
|
(= (len exprs) 1)
|
|
(compile-expr em (first exprs) scope tail?)
|
|
(do
|
|
(compile-expr em (first exprs) scope false)
|
|
(emit-op em 5)
|
|
(compile-begin em (rest exprs) scope tail?))))))
|
|
(define
|
|
desugar-let-match
|
|
(fn
|
|
(args)
|
|
(let
|
|
((first-arg (first args)))
|
|
(if (dict? first-arg)
|
|
;; Variant 2: (let-match {:k v} expr body...)
|
|
(let
|
|
((pattern first-arg)
|
|
(expr (nth args 1))
|
|
(body (slice args 2))
|
|
(src-sym (make-symbol "__lm_tmp"))
|
|
(bindings (list)))
|
|
(append! bindings (list src-sym expr))
|
|
(for-each
|
|
(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))
|
|
(bindings (list)))
|
|
(append! bindings (list src-sym expr))
|
|
(when (dict? pattern)
|
|
(for-each
|
|
(fn (k)
|
|
(append! bindings
|
|
(list (get pattern k)
|
|
(list (make-symbol "get") src-sym (str k)))))
|
|
(keys pattern)))
|
|
(cons bindings body))))))
|
|
(define
|
|
compile-let
|
|
(fn
|
|
(em args scope tail?)
|
|
(if
|
|
(= (type-of (first args)) "symbol")
|
|
(let
|
|
((loop-name (symbol-name (first args)))
|
|
(bindings (nth args 1))
|
|
(body (slice args 2))
|
|
(params (list))
|
|
(inits (list)))
|
|
(for-each
|
|
(fn
|
|
(binding)
|
|
(append!
|
|
params
|
|
(if
|
|
(= (type-of (first binding)) "symbol")
|
|
(first binding)
|
|
(make-symbol (first binding))))
|
|
(append! inits (nth binding 1)))
|
|
bindings)
|
|
(let
|
|
((lambda-expr (concat (list (make-symbol "fn") params) body))
|
|
(letrec-bindings
|
|
(list (list (make-symbol loop-name) lambda-expr)))
|
|
(call-expr (cons (make-symbol loop-name) inits)))
|
|
(compile-letrec em (list letrec-bindings call-expr) scope tail?)))
|
|
(let
|
|
((bindings (first args))
|
|
(body (rest args))
|
|
(let-scope (make-scope scope)))
|
|
(dict-set! let-scope "next-slot" (get scope "next-slot"))
|
|
(for-each
|
|
(fn
|
|
(binding)
|
|
(let
|
|
((name (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (first binding)))
|
|
(value (nth binding 1))
|
|
(slot (scope-define-local let-scope name)))
|
|
(compile-expr em value let-scope false)
|
|
(emit-op em 17)
|
|
(emit-byte em slot)))
|
|
bindings)
|
|
(compile-begin em body let-scope tail?)))))
|
|
(define
|
|
compile-letrec
|
|
(fn
|
|
(em args scope tail?)
|
|
"Compile letrec: all names visible during value compilation.\n 1. Define all local slots (initialized to nil).\n 2. Compile each value and assign — names are already in scope\n so mutually recursive functions can reference each other."
|
|
(let
|
|
((bindings (first args))
|
|
(body (rest args))
|
|
(let-scope (make-scope scope)))
|
|
(dict-set! let-scope "next-slot" (get scope "next-slot"))
|
|
(let
|
|
((slots (map (fn (binding) (let ((name (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (first binding)))) (let ((slot (scope-define-local let-scope name))) (emit-op em 2) (emit-op em 17) (emit-byte em slot) slot))) bindings)))
|
|
(for-each
|
|
(fn
|
|
(pair)
|
|
(let
|
|
((binding (first pair)) (slot (nth pair 1)))
|
|
(compile-expr em (nth binding 1) let-scope false)
|
|
(emit-op em 17)
|
|
(emit-byte em slot)))
|
|
(map
|
|
(fn (i) (list (nth bindings i) (nth slots i)))
|
|
(range 0 (len bindings)))))
|
|
(compile-begin em body let-scope tail?))))
|
|
(define
|
|
compile-lambda
|
|
(fn
|
|
(em args scope)
|
|
(let
|
|
((params (first args))
|
|
(body (rest args))
|
|
(fn-scope (make-scope scope))
|
|
(fn-em (make-emitter)))
|
|
(dict-set! fn-scope "is-function" true)
|
|
(for-each
|
|
(fn
|
|
(p)
|
|
(let
|
|
((name (cond (= (type-of p) "symbol") (symbol-name p) (and (list? p) (not (empty? p)) (= (type-of (first p)) "symbol")) (symbol-name (first p)) :else p)))
|
|
(when
|
|
(and (not (= name "&key")) (not (= name "&rest")))
|
|
(scope-define-local fn-scope name))))
|
|
params)
|
|
(compile-begin fn-em body fn-scope true)
|
|
(emit-op fn-em 50)
|
|
(let
|
|
((upvals (get fn-scope "upvalues"))
|
|
(code {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :bytecode (get fn-em "bytecode")})
|
|
(code-idx (pool-add (get em "pool") code)))
|
|
(emit-op em 51)
|
|
(emit-u16 em code-idx)
|
|
(for-each
|
|
(fn
|
|
(uv)
|
|
(emit-byte em (if (get uv "is-local") 1 0))
|
|
(emit-byte em (get uv "index")))
|
|
upvals)))))
|
|
(define
|
|
compile-define
|
|
(fn
|
|
(em args scope)
|
|
(let
|
|
((name-expr (first args))
|
|
(name
|
|
(if
|
|
(= (type-of name-expr) "symbol")
|
|
(symbol-name name-expr)
|
|
name-expr))
|
|
(value
|
|
(let
|
|
((rest-args (rest args)))
|
|
(if
|
|
(and
|
|
(not (empty? rest-args))
|
|
(= (type-of (first rest-args)) "keyword"))
|
|
(let
|
|
((skip-annotations (fn (items) (if (empty? items) nil (if (= (type-of (first items)) "keyword") (skip-annotations (rest (rest items))) (first items))))))
|
|
(skip-annotations rest-args))
|
|
(first rest-args)))))
|
|
(if
|
|
(not (nil? (get scope "parent")))
|
|
(let
|
|
((slot (scope-define-local scope name)))
|
|
(compile-expr em value scope false)
|
|
(emit-op em 17)
|
|
(emit-byte em slot))
|
|
(let
|
|
((name-idx (pool-add (get em "pool") name)))
|
|
(compile-expr em value scope false)
|
|
(emit-op em 128)
|
|
(emit-u16 em name-idx))))))
|
|
(define
|
|
compile-set
|
|
(fn
|
|
(em args scope)
|
|
(let
|
|
((name (if (= (type-of (first args)) "symbol") (symbol-name (first args)) (first args)))
|
|
(value (nth args 1))
|
|
(resolved (scope-resolve scope name)))
|
|
(compile-expr em value scope false)
|
|
(cond
|
|
(= (get resolved "type") "local")
|
|
(do (emit-op em 17) (emit-byte em (get resolved "index")))
|
|
(= (get resolved "type") "upvalue")
|
|
(do (emit-op em 19) (emit-byte em (get resolved "index")))
|
|
:else (let
|
|
((idx (pool-add (get em "pool") name)))
|
|
(emit-op em 21)
|
|
(emit-u16 em idx))))))
|
|
(define
|
|
compile-quote
|
|
(fn
|
|
(em args)
|
|
(if (empty? args) (emit-op em 2) (emit-const em (first args)))))
|
|
(define
|
|
compile-cond
|
|
(fn
|
|
(em args scope tail?)
|
|
"Compile (cond test1 body1 test2 body2 ... :else fallback)."
|
|
(if
|
|
(< (len args) 2)
|
|
(emit-op em 2)
|
|
(let
|
|
((test (first args))
|
|
(body (nth args 1))
|
|
(rest-clauses (if (> (len args) 2) (slice args 2) (list))))
|
|
(if
|
|
(or
|
|
(and
|
|
(= (type-of test) "keyword")
|
|
(= (keyword-name test) "else"))
|
|
(= test true))
|
|
(compile-expr 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-expr 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-cond em rest-clauses scope tail?)
|
|
(patch-i16
|
|
em
|
|
end-jump
|
|
(- (current-offset em) (+ end-jump 2)))))))))))
|
|
(define
|
|
compile-case
|
|
(fn
|
|
(em args scope tail?)
|
|
"Compile (case expr val1 body1 val2 body2 ... :else fallback)."
|
|
(compile-expr em (first args) scope false)
|
|
(let
|
|
((clauses (rest args)))
|
|
(compile-case-clauses em clauses scope tail?))))
|
|
(define
|
|
compile-case-clauses
|
|
(fn
|
|
(em clauses scope tail?)
|
|
(if
|
|
(< (len clauses) 2)
|
|
(do (emit-op em 5) (emit-op em 2))
|
|
(let
|
|
((test (first clauses))
|
|
(body (nth clauses 1))
|
|
(rest-clauses
|
|
(if (> (len clauses) 2) (slice clauses 2) (list))))
|
|
(if
|
|
(or
|
|
(and
|
|
(= (type-of test) "keyword")
|
|
(= (keyword-name test) "else"))
|
|
(= test true))
|
|
(do (emit-op em 5) (compile-expr em body scope tail?))
|
|
(do
|
|
(emit-op em 6)
|
|
(compile-expr em test scope false)
|
|
(let
|
|
((name-idx (pool-add (get em "pool") "=")))
|
|
(emit-op em 52)
|
|
(emit-u16 em name-idx)
|
|
(emit-byte em 2))
|
|
(emit-op em 33)
|
|
(let
|
|
((skip (current-offset em)))
|
|
(emit-i16 em 0)
|
|
(emit-op em 5)
|
|
(compile-expr 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-case-clauses em rest-clauses scope tail?)
|
|
(patch-i16
|
|
em
|
|
end-jump
|
|
(- (current-offset em) (+ end-jump 2)))))))))))
|
|
(define
|
|
compile-match
|
|
(fn
|
|
(em args scope tail?)
|
|
(compile-expr em (first args) scope false)
|
|
(letrec
|
|
((do-clauses (fn (clauses) (if (empty? clauses) (do (emit-op em 5) (let ((idx (pool-add (get em "pool") "match: no clause matched"))) (emit-op em 1) (emit-u16 em idx) (emit-op em 52) (emit-u16 em (pool-add (get em "pool") "error")) (emit-byte em 1))) (let ((clause (first clauses)) (pattern (first clause)) (body (nth clause 1)) (rest-clauses (rest clauses))) (cond (and (= (type-of pattern) "symbol") (= (symbol-name pattern) "_")) (do (emit-op em 5) (compile-expr em body scope tail?)) (and (= (type-of pattern) "symbol") (not (= (symbol-name pattern) "true")) (not (= (symbol-name pattern) "false")) (not (= (symbol-name pattern) "nil"))) (let ((var-name (symbol-name pattern)) (inner-scope (scope-add scope var-name))) (emit-op em 13) (emit-byte em (scope-index inner-scope var-name)) (compile-expr em body inner-scope tail?)) (and (list? pattern) (= (len pattern) 2) (= (type-of (first pattern)) "symbol") (= (symbol-name (first pattern)) "quote") (= (type-of (nth pattern 1)) "symbol")) (do (emit-op em 6) (let ((idx (pool-add (get em "pool") (make-symbol (symbol-name (nth pattern 1)))))) (emit-op em 1) (emit-u16 em idx)) (let ((eq-idx (pool-add (get em "pool") "="))) (emit-op em 52) (emit-u16 em eq-idx) (emit-byte em 2)) (emit-op em 33) (let ((skip (current-offset em))) (emit-i16 em 0) (emit-op em 5) (compile-expr 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))) (do-clauses rest-clauses) (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))) :else (do (emit-op em 6) (compile-expr em pattern scope false) (let ((eq-idx (pool-add (get em "pool") "="))) (emit-op em 52) (emit-u16 em eq-idx) (emit-byte em 2)) (emit-op em 33) (let ((skip (current-offset em))) (emit-i16 em 0) (emit-op em 5) (compile-expr 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))) (do-clauses rest-clauses) (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))))))
|
|
(do-clauses (rest args)))))
|
|
(define
|
|
compile-thread
|
|
(fn
|
|
(em args scope tail?)
|
|
"Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls."
|
|
(if
|
|
(empty? args)
|
|
(emit-op em 2)
|
|
(if
|
|
(= (len args) 1)
|
|
(compile-expr em (first args) scope tail?)
|
|
(let
|
|
((val-expr (first args)) (forms (rest args)))
|
|
(compile-thread-step em val-expr forms scope tail?))))))
|
|
(define
|
|
compile-thread-step
|
|
(fn
|
|
(em val-expr forms scope tail?)
|
|
(if
|
|
(empty? forms)
|
|
(compile-expr em val-expr scope tail?)
|
|
(let
|
|
((form (first forms))
|
|
(rest-forms (rest forms))
|
|
(is-tail (and tail? (empty? rest-forms))))
|
|
(let
|
|
((call-expr (if (list? form) (concat (list (first form) val-expr) (rest form)) (list form val-expr))))
|
|
(if
|
|
(empty? rest-forms)
|
|
(compile-expr em call-expr scope is-tail)
|
|
(do
|
|
(compile-expr em call-expr scope false)
|
|
(compile-thread-step em call-expr rest-forms scope tail?))))))))
|
|
(define
|
|
compile-defcomp
|
|
(fn
|
|
(em args scope)
|
|
"Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL."
|
|
(let
|
|
((name-idx (pool-add (get em "pool") "eval-defcomp")))
|
|
(emit-op em 20)
|
|
(emit-u16 em name-idx))
|
|
(emit-const em (concat (list (make-symbol "defcomp")) args))
|
|
(emit-op em 48)
|
|
(emit-byte em 1)))
|
|
(define
|
|
compile-defmacro
|
|
(fn
|
|
(em args scope)
|
|
"Compile defmacro — delegates to runtime via GLOBAL_GET + CALL."
|
|
(let
|
|
((name-idx (pool-add (get em "pool") "eval-defmacro")))
|
|
(emit-op em 20)
|
|
(emit-u16 em name-idx))
|
|
(emit-const em (concat (list (make-symbol "defmacro")) args))
|
|
(emit-op em 48)
|
|
(emit-byte em 1)))
|
|
(define
|
|
compile-quasiquote
|
|
(fn
|
|
(em expr scope)
|
|
"Compile quasiquote inline — walks the template at compile time,\n emitting code that builds the structure at runtime. Unquoted\n expressions are compiled normally (resolving locals/upvalues),\n avoiding the qq-expand-runtime env-lookup limitation."
|
|
(compile-qq-expr em expr scope)))
|
|
(define
|
|
compile-qq-expr
|
|
(fn
|
|
(em expr scope)
|
|
"Compile a quasiquote sub-expression."
|
|
(if
|
|
(not (= (type-of expr) "list"))
|
|
(emit-const em expr)
|
|
(if
|
|
(empty? expr)
|
|
(do (emit-op em 64) (emit-u16 em 0))
|
|
(let
|
|
((head (first expr)))
|
|
(if
|
|
(and
|
|
(= (type-of head) "symbol")
|
|
(= (symbol-name head) "unquote"))
|
|
(compile-expr em (nth expr 1) scope false)
|
|
(compile-qq-list em expr scope)))))))
|
|
(define
|
|
compile-qq-list
|
|
(fn
|
|
(em items scope)
|
|
"Compile a quasiquote list. Handles splice-unquote by building\n segments and concatenating them."
|
|
(let
|
|
((has-splice (some (fn (item) (and (= (type-of item) "list") (>= (len item) 2) (= (type-of (first item)) "symbol") (= (symbol-name (first item)) "splice-unquote"))) items)))
|
|
(if
|
|
(not has-splice)
|
|
(do
|
|
(for-each (fn (item) (compile-qq-expr em item scope)) items)
|
|
(emit-op em 64)
|
|
(emit-u16 em (len items)))
|
|
(let
|
|
((segment-count 0) (pending 0))
|
|
(for-each
|
|
(fn
|
|
(item)
|
|
(if
|
|
(and
|
|
(= (type-of item) "list")
|
|
(>= (len item) 2)
|
|
(= (type-of (first item)) "symbol")
|
|
(= (symbol-name (first item)) "splice-unquote"))
|
|
(do
|
|
(when
|
|
(> pending 0)
|
|
(emit-op em 64)
|
|
(emit-u16 em pending)
|
|
(set! segment-count (+ segment-count 1))
|
|
(set! pending 0))
|
|
(compile-expr em (nth item 1) scope false)
|
|
(set! segment-count (+ segment-count 1)))
|
|
(do
|
|
(compile-qq-expr em item scope)
|
|
(set! pending (+ pending 1)))))
|
|
items)
|
|
(when
|
|
(> pending 0)
|
|
(emit-op em 64)
|
|
(emit-u16 em pending)
|
|
(set! segment-count (+ segment-count 1)))
|
|
(when
|
|
(> segment-count 1)
|
|
(let
|
|
((concat-idx (pool-add (get em "pool") "concat")))
|
|
(emit-op em 52)
|
|
(emit-u16 em concat-idx)
|
|
(emit-byte em segment-count))))))))
|
|
(define
|
|
compile-call
|
|
(fn
|
|
(em head args scope tail?)
|
|
(let
|
|
((is-prim (and (= (type-of head) "symbol") (let ((name (symbol-name head))) (and (not (= (get (scope-resolve scope name) "type") "local")) (not (= (get (scope-resolve scope name) "type") "upvalue")) (primitive? name))))))
|
|
(if
|
|
is-prim
|
|
(let
|
|
((name (symbol-name head))
|
|
(argc (len args))
|
|
(name-idx (pool-add (get em "pool") name)))
|
|
(for-each (fn (a) (compile-expr em a scope false)) args)
|
|
(emit-op em 52)
|
|
(emit-u16 em name-idx)
|
|
(emit-byte em argc))
|
|
(do
|
|
(compile-expr em head scope false)
|
|
(for-each (fn (a) (compile-expr em a scope false)) args)
|
|
(if
|
|
tail?
|
|
(do (emit-op em 49) (emit-byte em (len args)))
|
|
(do (emit-op em 48) (emit-byte em (len args)))))))))
|
|
(define
|
|
compile
|
|
(fn
|
|
(expr)
|
|
"Compile a single SX expression to a bytecode module."
|
|
(let
|
|
((em (make-emitter)) (scope (make-scope nil)))
|
|
(compile-expr em expr scope false)
|
|
(emit-op em 50)
|
|
{:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")})))
|
|
(define
|
|
compile-module
|
|
(fn
|
|
(exprs)
|
|
"Compile a list of top-level expressions to a bytecode module."
|
|
(let
|
|
((em (make-emitter)) (scope (make-scope nil)))
|
|
(for-each
|
|
(fn (expr) (compile-expr em expr scope false) (emit-op em 5))
|
|
(init exprs))
|
|
(compile-expr em (last exprs) scope false)
|
|
(emit-op em 50)
|
|
{:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))))) ;; end define-library
|
|
|
|
;; Re-export to global namespace for backward compatibility
|
|
(import (sx compiler))
|