;; ==========================================================================
;; 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 "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
                  (emit-const em (keyword-name (first args)))
                  (emit-op em 52)
                  (emit-u16 em (pool-add (get em "pool") "context"))
                  (emit-byte em 1))
                (= name "peek")
                (do
                  (emit-const em (keyword-name (first args)))
                  (emit-op em 52)
                  (emit-u16 em (pool-add (get em "pool") "scope-peek"))
                  (emit-byte em 1))
                (= name "provide!")
                (do
                  (emit-const em (keyword-name (first args)))
                  (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
                  (emit-const em (keyword-name (first args)))
                  (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
                  (emit-const em (keyword-name (first args)))
                  (emit-op em 52)
                  (emit-u16 em (pool-add (get em "pool") "scope-emitted"))
                  (emit-byte em 1))
                (= 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)
            (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))
            (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
(define
  compile-provide
  (fn
    (em args scope tail?)
    (let
      ((name (keyword-name (first args)))
        (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))