Support let-forms for handling keyword-based argument lists.

Author: objecthub

Sources/LispKit/Compiler/EvalError.swift

@@ -102,6 +102,8 @@ public enum EvalError: Int, Hashable {
   case unknownInterpolateAlgorithm
   case unsupportedGradientColorSpec
   case invalidRegexpMatchingOption
+  case unknownKeyword
+  case expectedKeywordArg
 
   public var message: String {
     switch self {
@@ -259,6 +261,10 @@ public enum EvalError: Int, Hashable {
         return "unsupported gradient color specification: $0"
       case .invalidRegexpMatchingOption:
         return "invalid regexp matching option: $0"
+      case .unknownKeyword:
+        return "unknown keyword $1; cannot assign value $0"
+      case .expectedKeywordArg:
+        return "expected keyword argument: $0"
     }
   }
 

Sources/LispKit/Compiler/RuntimeError.swift

@@ -35,10 +35,10 @@ public class RuntimeError: Error, Hashable, CustomStringConvertible {
   public private(set) var library: Expr?
   public private(set) var stackTrace: [Procedure]?
 
-  private init(_ pos: SourcePosition,
-               _ descriptor: ErrorDescriptor,
-               _ irritants: [Expr],
-               _ stackTrace: [Procedure]? = nil) {
+  internal init(_ pos: SourcePosition,
+                _ descriptor: ErrorDescriptor,
+                _ irritants: [Expr],
+                _ stackTrace: [Procedure]? = nil) {
     self.pos = pos
     self.descriptor = descriptor
     self.irritants = irritants

Sources/LispKit/Primitives/ControlFlowLibrary.swift

@@ -37,6 +37,8 @@ public final class ControlFlowLibrary: NativeLibrary {
     self.define(SpecialForm("let*-values", self.compileLetStarValues))
     self.define(SpecialForm("let-optionals", self.compileLetOptionals))
     self.define(SpecialForm("let*-optionals", self.compileLetStarOptionals))
+    self.define(SpecialForm("let-keywords", self.compileLetKeywords))
+    self.define(SpecialForm("let*-keywords", self.compileLetStarKeywords))
     self.define(SpecialForm("let-syntax", self.compileLetSyntax))
     self.define(SpecialForm("letrec-syntax", self.compileLetRecSyntax))
     self.define(SpecialForm("do", self.compileDo))
@@ -343,6 +345,129 @@ public final class ControlFlowLibrary: NativeLibrary {
     return group
   }
 
+  private func compileLetKeywords(_ compiler: Compiler,
+                                  expr: Expr,
+                                  env: Env,
+                                  tail: Bool) throws -> Bool {
+    guard case .pair(_, .pair(let optlist, .pair(let first, let body))) = expr else {
+      throw RuntimeError.argumentCount(of: "let-keywords", min: 2, expr: expr)
+    }
+    let initialLocals = compiler.numLocals
+    switch first {
+      case .null:
+        return try compiler.compileSeq(.pair(optlist, body),
+                                       in: env,
+                                       inTailPos: tail)
+      case .pair(_, _):
+        try compiler.compile(optlist, in: env, inTailPos: false)
+        let group = try self.compileKeywordBindings(compiler, first, in: env, atomic: true)
+        compiler.emit(.pop)
+        let res = try compiler.compileSeq(body,
+                                          in: Env(group),
+                                          inTailPos: tail)
+        return compiler.finalizeBindings(group, exit: res, initialLocals: initialLocals)
+      default:
+        throw RuntimeError.type(first, expected: [.listType])
+    }
+  }
+  
+  private func compileLetStarKeywords(_ compiler: Compiler,
+                                      expr: Expr,
+                                      env: Env,
+                                      tail: Bool) throws -> Bool {
+    guard case .pair(_, .pair(let optlist, .pair(let first, let body))) = expr else {
+      throw RuntimeError.argumentCount(of: "let*-keywords", min: 2, expr: expr)
+    }
+    let initialLocals = compiler.numLocals
+    switch first {
+      case .null:
+        return try compiler.compileSeq(.pair(optlist, body),
+                                       in: env,
+                                       inTailPos: tail)
+      case .pair(_, _):
+        try compiler.compile(optlist, in: env, inTailPos: false)
+        let group = try self.compileKeywordBindings(compiler, first, in: env, atomic: false)
+        compiler.emit(.pop)
+        let res = try compiler.compileSeq(body,
+                                          in: Env(group),
+                                          inTailPos: tail)
+        return compiler.finalizeBindings(group, exit: res, initialLocals: initialLocals)
+      default:
+        throw RuntimeError.type(first, expected: [.listType])
+    }
+  }
+
+  private func compileKeywordBindings(_ compiler: Compiler,
+                                      _ bindingList: Expr,
+                                      in lenv: Env,
+                                      atomic: Bool) throws -> BindingGroup {
+    let group = BindingGroup(owner: compiler, parent: lenv)
+    let env = atomic ? lenv : .local(group)
+    var bindings = bindingList
+    var prevIndex = -1
+    let initialIp = compiler.emitPlaceholder()
+    let backfillIp = compiler.offsetToNext(0)
+    // Backfill keyword bindings with defaults
+    while case .pair(let binding, let rest) = bindings {
+      guard case .pair(.symbol(let sym), .pair(let expr, .null)) = binding else {
+        throw RuntimeError.eval(.malformedBinding, binding, bindingList)
+      }
+      compiler.emit(.pushUndef)
+      let pushValueIp = compiler.emitPlaceholder()
+      compiler.emit(.eq)
+      let alreadySetIp = compiler.emitPlaceholder()
+      try compiler.compile(expr, in: env, inTailPos: false)
+      let binding = group.allocBindingFor(sym)
+      guard binding.index > prevIndex else {
+        throw RuntimeError.eval(.duplicateBinding, .symbol(sym), bindingList)
+      }
+      compiler.emit(binding.isValue ? .setLocal(binding.index) : .setLocalValue(binding.index))
+      compiler.patch(binding.isValue ? .pushLocal(binding.index) : .pushLocalValue(binding.index),
+                     at: pushValueIp)
+      compiler.patch(.branchIfNot(compiler.offsetToNext(alreadySetIp)), at: alreadySetIp)
+      prevIndex = binding.index
+      bindings = rest
+    }
+    guard bindings.isNull else {
+      throw RuntimeError.eval(.malformedBindings, bindingList)
+    }
+    let finalIp = compiler.emitPlaceholder()
+    compiler.patch(.branch(compiler.offsetToNext(initialIp)), at: initialIp)
+    // Allocate space for all the bindings
+    bindings = bindingList
+    while case .pair(.pair(.symbol(let sym), _), let rest) = bindings {
+      let binding = group.allocBindingFor(sym)
+      compiler.emit(.pushUndef)
+      compiler.emit(binding.isValue ? .setLocal(binding.index) : .makeLocalVariable(binding.index))
+      bindings = rest
+    }
+    // Process keyword list
+    bindings = bindingList
+    let loopIp = compiler.emit(.dup)
+    compiler.emit(.isNull)
+    let listEmptyIp = compiler.emitPlaceholder()
+    compiler.emit(.deconsKeyword)
+    while case .pair(.pair(.symbol(let sym), _), let rest) = bindings {
+      let binding = group.allocBindingFor(sym)
+      compiler.emit(.dup)
+      compiler.pushConstant(.symbol(compiler.context.symbols.intern(sym.identifier + ":")))
+      compiler.emit(.eq)
+      let keywordCompIp = compiler.emitPlaceholder()
+      compiler.emit(.pop)
+      compiler.emit(binding.isValue ? .setLocal(binding.index) : .makeLocalVariable(binding.index))
+      compiler.emit(.branch(-compiler.offsetToNext(loopIp)))
+      compiler.patch(.branchIfNot(compiler.offsetToNext(keywordCompIp)), at: keywordCompIp)
+      bindings = rest
+    }
+    compiler.emit(.raiseError(EvalError.unknownKeyword.rawValue, 2))
+    compiler.patch(.branchIf(compiler.offsetToNext(listEmptyIp)), at: listEmptyIp)
+    // Jumop to the default backfill
+    compiler.emit(.branch(-compiler.offsetToNext(backfillIp)))
+    // Patch instructions jumping to the end
+    compiler.patch(.branch(compiler.offsetToNext(finalIp)), at: finalIp)
+    return group
+  }
+  
   private func compileLetSyntax(_ compiler: Compiler,
                                 expr: Expr,
                                 env: Env, tail: Bool) throws -> Bool {

Sources/LispKit/Runtime/Instruction.swift

@@ -317,6 +317,10 @@ public enum Instruction: CustomStringConvertible {
   /// the stack is not null.
   case isNull
 
+  /// **`is_undef`**: Pushes `#false` onto the stack if the current value on top of
+  /// the stack is not undefined.
+  case isUndef
+  
   /// **`list` _n_**: Pops the top _n_ values off the stack and constructs a list out of
   /// them on top of the stack.
   case list(Int)
@@ -329,6 +333,10 @@ public enum Instruction: CustomStringConvertible {
   /// onto the stack.
   case decons
 
+  /// **`decons_keyword`**: Pops a list off the stack, pushing the first two elements as well as the
+  /// tail of the second pair onto the stack
+  case deconsKeyword
+  
   /// **`car`**: Pops a pair off the stack and pushes its head onto the stack.
   case car
 
@@ -425,6 +433,10 @@ public enum Instruction: CustomStringConvertible {
 
   // Miscellaneous ----------------------------------------------------------------------------
 
+  /// **`raise_error` _err_,_n_**: Raises the given evaluation error _err_ using the top _n_
+  /// elements on top of the stack as irritants.
+  case raiseError(Int, Int)
+  
   /// **`push_current_time`**: Pushes the current time as a flonum onto the stack. The time
   /// is expressed as seconds since January 1, 1970 at 00:00.
   case pushCurrentTime
@@ -624,6 +636,8 @@ public enum Instruction: CustomStringConvertible {
         return "store_in_promise"
       case .swap:
         return "swap"
+      case .raiseError(let err, let n):
+        return "raise_error \(err), \(n)"
       case .pushCurrentTime:
         return "push_current_time"
       case .display:
@@ -640,10 +654,14 @@ public enum Instruction: CustomStringConvertible {
         return "is_pair"
       case .isNull:
         return "is_null"
+      case .isUndef:
+        return "is_undef"
       case .cons:
         return "cons"
       case .decons:
         return "decons"
+      case .deconsKeyword:
+        return "decons_keyword"
       case .car:
         return "car"
       case .cdr:

Sources/LispKit/Runtime/VirtualMachine.swift

@@ -1482,6 +1482,14 @@ public final class VirtualMachine: TrackedObject {
           self.stack[self.sp] = .undef
           // Re-execute force
           self.registers.ip = self.registers.ip &- 2
+        case .raiseError(let err, let n):
+          var irritants: [Expr] = []
+          for _ in 0..<n {
+            irritants.insert(self.pop(), at: 0)
+          }
+          throw RuntimeError(SourcePosition.unknown,
+                             ErrorDescriptor.eval(EvalError(rawValue: err)!),
+                             irritants)
         case .pushCurrentTime:
           self.push(.flonum(Timer.currentTimeInSec))
         case .display:
@@ -1508,6 +1516,8 @@ public final class VirtualMachine: TrackedObject {
           }
         case .isNull:
           self.push(.makeBoolean(self.popUnsafe() == .null))
+        case .isUndef:
+          self.push(.makeBoolean(self.popUnsafe() == .undef))
         case .cons:
           let cdr = self.pop()
           self.push(.pair(self.popUnsafe(), cdr))
@@ -1518,6 +1528,14 @@ public final class VirtualMachine: TrackedObject {
           }
           self.push(cdr)
           self.push(car)
+        case .deconsKeyword:
+          let expr = self.popUnsafe()
+          guard case .pair(let fst, .pair(let snd, let cdr)) = expr else {
+            throw RuntimeError.eval(.expectedKeywordArg, expr)
+          }
+          self.push(cdr)
+          self.push(snd)
+          self.push(fst)
         case .car:
           let expr = self.popUnsafe()
           guard case .pair(let car, _) = expr else {