feat(eval): add special form desugaring and quasiquote

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
+    }
+}