From af0a0aca5b91693f0e19c4e834b6b6742b98be78 Mon Sep 17 00:00:00 2001 From: DualFroz Date: Mon, 24 Aug 2026 20:00:00 +0200 Subject: [PATCH] feat(eval): add special form desugaring and quasiquote --- Sources/KiteCore/Desugar.swift | 173 +++++++++++++++++++++++++++++++++ 1 file changed, 173 insertions(+) create mode 100644 Sources/KiteCore/Desugar.swift diff --git a/Sources/KiteCore/Desugar.swift b/Sources/KiteCore/Desugar.swift new file mode 100644 index 0000000..d4d775a --- /dev/null +++ b/Sources/KiteCore/Desugar.swift @@ -0,0 +1,173 @@ +func sym(_ name: String) -> Value { .symbol(name) } +func listV(_ items: [Value]) -> Value { arrayToList(items) } +func quoteExpr(_ v: Value) -> Value { listV([sym("quote"), v]) } + +func cadrOf(_ form: Value) throws -> Value { + let parts = try listToArray(form) + guard parts.count >= 2 else { throw schemeError("malformed form", [form]) } + return parts[1] +} + +func desugarLet(_ form: Value, _ gensym: Gensym) throws -> Value { + let elems = try listToArray(form) + guard elems.count >= 3 else { throw schemeError("malformed let") } + if case .symbol(let name) = elems[1] { + let bindings = try listToArray(elems[2]) + let body = Array(elems[3...]) + var vars: [Value] = [] + var inits: [Value] = [] + for b in bindings { + let bp = try listToArray(b) + vars.append(bp[0]) + inits.append(bp.count > 1 ? bp[1] : .unspecified) + } + let lambdaExpr = listV([sym("lambda"), listV(vars)] + body) + let letrecBindings = listV([listV([sym(name), lambdaExpr])]) + let call = listV([sym(name)] + inits) + return listV([sym("letrec"), letrecBindings, call]) + } + let bindings = try listToArray(elems[1]) + let body = Array(elems[2...]) + var vars: [Value] = [] + var inits: [Value] = [] + for b in bindings { + let bp = try listToArray(b) + vars.append(bp[0]) + inits.append(bp.count > 1 ? bp[1] : .unspecified) + } + let lambdaExpr = listV([sym("lambda"), listV(vars)] + body) + return listV([lambdaExpr] + inits) +} + +func desugarLetStar(_ form: Value) throws -> Value { + let elems = try listToArray(form) + let bindings = try listToArray(elems[1]) + let body = Array(elems[2...]) + if bindings.isEmpty { + return listV([listV([sym("lambda"), .null] + body)]) + } + let first = bindings[0] + let rest = Array(bindings[1...]) + let inner = listV([sym("let*"), listV(rest)] + body) + return listV([sym("let"), listV([first]), inner]) +} + +func desugarLetrec(_ form: Value) throws -> Value { + let elems = try listToArray(form) + let bindings = try listToArray(elems[1]) + let body = Array(elems[2...]) + var vars: [Value] = [] + var setExprs: [Value] = [] + for b in bindings { + let bp = try listToArray(b) + vars.append(bp[0]) + setExprs.append(listV([sym("set!"), bp[0], bp.count > 1 ? bp[1] : .unspecified])) + } + let lambdaBody = setExprs + body + let lambdaExpr = listV([sym("lambda"), listV(vars)] + lambdaBody) + let args = vars.map { _ in Value.unspecified } + return listV([lambdaExpr] + args) +} + +func desugarCond(_ form: Value, _ gensym: Gensym) throws -> Value { + let clauses = Array(try listToArray(form)[1...]) + var result: Value = .unspecified + for clause in clauses.reversed() { + let parts = try listToArray(clause) + guard let test = parts.first else { throw schemeError("empty cond clause") } + if case .symbol(let s) = test, baseName(s) == "else" { + result = listV([sym("begin")] + Array(parts[1...])) + } else if parts.count >= 3, case .symbol(let arrow) = parts[1], baseName(arrow) == "=>" { + let temp = freshTemp(gensym) + result = listV([ + sym("let"), listV([listV([sym(temp), test])]), + listV([sym("if"), sym(temp), listV([parts[2], sym(temp)]), result]), + ]) + } else if parts.count == 1 { + let temp = freshTemp(gensym) + result = listV([ + sym("let"), listV([listV([sym(temp), test])]), + listV([sym("if"), sym(temp), sym(temp), result]), + ]) + } else { + let thenExpr = listV([sym("begin")] + Array(parts[1...])) + result = listV([sym("if"), test, thenExpr, result]) + } + } + return result +} + +func desugarCase(_ form: Value, _ gensym: Gensym) throws -> Value { + let parts = try listToArray(form) + let key = parts[1] + let clauses = Array(parts[2...]) + let temp = freshTemp(gensym) + var condClauses: [Value] = [] + for clause in clauses { + let cparts = try listToArray(clause) + if case .symbol(let s) = cparts[0], baseName(s) == "else" { + condClauses.append(listV([sym("else")] + Array(cparts[1...]))) + } else { + let test = listV([sym("memv"), sym(temp), quoteExpr(cparts[0])]) + condClauses.append(listV([test] + Array(cparts[1...]))) + } + } + let condForm = listV([sym("cond")] + condClauses) + return listV([sym("let"), listV([listV([sym(temp), key])]), condForm]) +} + +func desugarAnd(_ form: Value) throws -> Value { + let parts = Array(try listToArray(form)[1...]) + func andOf(_ xs: [Value]) -> Value { + if xs.isEmpty { return .bool(true) } + if xs.count == 1 { return xs[0] } + return listV([sym("if"), xs[0], andOf(Array(xs[1...])), .bool(false)]) + } + return andOf(parts) +} + +func desugarOr(_ form: Value, _ gensym: Gensym) throws -> Value { + let parts = Array(try listToArray(form)[1...]) + func orOf(_ xs: [Value]) -> Value { + if xs.isEmpty { return .bool(false) } + if xs.count == 1 { return xs[0] } + let temp = freshTemp(gensym) + return listV([ + sym("let"), listV([listV([sym(temp), xs[0]])]), + listV([sym("if"), sym(temp), sym(temp), orOf(Array(xs[1...]))]), + ]) + } + return orOf(parts) +} + +func freshTemp(_ gensym: Gensym) -> String { + "t" + String(hygieneMark) + "d" + String(gensym.next()) +} + +func expandQuasi(_ template: Value, _ depth: Int) -> Value { + switch template { + case .pair(let p): + if case .symbol(let s) = p.car, baseName(s) == "unquote" { + if depth == 1 { + if case .pair(let inner) = p.cdr { return inner.car } + return .unspecified + } + return listV([sym("cons"), quoteExpr(sym("unquote")), expandQuasi(p.cdr, depth - 1)]) + } + if case .symbol(let s) = p.car, baseName(s) == "quasiquote" { + return listV([sym("cons"), quoteExpr(sym("quasiquote")), expandQuasi(p.cdr, depth + 1)]) + } + if case .pair(let carp) = p.car, case .symbol(let s) = carp.car, baseName(s) == "unquote-splicing", depth == 1 { + let spliced: Value + if case .pair(let inner) = carp.cdr { spliced = inner.car } else { spliced = .null } + return listV([sym("append"), spliced, expandQuasi(p.cdr, depth)]) + } + return listV([sym("cons"), expandQuasi(p.car, depth), expandQuasi(p.cdr, depth)]) + case .null: + return quoteExpr(.null) + case .symbol: + return quoteExpr(template) + default: + return template + } +}