From ceb2adfe5090d1dabbf032db68a0153a6bd84d9d Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 19 Mar 2026 19:34:36 +0000 Subject: [PATCH] Compiler: cond, case, thread-first, defcomp, quasiquote, letrec MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Added compilation for all remaining special forms: - cond: nested JUMP_IF_FALSE chains - case: desugar to DUP + equality checks - ->: desugar to nested function calls - defcomp/defisland/defmacro: delegate to runtime primitives - quasiquote: delegate to runtime qq-expand - letrec: compiled as let (same scope) - All def* forms: compiled as no-op (handled by page loader) Also: concat, slice, make-symbol primitives for compiler support. All test patterns compile: (cond ...) → 52 bytes, (case ...) → 8 bytes, (-> ...) → 28 bytes, nested let+cond → 37 bytes Co-Authored-By: Claude Opus 4.6 (1M context) --- spec/compiler.sx | 141 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 140 insertions(+), 1 deletion(-) diff --git a/spec/compiler.sx b/spec/compiler.sx index 3aed1e2..7f5b224 100644 --- a/spec/compiler.sx +++ b/spec/compiler.sx @@ -236,7 +236,23 @@ (= name "define") (compile-define em args scope) (= name "set!") (compile-set em args scope) (= name "quote") (compile-quote em args) - (= name "if") (compile-if em args scope tail?) + (= 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") (emit-op em 2) ;; defstyle → nil (no-op at runtime) + (= name "defhandler") (emit-op em 2) ;; no-op + (= name "defpage") (emit-op em 2) ;; handled by page loader + (= name "defquery") (emit-op em 2) + (= name "defaction") (emit-op em 2) + (= name "defrelation") (emit-op em 2) + (= name "deftype") (emit-op em 2) + (= name "defeffect") (emit-op em 2) + (= name "defisland") (compile-defcomp em args scope) + (= name "quasiquote") (compile-quasiquote em (first args) scope) + (= name "letrec") (compile-let em args scope tail?) ;; Default — function call :else (compile-call em head args scope tail?))))))) @@ -423,6 +439,129 @@ (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) ;; OP_NIL + (let ((test (first args)) + (body (nth args 1)) + (rest-clauses (if (> (len args) 2) (slice args 2) (list)))) + (if (or (= test :else) (= test true)) + ;; else clause — just compile the body + (compile-expr em body scope tail?) + (do + (compile-expr em test scope false) + (emit-op em 33) ;; OP_JUMP_IF_FALSE + (let ((skip (current-offset em))) + (emit-i16 em 0) + (compile-expr em body scope tail?) + (emit-op em 32) ;; OP_JUMP + (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)." + ;; Desugar to nested if: evaluate expr once, then compare + (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)) ;; POP match-val, push NIL + (let ((test (first clauses)) + (body (nth clauses 1)) + (rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list)))) + (if (or (= test :else) (= test true)) + (do (emit-op em 5) ;; POP match-val + (compile-expr em body scope tail?)) + (do + (emit-op em 6) ;; DUP match-val + (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)) ;; CALL_PRIM "=" 2 + (emit-op em 33) ;; JUMP_IF_FALSE + (let ((skip (current-offset em))) + (emit-i16 em 0) + (emit-op em 5) ;; POP match-val + (compile-expr em body scope tail?) + (emit-op em 32) ;; JUMP + (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-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?) + ;; Desugar: (-> x (f a)) → (f x a) + (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)))) + ;; Build desugared call: (f val args...) + (let ((call-expr + (if (list? form) + ;; (-> x (f a b)) → (f x a b) + (concat (list (first form) val-expr) (rest form)) + ;; (-> x f) → (f x) + (list form val-expr)))) + (if (empty? rest-forms) + (compile-expr em call-expr scope is-tail) + (do + (compile-expr em call-expr scope false) + ;; Thread result through remaining forms + ;; Store in temp, compile next step + ;; Actually, just compile sequentially — each step returns a value + (compile-thread-step em call-expr rest-forms scope tail?)))))))) + + +(define compile-defcomp + (fn (em args scope) + "Compile defcomp/defisland — delegates to runtime primitive." + ;; For now, quote the entire defcomp form and call the primitive + (emit-const em (concat (list (make-symbol "defcomp")) args)) + (let ((name-idx (pool-add (get em "pool") "eval-defcomp"))) + (emit-op em 52) (emit-u16 em name-idx) (emit-byte em 1)) ;; CALL_PRIM + )) + +(define compile-defmacro + (fn (em args scope) + "Compile defmacro — delegates to runtime." + (emit-const em (concat (list (make-symbol "defmacro")) args)) + (let ((name-idx (pool-add (get em "pool") "eval-defmacro"))) + (emit-op em 52) (emit-u16 em name-idx) (emit-byte em 1)))) + + +(define compile-quasiquote + (fn (em expr scope) + "Compile quasiquote — for now, quote the template and call qq-expand at runtime." + (emit-const em expr) ;; push template + ;; qq-expand is a runtime function — call it + (let ((name-idx (pool-add (get em "pool") "qq-expand-runtime"))) + (emit-op em 52) (emit-u16 em name-idx) (emit-byte em 1)))) + + ;; -------------------------------------------------------------------------- ;; Function call compilation ;; --------------------------------------------------------------------------