Sources/OrgCore/Config/Elisp.swift
960 lines · 43296 bytes
1import Foundation
2
3/// A small Emacs Lisp evaluator over `Sexp` values: the special forms and functions diary
4/// sexps and table formulas use, with dynamic binding. A function or form it doesn't have
5/// throws `Unsupported`; errors Emacs would signal throw `Signal`.
6public final class Elisp {
7 public struct Unsupported: Error, Equatable, CustomStringConvertible {
8 public let what: String
9 public var description: String { what }
10 }
11
12 public struct Signal: Error, Equatable, CustomStringConvertible {
13 public let message: String
14 public var description: String { message }
15 }
16
17 public typealias Builtin = (Elisp, [Sexp]) throws -> Sexp
18
19 private var scopes: [[String: Sexp]] = [[:]]
20 private var functions: [String: Builtin] = [:]
21 private var steps = 0
22 static let stepLimit = 1_000_000
23 /// Nested evaluations, as `max-lisp-eval-depth` limits them.
24 private var depth = 0
25 static let depthLimit = 1600
26 /// The most elements a list built at once may have.
27 static let lengthLimit = 1_000_000
28 /// What `princ` and the other printers wrote: the innermost `with-output-to-string`, or
29 /// standard output.
30 private var outputs: [String] = [""]
31 /// What went to standard output.
32 public var standardOutput: String { outputs[0] }
33 /// What `message` wrote.
34 public private(set) var messages = ""
35
36 public init() {
37 Self.core(self)
38 }
39
40 /// Defines or replaces a function.
41 public func define(_ name: String, _ function: @escaping Builtin) { functions[name] = function }
42
43 /// Sets a global variable.
44 public func set(_ name: String, _ value: Sexp) { scopes[0][name] = value }
45
46 public func value(_ name: String) throws -> Sexp {
47 for scope in scopes.reversed() { if let v = scope[name] { return v } }
48 throw Signal(message: "Symbol’s value as variable is void: \(name)")
49 }
50
51 /// Evaluates `body` with `bindings` added.
52 public func binding<T>(_ bindings: [String: Sexp], _ body: () throws -> T) rethrows -> T {
53 scopes.append(bindings)
54 defer { scopes.removeLast() }
55 return try body()
56 }
57
58 private func assign(_ name: String, _ v: Sexp) {
59 for i in scopes.indices.reversed() where scopes[i][name] != nil {
60 scopes[i][name] = v
61 return
62 }
63 scopes[0][name] = v
64 }
65
66 // MARK: - Values
67
68 public static let t = Sexp.symbol("t")
69
70 public static func isNil(_ v: Sexp) -> Bool { v == .nil || v == .list([]) }
71 public static func bool(_ b: Bool) -> Sexp { b ? t : .nil }
72 static func list(_ items: [Sexp]) -> Sexp { items.isEmpty ? .nil : .list(items) }
73
74 static func cons(_ a: Sexp, _ b: Sexp) -> Sexp {
75 switch b {
76 case .list(let items): .list([a] + items)
77 case .dotted(let items, let last): .dotted([a] + items, last)
78 case _ where isNil(b): .list([a])
79 default: .dotted([a], b)
80 }
81 }
82
83 static func car(_ v: Sexp) throws -> Sexp {
84 switch v {
85 case .list(let items): items.first ?? .nil
86 case .dotted(let items, _): items[0]
87 case _ where isNil(v): .nil
88 default: throw Signal(message: "Wrong type argument: listp, \(v.description)")
89 }
90 }
91
92 static func cdr(_ v: Sexp) throws -> Sexp {
93 switch v {
94 case .list(let items): list(Array(items.dropFirst()))
95 case .dotted(let items, let last): items.count == 1 ? last : .dotted(Array(items.dropFirst()), last)
96 case _ where isNil(v): .nil
97 default: throw Signal(message: "Wrong type argument: listp, \(v.description)")
98 }
99 }
100
101 /// A proper list's elements.
102 static func elements(_ v: Sexp) throws -> [Sexp] {
103 if case .list(let items) = v { return items }
104 if isNil(v) { return [] }
105 throw Signal(message: "Wrong type argument: listp, \(v.description)")
106 }
107
108 enum Number {
109 case int(Int), float(Double)
110 var double: Double {
111 switch self {
112 case .int(let i): Double(i)
113 case .float(let d): d
114 }
115 }
116 }
117
118 static func number(_ v: Sexp) throws -> Number {
119 switch v {
120 case .integer(let i): return .int(i)
121 case .float(let d): return .float(d)
122 case .character(let c): return .int(c)
123 default: throw Signal(message: "Wrong type argument: number-or-marker-p, \(v.description)")
124 }
125 }
126
127 static func int(_ v: Sexp) throws -> Int {
128 switch v {
129 case .integer(let i): return i
130 case .character(let c): return c
131 default: throw Signal(message: "Wrong type argument: integerp, \(v.description)")
132 }
133 }
134
135 static func string(_ v: Sexp) throws -> String {
136 guard case .string(let s) = v else { throw Signal(message: "Wrong type argument: stringp, \(v.description)") }
137 return s
138 }
139
140 static func sexp(_ n: Number) -> Sexp {
141 switch n {
142 case .int(let i): .integer(i)
143 case .float(let d): .float(d)
144 }
145 }
146
147 /// `prin1-to-string` with `princ` for strings when `escape` is false.
148 public static func printed(_ v: Sexp, escape: Bool = false) -> String {
149 switch v {
150 case .string(let s): return escape ? "\"" + s.replacingOccurrences(of: "\\", with: "\\\\").replacingOccurrences(of: "\"", with: "\\\"") + "\"" : s
151 case .float(let d): return floatText(d)
152 case .character(let c): return String(c)
153 case .list(let items): return "(" + items.map { printed($0, escape: true) }.joined(separator: " ") + ")"
154 case .dotted(let items, let last): return "(" + items.map { printed($0, escape: true) }.joined(separator: " ") + " . " + printed(last, escape: true) + ")"
155 case .vector(let items): return "[" + items.map { printed($0, escape: true) }.joined(separator: " ") + "]"
156 default: return v.description
157 }
158 }
159
160 /// Emacs's float printing: the shortest text that reads back, with `.0` on whole numbers.
161 static func floatText(_ d: Double) -> String {
162 if d.isNaN { return d.sign == .minus ? "-0.0e+NaN" : "0.0e+NaN" }
163 if d.isInfinite { return d < 0 ? "-1.0e+INF" : "1.0e+INF" }
164 var text = "\(d)"
165 if let e = text.firstIndex(of: "e") {
166 let mantissa = text[..<e]
167 var exponent = String(text[text.index(after: e)...])
168 if !exponent.hasPrefix("-"), !exponent.hasPrefix("+") { exponent = "+" + exponent }
169 text = mantissa.hasSuffix(".0") ? String(mantissa.dropLast(2)) + "e" + exponent : mantissa + "e" + exponent
170 }
171 return text
172 }
173
174 // MARK: - Evaluation
175
176 /// Less than 128 KB of this thread's stack left: background threads have only 512 KB.
177 static func stackIsLow() -> Bool {
178 var marker = 0
179 let here = withUnsafeMutablePointer(to: &marker) { UInt(bitPattern: $0) }
180 let top = UInt(bitPattern: pthread_get_stackaddr_np(pthread_self()))
181 let size = UInt(pthread_get_stacksize_np(pthread_self()))
182 return here < top - size + 128 * 1024
183 }
184
185 public func eval(_ form: Sexp) throws -> Sexp {
186 steps += 1
187 if steps > Self.stepLimit { throw Signal(message: "Evaluation took too long") }
188 depth += 1
189 defer { depth -= 1 }
190 if depth > Self.depthLimit || Self.stackIsLow() { throw Signal(message: "Lisp nesting exceeds ‘max-lisp-eval-depth’") }
191 switch form {
192 case .symbol(let name):
193 if name == "nil" || name == "t" || name.hasPrefix(":") { return form }
194 return try value(name)
195 case .character(let c): return .integer(c)
196 case .list(let items):
197 guard let head = items.first else { return .nil }
198 guard case .symbol(let name) = head else {
199 if case .list(let lambda) = head, lambda.first == .symbol("lambda") {
200 return try call(head, try items.dropFirst().map(eval))
201 }
202 throw Signal(message: "Invalid function: \(head.description)")
203 }
204 return try special(name, Array(items.dropFirst())) ?? callNamed(name, try items.dropFirst().map(eval))
205 case .dotted: throw Signal(message: "Invalid function")
206 default: return form
207 }
208 }
209
210 func progn(_ body: some Collection<Sexp>) throws -> Sexp {
211 var result = Sexp.nil
212 for form in body { result = try eval(form) }
213 return result
214 }
215
216 /// Special forms and macros; nil when `name` is an ordinary function.
217 private func special(_ name: String, _ args: [Sexp]) throws -> Sexp? {
218 switch name {
219 case "quote":
220 return args.first ?? .nil
221 case "function":
222 return args.first ?? .nil
223 case "lambda":
224 return .list([.symbol("lambda")] + args)
225 case "progn":
226 return try progn(args)
227 case "prog1":
228 guard let first = args.first else { return .nil }
229 let value = try eval(first)
230 _ = try progn(args.dropFirst())
231 return value
232 case "if":
233 guard args.count >= 2 else { throw Signal(message: "Wrong number of arguments: if") }
234 return Self.isNil(try eval(args[0])) ? try progn(args.dropFirst(2)) : try eval(args[1])
235 case "when", "unless":
236 guard let test = args.first else { return .nil }
237 return Self.isNil(try eval(test)) == (name == "unless") ? try progn(args.dropFirst()) : .nil
238 case "cond":
239 for clause in args {
240 let parts = try Self.elements(clause)
241 guard let test = parts.first else { continue }
242 let value = try eval(test)
243 if !Self.isNil(value) { return parts.count == 1 ? value : try progn(parts.dropFirst()) }
244 }
245 return .nil
246 case "and":
247 var value = Self.t
248 for form in args {
249 value = try eval(form)
250 if Self.isNil(value) { return .nil }
251 }
252 return value
253 case "or":
254 for form in args {
255 let value = try eval(form)
256 if !Self.isNil(value) { return value }
257 }
258 return .nil
259 case "let", "let*":
260 guard let first = args.first else { return .nil }
261 var bindings: [String: Sexp] = [:]
262 scopes.append([:])
263 defer { scopes.removeLast() }
264 for binding in try Self.elements(first) {
265 let (variable, value): (String, Sexp)
266 if case .symbol(let s) = binding {
267 (variable, value) = (s, .nil)
268 } else {
269 let parts = try Self.elements(binding)
270 guard case .symbol(let s)? = parts.first else { throw Signal(message: "Bad binding") }
271 (variable, value) = (s, parts.count > 1 ? try eval(parts[1]) : .nil)
272 }
273 if name == "let*" { scopes[scopes.count - 1][variable] = value } else { bindings[variable] = value }
274 }
275 if name == "let" { scopes[scopes.count - 1] = bindings }
276 return try progn(args.dropFirst())
277 case "setq":
278 var value = Sexp.nil
279 var i = 0
280 while i + 1 < args.count {
281 guard case .symbol(let variable) = args[i] else { throw Signal(message: "Bad setq") }
282 value = try eval(args[i + 1])
283 assign(variable, value)
284 i += 2
285 }
286 return value
287 case "push", "pop":
288 guard case .symbol(let variable)? = (name == "push" ? args.dropFirst().first : args.first) else { throw Unsupported(what: "\(name) on a place") }
289 let list = try value(variable)
290 if name == "pop" {
291 assign(variable, try Self.cdr(list))
292 return try Self.car(list)
293 }
294 let pushed = Self.cons(try eval(args[0]), list)
295 assign(variable, pushed)
296 return pushed
297 case "while":
298 guard let test = args.first else { return .nil }
299 while !Self.isNil(try eval(test)) { _ = try progn(args.dropFirst()) }
300 return .nil
301 case "dolist", "dotimes":
302 let spec = try args.first.map(Self.elements) ?? []
303 guard case .symbol(let variable)? = spec.first, spec.count >= 2 else { throw Signal(message: "Bad \(name)") }
304 let source = try eval(spec[1])
305 let items = name == "dolist" ? try Self.elements(source) : []
306 let count = name == "dolist" ? items.count : max(0, try Self.int(source))
307 scopes.append([:])
308 defer { scopes.removeLast() }
309 for i in 0..<count {
310 steps += 1
311 if steps > Self.stepLimit { throw Signal(message: "Evaluation took too long") }
312 scopes[scopes.count - 1][variable] = name == "dolist" ? items[i] : .integer(i)
313 _ = try progn(args.dropFirst())
314 }
315 if spec.count > 2 {
316 scopes[scopes.count - 1][variable] = name == "dotimes" ? .integer(count) : .nil
317 return try eval(spec[2])
318 }
319 return .nil
320 case "with-output-to-string":
321 outputs.append("")
322 do {
323 _ = try progn(args)
324 } catch {
325 outputs.removeLast()
326 throw error
327 }
328 return .string(outputs.removeLast())
329 case "ignore-errors":
330 do { return try progn(args) } catch is Signal { return .nil }
331 case "condition-case":
332 guard args.count >= 2 else { throw Signal(message: "Bad condition-case") }
333 do {
334 return try eval(args[1])
335 } catch let signal as Signal {
336 for handler in args.dropFirst(2) {
337 let parts = try Self.elements(handler)
338 guard let condition = parts.first else { continue }
339 let names = (try? Self.elements(condition)) ?? [condition]
340 guard names.contains(.symbol("error")) || names.contains(.symbol("t")) else { continue }
341 let bindings: [String: Sexp] = args[0].symbol.map { $0 == "nil" ? [:] : [$0: .list([.symbol("error"), .string(signal.message)])] } ?? [:]
342 return try binding(bindings) { try progn(parts.dropFirst()) }
343 }
344 throw signal
345 }
346 default:
347 return nil
348 }
349 }
350
351 /// Calls a function value: a symbol naming one, or a lambda list.
352 public func call(_ function: Sexp, _ args: [Sexp]) throws -> Sexp {
353 switch function {
354 case .symbol(let name): return try callNamed(name, args)
355 case .list(let items) where items.first == .symbol("lambda") && items.count >= 2:
356 var bindings: [String: Sexp] = [:]
357 var mode = "required"
358 var i = 0
359 for parameter in try Self.elements(items[1]) {
360 guard case .symbol(let p) = parameter else { throw Signal(message: "Bad lambda list") }
361 if p == "&optional" || p == "&rest" {
362 mode = p
363 continue
364 }
365 if mode == "&rest" {
366 bindings[p] = Self.list(Array(args.dropFirst(i)))
367 i = args.count
368 } else if i < args.count {
369 bindings[p] = args[i]
370 i += 1
371 } else if mode == "&optional" {
372 bindings[p] = .nil
373 } else {
374 throw Signal(message: "Wrong number of arguments")
375 }
376 }
377 if i < args.count { throw Signal(message: "Wrong number of arguments") }
378 return try binding(bindings) { try progn(items.dropFirst(2)) }
379 default:
380 throw Signal(message: "Invalid function: \(function.description)")
381 }
382 }
383
384 func callNamed(_ name: String, _ args: [Sexp]) throws -> Sexp {
385 guard let function = functions[name] else { throw Unsupported(what: "function \(name)") }
386 return try function(self, args)
387 }
388
389 static func arity(_ args: [Sexp], _ range: ClosedRange<Int>, _ name: String) throws {
390 guard range.contains(args.count) else { throw Signal(message: "Wrong number of arguments: \(name), \(args.count)") }
391 }
392
393 // MARK: - Functions
394
395 private static func core(_ lisp: Elisp) {
396 func arithmetic(_ name: String, identity: Int, _ intOp: @escaping (Int, Int) -> (Int, Bool), _ floatOp: @escaping (Double, Double) -> Double) {
397 lisp.define(name) { _, args in
398 let numbers = try args.map(number)
399 guard var result = numbers.first else { return .integer(identity) }
400 if numbers.count == 1, name == "-" {
401 switch result {
402 case .int(let i):
403 guard i != .min else { throw Unsupported(what: "integer size") }
404 return .integer(-i)
405 case .float(let d): return .float(-d)
406 }
407 }
408 for n in numbers.dropFirst() {
409 switch (result, n) {
410 case (.int(let a), .int(let b)):
411 let (value, overflow) = intOp(a, b)
412 if overflow { throw Unsupported(what: "integer size") }
413 result = .int(value)
414 default:
415 result = .float(floatOp(result.double, n.double))
416 }
417 }
418 return sexp(result)
419 }
420 }
421 arithmetic("+", identity: 0, { $0.addingReportingOverflow($1) }, +)
422 arithmetic("-", identity: 0, { $0.subtractingReportingOverflow($1) }, -)
423 arithmetic("*", identity: 1, { $0.multipliedReportingOverflow(by: $1) }, *)
424 lisp.define("/") { _, args in
425 try arity(args, 1...Int.max, "/")
426 let numbers = try args.map(number)
427 let floating = numbers.contains { if case .float = $0 { true } else { false } }
428 if numbers.count == 1 { return try sexp(divide(.int(1), numbers[0], floating: floating)) }
429 var result = numbers[0]
430 for n in numbers.dropFirst() { result = try divide(result, n, floating: floating) }
431 return sexp(result)
432 }
433 lisp.define("%") { _, args in
434 try arity(args, 2...2, "%")
435 let b = try int(args[1])
436 guard b != 0 else { throw Signal(message: "Arithmetic error") }
437 let (r, overflow) = try int(args[0]).remainderReportingOverflow(dividingBy: b)
438 if overflow { throw Unsupported(what: "integer size") }
439 return .integer(r)
440 }
441 lisp.define("mod") { _, args in
442 try arity(args, 2...2, "mod")
443 switch (try number(args[0]), try number(args[1])) {
444 case (.int(let a), .int(let b)):
445 guard b != 0 else { throw Signal(message: "Arithmetic error") }
446 let (r, overflow) = a.remainderReportingOverflow(dividingBy: b)
447 if overflow { throw Unsupported(what: "integer size") }
448 return .integer(r != 0 && (r < 0) != (b < 0) ? r + b : r)
449 case (let a, let b):
450 let r = fmod(a.double, b.double)
451 return .float(r != 0 && (r < 0) != (b.double < 0) ? r + b.double : r)
452 }
453 }
454 lisp.define("1+") { _, args in try arity(args, 1...1, "1+"); return try sexp(add(number(args[0]), 1)) }
455 lisp.define("1-") { _, args in try arity(args, 1...1, "1-"); return try sexp(add(number(args[0]), -1)) }
456 lisp.define("abs") { _, args in
457 try arity(args, 1...1, "abs")
458 switch try number(args[0]) {
459 case .int(let i):
460 guard i != .min else { throw Unsupported(what: "integer size") }
461 return .integer(abs(i))
462 case .float(let d): return .float(abs(d))
463 }
464 }
465 for name in ["max", "min"] {
466 lisp.define(name) { _, args in
467 try arity(args, 1...Int.max, name)
468 let numbers = try args.map(number)
469 let floating = numbers.contains { if case .float = $0 { true } else { false } }
470 var best = numbers[0]
471 for n in numbers.dropFirst() where name == "max" ? n.double > best.double : n.double < best.double { best = n }
472 return floating ? .float(best.double) : sexp(best)
473 }
474 }
475 for name in ["floor", "ceiling", "round", "truncate"] {
476 lisp.define(name) { _, args in
477 try arity(args, 1...2, name)
478 var x = try number(args[0]).double
479 if args.count == 2, !isNil(args[1]) {
480 let divisor = try number(args[1]).double
481 guard divisor != 0 else { throw Signal(message: "Arithmetic error") }
482 x /= divisor
483 } else if case .int(let i) = try number(args[0]) {
484 return .integer(i)
485 }
486 let rule: FloatingPointRoundingRule = switch name {
487 case "floor": .down
488 case "ceiling": .up
489 case "round": .toNearestOrEven
490 default: .towardZero
491 }
492 guard let i = Int(exactly: x.rounded(rule)) else { throw Signal(message: "Arithmetic overflow error") }
493 return .integer(i)
494 }
495 }
496 lisp.define("float") { _, args in try arity(args, 1...1, "float"); return .float(try number(args[0]).double) }
497 for (name, op) in [("=", { (a: Double, b: Double) in a == b }), ("<", { $0 < $1 }), (">", { $0 > $1 }), ("<=", { $0 <= $1 }), (">=", { $0 >= $1 })] {
498 lisp.define(name) { _, args in
499 try arity(args, 1...Int.max, name)
500 let numbers = try args.map(number)
501 for (a, b) in zip(numbers, numbers.dropFirst()) {
502 let holds: Bool = switch (a, b) {
503 case (.int(let x), .int(let y)): op(Double(x), Double(y)) && (name != "=" || x == y)
504 default: op(a.double, b.double)
505 }
506 if !holds { return .nil }
507 }
508 return t
509 }
510 }
511 lisp.define("/=") { _, args in
512 try arity(args, 2...2, "/=")
513 return bool(try number(args[0]).double != (try number(args[1])).double)
514 }
515 lisp.define("zerop") { _, args in try arity(args, 1...1, "zerop"); return bool(try number(args[0]).double == 0) }
516 lisp.define("not") { _, args in try arity(args, 1...1, "not"); return bool(isNil(args[0])) }
517 lisp.define("null") { _, args in try arity(args, 1...1, "null"); return bool(isNil(args[0])) }
518 lisp.define("eq") { _, args in try arity(args, 2...2, "eq"); return bool(eq(args[0], args[1])) }
519 lisp.define("eql") { _, args in try arity(args, 2...2, "eql"); return bool(eq(args[0], args[1])) }
520 lisp.define("equal") { _, args in try arity(args, 2...2, "equal"); return bool(normalized(args[0]) == normalized(args[1])) }
521 lisp.define("numberp") { _, args in
522 try arity(args, 1...1, "numberp")
523 return bool((try? number(args[0])) != nil && args[0].character == nil)
524 }
525 lisp.define("integerp") { _, args in try arity(args, 1...1, "integerp"); return bool(args[0].integer != nil) }
526 lisp.define("floatp") { _, args in
527 try arity(args, 1...1, "floatp")
528 if case .float = args[0] { return t }
529 return .nil
530 }
531 lisp.define("stringp") { _, args in try arity(args, 1...1, "stringp"); return bool(args[0].string != nil) }
532 lisp.define("listp") { _, args in
533 try arity(args, 1...1, "listp")
534 switch args[0] {
535 case .list, .dotted: return t
536 default: return bool(isNil(args[0]))
537 }
538 }
539 lisp.define("consp") { _, args in
540 try arity(args, 1...1, "consp")
541 switch args[0] {
542 case .list(let items): return bool(!items.isEmpty)
543 case .dotted: return t
544 default: return .nil
545 }
546 }
547 lisp.define("symbolp") { _, args in try arity(args, 1...1, "symbolp"); return bool(args[0].symbol != nil || isNil(args[0])) }
548
549 // Lists.
550 lisp.define("car") { _, args in try arity(args, 1...1, "car"); return try car(args[0]) }
551 lisp.define("cdr") { _, args in try arity(args, 1...1, "cdr"); return try cdr(args[0]) }
552 lisp.define("cadr") { _, args in try arity(args, 1...1, "cadr"); return try car(cdr(args[0])) }
553 lisp.define("cddr") { _, args in try arity(args, 1...1, "cddr"); return try cdr(cdr(args[0])) }
554 lisp.define("cons") { _, args in try arity(args, 2...2, "cons"); return cons(args[0], args[1]) }
555 lisp.define("list") { _, args in list(args) }
556 lisp.define("nth") { _, args in
557 try arity(args, 2...2, "nth")
558 var v = args[1]
559 for _ in 0..<max(0, try int(args[0])) { v = try cdr(v) }
560 return try car(v)
561 }
562 lisp.define("nthcdr") { _, args in
563 try arity(args, 2...2, "nthcdr")
564 var v = args[1]
565 for _ in 0..<max(0, try int(args[0])) { v = try cdr(v) }
566 return v
567 }
568 lisp.define("elt") { _, args in
569 try arity(args, 2...2, "elt")
570 let items = try sequence(args[0])
571 let i = try int(args[1])
572 if case .list = args[0], i >= items.count { return .nil }
573 guard items.indices.contains(i) else { throw Signal(message: "Args out of range") }
574 return items[i]
575 }
576 lisp.define("aref") { _, args in
577 try arity(args, 2...2, "aref")
578 let items = try sequence(args[0])
579 let i = try int(args[1])
580 guard items.indices.contains(i) else { throw Signal(message: "Args out of range") }
581 return items[i]
582 }
583 lisp.define("append") { _, args in
584 guard let last = args.last else { return .nil }
585 var items: [Sexp] = []
586 for arg in args.dropLast() { items += try sequence(arg) }
587 return items.reversed().reduce(last) { cons($1, $0) }
588 }
589 lisp.define("length") { _, args in
590 try arity(args, 1...1, "length")
591 return .integer(try sequence(args[0]).count)
592 }
593 lisp.define("reverse") { _, args in
594 try arity(args, 1...1, "reverse")
595 if case .string(let s) = args[0] { return .string(String(s.reversed())) }
596 return list(try elements(args[0]).reversed())
597 }
598 lisp.define("number-sequence") { _, args in
599 try arity(args, 1...3, "number-sequence")
600 let from = try int(args[0])
601 guard args.count > 1, !isNil(args[1]) else { return .list([.integer(from)]) }
602 let to = try int(args[1])
603 let step = args.count > 2 && !isNil(args[2]) ? try int(args[2]) : 1
604 guard step != 0 else { throw Signal(message: "The increment can not be zero") }
605 let span = Double(to) - Double(from)
606 guard span / Double(step) < Double(Self.lengthLimit) else { throw Signal(message: "Too many elements for number-sequence") }
607 return list(Array(stride(from: from, through: to, by: step)).map { .integer($0) })
608 }
609 for name in ["memq", "member", "memql"] {
610 lisp.define(name) { _, args in
611 try arity(args, 2...2, name)
612 var rest = args[1]
613 while case .list(let items) = rest, let first = items.first {
614 if name == "member" ? normalized(first) == normalized(args[0]) : eq(first, args[0]) { return rest }
615 rest = list(Array(items.dropFirst()))
616 }
617 return .nil
618 }
619 }
620 for name in ["assoc", "assq"] {
621 lisp.define(name) { _, args in
622 try arity(args, 2...3, name)
623 for pair in try elements(args[1]) {
624 guard let key = try? car(pair) else { continue }
625 if name == "assoc" ? normalized(key) == normalized(args[0]) : eq(key, args[0]) { return pair }
626 }
627 return .nil
628 }
629 }
630 lisp.define("identity") { _, args in try arity(args, 1...1, "identity"); return args[0] }
631 lisp.define("ignore") { _, _ in .nil }
632 lisp.define("funcall") { lisp, args in
633 try arity(args, 1...Int.max, "funcall")
634 return try lisp.call(args[0], Array(args.dropFirst()))
635 }
636 lisp.define("apply") { lisp, args in
637 try arity(args, 1...Int.max, "apply")
638 let spread = args.count > 1 ? Array(args[1..<(args.count - 1)]) + (try elements(args[args.count - 1])) : []
639 return try lisp.call(args[0], spread)
640 }
641 lisp.define("mapcar") { lisp, args in
642 try arity(args, 2...2, "mapcar")
643 return list(try sequence(args[1]).map { try lisp.call(args[0], [$0]) })
644 }
645 lisp.define("mapc") { lisp, args in
646 try arity(args, 2...2, "mapc")
647 for item in try sequence(args[1]) { _ = try lisp.call(args[0], [item]) }
648 return args[1]
649 }
650 lisp.define("mapconcat") { lisp, args in
651 try arity(args, 1...3, "mapconcat")
652 let separator = args.count > 2 ? try string(args[2]) : ""
653 return .string(try sequence(args[1]).map { try printedString(lisp.call(args[0], [$0])) }.joined(separator: separator))
654 }
655 lisp.define("delq") { _, args in
656 try arity(args, 2...2, "delq")
657 return list(try elements(args[1]).filter { !eq($0, args[0]) })
658 }
659 lisp.define("delete") { _, args in
660 try arity(args, 2...2, "delete")
661 return list(try elements(args[1]).filter { normalized($0) != normalized(args[0]) })
662 }
663 lisp.define("error") { _, args in
664 let message = args.isEmpty ? "" : try format(args)
665 throw Signal(message: message)
666 }
667 lisp.define("user-error") { _, args in
668 throw Signal(message: args.isEmpty ? "" : try format(args))
669 }
670
671 // Printing.
672 for (name, escape) in [("princ", false), ("prin1", true), ("print", true)] {
673 lisp.define(name) { lisp, args in
674 try arity(args, 1...2, name)
675 let text = printed(args[0], escape: escape)
676 lisp.outputs[lisp.outputs.count - 1] += name == "print" ? "\n" + text + "\n" : text
677 return args[0]
678 }
679 }
680 lisp.define("terpri") { lisp, _ in
681 lisp.outputs[lisp.outputs.count - 1] += "\n"
682 return t
683 }
684 lisp.define("message") { lisp, args in
685 guard !args.isEmpty, !isNil(args[0]) else { return .nil }
686 let text = try format(args)
687 lisp.messages += text + "\n"
688 return .string(text)
689 }
690 lisp.define("prin1-to-string") { _, args in
691 try arity(args, 1...2, "prin1-to-string")
692 return .string(printed(args[0], escape: args.count < 2 || isNil(args[1])))
693 }
694
695 // Strings.
696 lisp.define("concat") { _, args in .string(try args.map(printedString).joined()) }
697 lisp.define("format") { _, args in .string(try format(args)) }
698 lisp.define("format-message") { _, args in .string(try format(args)) }
699 lisp.define("string=") { _, args in
700 try arity(args, 2...2, "string=")
701 return bool(try stringOrSymbol(args[0]) == (try stringOrSymbol(args[1])))
702 }
703 lisp.define("string-equal") { _, args in
704 try arity(args, 2...2, "string-equal")
705 return bool(try stringOrSymbol(args[0]) == (try stringOrSymbol(args[1])))
706 }
707 lisp.define("string<") { _, args in
708 try arity(args, 2...2, "string<")
709 return bool(Array(try stringOrSymbol(args[0]).unicodeScalars.map(\.value)).lexicographicallyPrecedes(try stringOrSymbol(args[1]).unicodeScalars.map(\.value)))
710 }
711 lisp.define("string-lessp") { lisp, args in try lisp.callNamed("string<", args) }
712 lisp.define("upcase") { _, args in
713 try arity(args, 1...1, "upcase")
714 if case .integer(let c) = args[0] { return .integer(Int(String(try scalar(c)).uppercased().unicodeScalars.first!.value)) }
715 return .string(try string(args[0]).uppercased())
716 }
717 lisp.define("downcase") { _, args in
718 try arity(args, 1...1, "downcase")
719 if case .integer(let c) = args[0] { return .integer(Int(String(try scalar(c)).lowercased().unicodeScalars.first!.value)) }
720 return .string(try string(args[0]).lowercased())
721 }
722 lisp.define("capitalize") { _, args in
723 try arity(args, 1...1, "capitalize")
724 return .string(try string(args[0]).capitalized)
725 }
726 lisp.define("substring") { _, args in
727 try arity(args, 1...3, "substring")
728 let chars = Array(try string(args[0]))
729 func index(_ v: Sexp?, _ fallback: Int) throws -> Int {
730 guard let v, !isNil(v) else { return fallback }
731 let i = try int(v)
732 return i < 0 ? chars.count + i : i
733 }
734 let from = try index(args.count > 1 ? args[1] : nil, 0)
735 let to = try index(args.count > 2 ? args[2] : nil, chars.count)
736 guard from >= 0, to <= chars.count, from <= to else { throw Signal(message: "Args out of range") }
737 return .string(String(chars[from..<to]))
738 }
739 lisp.define("string-to-number") { _, args in
740 try arity(args, 1...2, "string-to-number")
741 return stringToNumber(try string(args[0]))
742 }
743 for name in ["number-to-string", "int-to-string"] {
744 lisp.define(name) { _, args in
745 try arity(args, 1...1, name)
746 return .string(printed(sexp(try number(args[0]))))
747 }
748 }
749 lisp.define("string-prefix-p") { _, args in
750 try arity(args, 2...3, "string-prefix-p")
751 return bool(try string(args[1]).hasPrefix(try string(args[0])))
752 }
753 lisp.define("string-suffix-p") { _, args in
754 try arity(args, 2...3, "string-suffix-p")
755 return bool(try string(args[1]).hasSuffix(try string(args[0])))
756 }
757 lisp.define("string-empty-p") { _, args in
758 try arity(args, 1...1, "string-empty-p")
759 return bool(try stringOrSymbol(args[0]).isEmpty)
760 }
761 lisp.define("string-trim") { _, args in
762 try arity(args, 1...1, "string-trim")
763 return .string(try string(args[0]).trimmingCharacters(in: .whitespacesAndNewlines))
764 }
765 lisp.define("split-string") { _, args in
766 try arity(args, 1...2, "split-string")
767 let s = try string(args[0])
768 if args.count == 2, !isNil(args[1]) {
769 let separator = try string(args[1])
770 let regex = try NSRegularExpression(pattern: separator)
771 let ns = s as NSString
772 var parts: [Sexp] = []
773 var start = 0
774 for m in regex.matches(in: s, range: NSRange(location: 0, length: ns.length)) where m.range.length > 0 {
775 parts.append(.string(ns.substring(with: NSRange(location: start, length: m.range.location - start))))
776 start = NSMaxRange(m.range)
777 }
778 parts.append(.string(ns.substring(from: start)))
779 return list(parts)
780 }
781 return list(s.split(whereSeparator: { " \t\n\r\u{0C}\u{0B}".contains($0) }).map { .string(String($0)) })
782 }
783 }
784
785 static func add(_ n: Number, _ k: Int) throws -> Number {
786 switch n {
787 case .int(let i):
788 let (sum, overflow) = i.addingReportingOverflow(k)
789 if overflow { throw Unsupported(what: "integer size") }
790 return .int(sum)
791 case .float(let d): return .float(d + Double(k))
792 }
793 }
794
795 /// A character code as a character.
796 static func scalar(_ code: Int) throws -> Unicode.Scalar {
797 guard code >= 0, code <= 0x10FFFF, let scalar = Unicode.Scalar(UInt32(code)) else {
798 throw Signal(message: "Invalid character: \(code)")
799 }
800 return scalar
801 }
802
803 static func divide(_ a: Number, _ b: Number, floating: Bool) throws -> Number {
804 if !floating, case .int(let x) = a, case .int(let y) = b {
805 guard y != 0 else { throw Signal(message: "Arithmetic error") }
806 let (q, overflow) = x.dividedReportingOverflow(by: y)
807 if overflow { throw Unsupported(what: "integer size") }
808 return .int(q)
809 }
810 return .float(a.double / b.double)
811 }
812
813 static func eq(_ a: Sexp, _ b: Sexp) -> Bool {
814 switch (normalized(a), normalized(b)) {
815 case (.symbol(let x), .symbol(let y)): x == y
816 case (.integer(let x), .integer(let y)): x == y
817 case (.float(let x), .float(let y)): x == y
818 default: false
819 }
820 }
821
822 /// Characters as integers and the empty list as nil, for comparing.
823 static func normalized(_ v: Sexp) -> Sexp {
824 switch v {
825 case .character(let c): .integer(c)
826 case .list(let items): items.isEmpty ? .nil : .list(items.map(normalized))
827 case .dotted(let items, let last): .dotted(items.map(normalized), normalized(last))
828 case .vector(let items): .vector(items.map(normalized))
829 default: v
830 }
831 }
832
833 static func sequence(_ v: Sexp) throws -> [Sexp] {
834 switch v {
835 case .string(let s): return s.unicodeScalars.map { .integer(Int($0.value)) }
836 case .vector(let items): return items
837 default: return try elements(v)
838 }
839 }
840
841 static func stringOrSymbol(_ v: Sexp) throws -> String {
842 if case .symbol(let s) = v { return s }
843 return try string(v)
844 }
845
846 /// What `concat` and `mapconcat` accept: strings, and lists or vectors of characters.
847 static func printedString(_ v: Sexp) throws -> String {
848 switch v {
849 case .string(let s): return s
850 case _ where isNil(v): return ""
851 case .list, .vector:
852 return String(String.UnicodeScalarView(try sequence(v).map { try scalar(try int($0)) }))
853 default: throw Signal(message: "Wrong type argument: sequencep, \(v.description)")
854 }
855 }
856
857 /// `string-to-number` in base 10.
858 static func stringToNumber(_ s: String) -> Sexp {
859 let trimmed = s.drop { $0 == " " || $0 == "\t" || $0 == "\n" }
860 guard let r = trimmed.range(of: "^[-+]?([0-9]+\\.?[0-9]*|\\.[0-9]+)([eE][-+]?[0-9]+)?", options: .regularExpression) else { return .integer(0) }
861 let text = String(trimmed[r])
862 if text.range(of: "^[-+]?[0-9]+$", options: .regularExpression) != nil, let i = Int(text.hasPrefix("+") ? String(text.dropFirst()) : text) {
863 return .integer(i)
864 }
865 if text.range(of: "^[-+]?[0-9]+\\.$", options: .regularExpression) != nil, let i = Int(text.dropLast().replacingOccurrences(of: "+", with: "")) {
866 return .integer(i)
867 }
868 return .float(Double(text) ?? 0)
869 }
870
871 /// `format`.
872 static func format(_ args: [Sexp]) throws -> String {
873 let spec = Array(try string(args[0]))
874 var out = ""
875 var next = 1
876 var i = 0
877 func argument() throws -> Sexp {
878 guard next < args.count else { throw Signal(message: "Not enough arguments for format string") }
879 defer { next += 1 }
880 return args[next]
881 }
882 while i < spec.count {
883 let c = spec[i]
884 i += 1
885 guard c == "%" else {
886 out.append(c)
887 continue
888 }
889 var flags = ""
890 while i < spec.count, "-+ #0".contains(spec[i]) {
891 flags.append(spec[i])
892 i += 1
893 }
894 var width = ""
895 while i < spec.count, spec[i].isNumber {
896 width.append(spec[i])
897 i += 1
898 }
899 var precision: Int?
900 if i < spec.count, spec[i] == "." {
901 i += 1
902 var digits = ""
903 while i < spec.count, spec[i].isNumber {
904 digits.append(spec[i])
905 i += 1
906 }
907 precision = Int(digits) ?? 0
908 }
909 guard i < spec.count else { throw Signal(message: "Format string ends in middle of format specifier") }
910 let conversion = spec[i]
911 i += 1
912 var text: String
913 switch conversion {
914 case "%":
915 out.append("%")
916 continue
917 case "s", "S":
918 text = printed(try argument(), escape: conversion == "S")
919 if let precision { text = String(text.prefix(precision)) }
920 case "d", "o", "x", "X":
921 let value: Int
922 switch try number(try argument()) {
923 case .int(let n): value = n
924 case .float(let d):
925 guard let n = Int(exactly: d.rounded(.towardZero)) else { throw Signal(message: "Arithmetic overflow") }
926 value = n
927 }
928 text = String(format: "%" + flags + width + (precision.map { ".\($0)" } ?? "") + (conversion == "d" ? "ld" : "l" + String(conversion)), value)
929 out += text
930 continue
931 case "c":
932 text = String(try scalar(try int(try argument())))
933 case "e", "f", "g":
934 let value = try number(try argument()).double
935 out += String(format: "%" + flags + width + (precision.map { ".\($0)" } ?? "") + String(conversion), value)
936 continue
937 default:
938 throw Signal(message: "Invalid format operation %\(conversion)")
939 }
940 let pad = max(0, (Int(width) ?? 0) - text.count)
941 out += flags.contains("-") ? text + String(repeating: " ", count: pad) : String(repeating: " ", count: pad) + text
942 }
943 return out
944 }
945}
946
947extension Sexp {
948 var character: Int? { if case .character(let c) = self { return c } else { return nil } }
949}
950
951extension LispReader {
952 /// The first form in `text` and the number of characters it spans, as `forward-sexp`
953 /// would read it.
954 public static func readFirst(_ text: String) throws -> (sexp: Sexp, length: Int) {
955 var reader = Reader(Array(text.unicodeScalars))
956 let sexp = try reader.form()
957 let consumed = String(String.UnicodeScalarView(reader.chars[..<reader.index]))
958 return (sexp, consumed.count)
959 }
960}