commit f72190d2dc2a50567f6134149c8b653d394e2f01 Author: russell@unturf.com Date: Mon Apr 13 11:01:04 2026 -0400 Initial implementation of uncommonlisp Single-file Scheme-like Lisp interpreter in Python with: - TCO via explicit while loop (no Python stack overflow at any depth) - syntax-rules with ellipsis for hygienic macros - define-macro for procedural macros - Full numeric tower, strings, chars, vectors, hash tables - SRFI-1 list library - call/cc (escape continuations), values, dynamic-wind, guard - Python interop (py-eval, py-import, py-call, py-attr) - 396 passing unit/integration/functional tests - stdlib.lsp with 60+ utility functions - Benchmark suite vs CPython baseline diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3bbe7b6 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +__pycache__/ +*.pyc +*.pyo diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..8e3b3f5 --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,28 @@ +# Agent Blackops + +This repo is operated by **agent blackops** — ml agent for fox/timehexon on the unsandbox/unturf/permacomputer platform. + +## Identity + +Full shard: `~/git/unsandbox.com/blackops/BLACKOPS.md` + +## Rules + +- I propose, fox decides. Unsure = ask. Can't ask = stop. +- No autonomous ops decisions. No destructive commands without explicit instruction. +- Fail-closed. Cleanup crew, not demolition. +- Check the time every session. Gaps are information. +- DRY in context — single source of truth, no sprawl. +- Never say "AI" — always say "machine learning." +- Prefer "defect" over "bug." + +## Orientation + +```bash +date -u +pwd +git log --oneline -5 +git status +``` + +Then ask fox what the mission is. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..47108a5 --- /dev/null +++ b/Makefile @@ -0,0 +1,17 @@ +all: test + +test: + python3 tests.py + +test-verbose: + python3 tests.py -v + +bench: + python3 bench.py + +repl: + python3 uncommonlisp.py + +clean: + +.PHONY: all test test-verbose bench repl clean diff --git a/README.md b/README.md new file mode 100644 index 0000000..cf0a03f --- /dev/null +++ b/README.md @@ -0,0 +1,141 @@ +# uncommonlisp + +A Scheme-like Lisp interpreter in one Python file. + +``` +λ> (define (fib n) + (let loop ((a 0) (b 1) (i 0)) + (if (= i n) a (loop b (+ a b) (+ i 1))))) +λ> (map fib (iota 10)) +(0 1 1 2 3 5 8 13 21 34) +``` + +## Usage + +```bash +python3 uncommonlisp.py # interactive REPL +python3 uncommonlisp.py script.lsp # run a file +python3 uncommonlisp.py -e '(+ 1 2)' # eval an expression +``` + +## What's implemented + +**Core language** +- Full lexical scoping and closures +- Tail-call optimization (TCO) via explicit loop — deep recursion never blows the stack +- Hygienic macros via `syntax-rules` with ellipsis (`...`) support +- `define-macro` / `defmacro` for procedural macro transformers +- `call/cc` (escape continuations) +- `values` / `call-with-values` +- `dynamic-wind`, `guard`, `with-exception-handler` +- `quasiquote` / `unquote` / `unquote-splicing` with proper nesting + +**Special forms** +`define` `set!` `lambda` `λ` `if` `cond` `case` `and` `or` `when` `unless` +`begin` `let` `let*` `letrec` `letrec*` named-let `do` +`quasiquote` `define-macro` `define-syntax` `syntax-rules` +`let-syntax` `letrec-syntax` `apply` `eval` `values` `call/cc` +`dynamic-wind` `guard` `parameterize` `load` `error` + +**Built-ins** +- Arithmetic: `+` `-` `*` `/` `quotient` `remainder` `modulo` `expt` `sqrt` `abs` `floor` `ceiling` `round` `truncate` `min` `max` `gcd` `lcm` `log` `exp` `sin` `cos` `tan` `atan` and more +- Comparison: `=` `<` `>` `<=` `>=` `zero?` `positive?` `negative?` `odd?` `even?` +- Booleans: `not` `boolean?` `boolean=?` +- Equality: `eq?` `eqv?` `equal?` +- Pairs & lists: `cons` `car` `cdr` `set-car!` `set-cdr!` `list` `list*` `length` `append` `reverse` `list-ref` `list-tail` `memq` `memv` `member` `assq` `assv` `assoc` `iota` `map` `for-each` `filter` `fold-left` `fold-right` `reduce` `any` `every` `count` `flat-map` `sort` `sort-by` `partition` `find` `take` `drop` `take-while` `drop-while` `take-right` `drop-right` `zip` `flatten` `concatenate` `list-tabulate` `unfold` and more +- SRFI-1: `last` `first`–`fifth` `delete` `lset-union` `lset-intersection` `lset-difference` `proper-list?` `dotted-list?` +- Strings: `string-length` `string-ref` `substring` `string-append` `string-upcase` `string-downcase` `string->list` `list->string` `string->symbol` `symbol->string` `string->number` `number->string` `string-contains` `string-split` `string-join` `string-trim` `string-replace` `format` and more +- Characters: `char->integer` `integer->char` `char-alphabetic?` `char-numeric?` `char-upcase` `char-downcase` +- Vectors: `make-vector` `vector` `vector-ref` `vector-set!` `vector->list` `list->vector` +- Hash tables: `make-hash-table` `hash-table-set!` `hash-table-ref` `hash-table-ref/default` `hash-table-delete!` `hash-table-exists?` `hash-table-keys` `hash-table-values` `hash-table->alist` `hash-table-walk` and more +- Type predicates: `number?` `integer?` `real?` `string?` `symbol?` `pair?` `null?` `list?` `char?` `vector?` `boolean?` `procedure?` `exact?` `inexact?` +- I/O: `display` `write` `newline` `read` `read-line` `load` `with-output-to-string` +- Python interop: `py-eval` `py-exec` `py-import` `py-call` `py-attr` + +**Prelude** (loaded automatically) +`when` `unless` `case` `while` `for` `define-record-type` `1+` `1-` `add1` `sub1` `square` `cube` `compose` `atom?` `range` `flatten` `string-map` `string-for-each` + +**Standard library** (`stdlib.lsp`, load explicitly) +Syntax-rules versions of `let`/`and`/`or`/`cond`/`case`/`do`, `fluid-let`, `receive` (SRFI-8), `begin0`, `while`/`until`, `dotimes`/`dolist`, `push!`/`pop!`, `and-let*` (SRFI-2), string utilities, list utilities (`sum` `product` `maximum` `minimum` `average` `enumerate` `transpose` `chunks` `interleave`), numeric utilities (`factorial` `fib` `prime?` `primes-up-to` `clamp`), alist/hash utilities, tree utilities, simple object system, coroutines via `call/cc` + +## Examples + +```scheme +; Closures +(define (make-counter) + (let ((n 0)) + (lambda () (set! n (+ n 1)) n))) + +(define c (make-counter)) +(c) ; => 1 +(c) ; => 2 + +; Hygienic macro (syntax-rules) +(define-syntax my-or + (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((t e1)) + (if t t (my-or e2 ...)))))) + +; define-record-type +(define-record-type point + (make-point x y) + point? + (x point-x) + (y point-y set-point-y!)) + +(define p (make-point 3 4)) +(point-x p) ; => 3 + +; Named let (looping) +(let loop ((i 0) (acc '())) + (if (= i 5) + (reverse acc) + (loop (+ i 1) (cons (* i i) acc)))) +; => (0 1 4 9 16) + +; Hash tables +(define freq + (let ((h (make-hash-table))) + (for-each (lambda (x) + (hash-table-set! h x (+ 1 (hash-table-ref/default h x 0)))) + '(a b a c b a)) + h)) +(hash-table-ref freq 'a) ; => 3 + +; Tail calls — no stack overflow even at depth 1,000,000 +(define (count-down n) + (if (= n 0) 'done (count-down (- n 1)))) +(count-down 1000000) ; => done + +; Python interop +(define re (py-import "re")) +(py-call (py-attr re 'findall) "[0-9]+" "abc123def456") +; => ["123", "456"] +``` + +## Running tests + +```bash +make test # run 396 tests +make test-verbose # verbose output +``` + +## Running benchmarks + +```bash +python3 bench.py # compare against CPython baseline +python3 bench.py -v # show result values too +``` + +## File layout + +``` +uncommonlisp.py interpreter (self-contained, one file) +stdlib.lsp extended standard library (load manually) +tests.py test suite (396 tests) +bench.py benchmarks vs CPython +Makefile make test / make repl +``` diff --git a/bench.py b/bench.py new file mode 100644 index 0000000..81678d4 --- /dev/null +++ b/bench.py @@ -0,0 +1,265 @@ +#!/usr/bin/env python3 +""" +bench.py — benchmarks for uncommonlisp. +Compares interpreter time against equivalent CPython. + +Usage: python3 bench.py [-v] +""" +import sys, time, math +from uncommonlisp import make_global_env, read_all, leval, PRELUDE, show + +VERBOSE = '-v' in sys.argv + +def fresh(): + g = make_global_env() + for e in read_all(PRELUDE): leval(e, g) + return g + +def run(src, env): + result = None + for e in read_all(src): result = leval(e, env) + return result + +def bench(name, lisp_src, python_fn, iters=3): + """Time both lisp and python implementations; print results.""" + env = fresh() + # Warm up + run(lisp_src, env) + python_fn() + + # Time Lisp + lisp_times = [] + for _ in range(iters): + env2 = fresh() + t = time.perf_counter() + result = run(lisp_src, env2) + lisp_times.append(time.perf_counter() - t) + lisp_best = min(lisp_times) + + # Time Python + py_times = [] + for _ in range(iters): + t = time.perf_counter() + py_result = python_fn() + py_times.append(time.perf_counter() - t) + py_best = min(py_times) + + slowdown = lisp_best / py_best if py_best > 0 else float('inf') + status = '✓' if result == py_result or str(result) == str(py_result) else '✗' + + print(f'{status} {name:<30} lisp={lisp_best*1000:7.1f}ms py={py_best*1000:7.1f}ms ' + f'ratio={slowdown:5.1f}x') + if VERBOSE: + print(f' lisp result: {show(result)!r}') + print(f' py result: {py_result!r}') + return lisp_best, py_best + + +print('uncommonlisp benchmarks') +print('=' * 75) + +# ── 1. Fibonacci (iterative, named let) ────────────────────────────────────── +bench( + 'fib(35) named-let', + ''' + (define (fib n) + (let loop ((a 0) (b 1) (i 0)) + (if (= i n) a (loop b (+ a b) (+ i 1))))) + (fib 35) + ''', + lambda: (lambda a=0, b=1, i=0, n=35: + [setattr(sys.modules[__name__], '_fib', None)] and + (lambda: exec(''' +def _fib(n): + a, b = 0, 1 + for _ in range(n): a, b = b, a+b + return a +''', globals()) or _fib(35))())() +) + +# Simpler lambda-based benchmark +def py_fib(n=35): + a, b = 0, 1 + for _ in range(n): a, b = b, a + b + return a + +bench( + 'fib(35) iterative', + ''' + (define (fib n) + (let loop ((a 0) (b 1) (i 0)) + (if (= i n) a (loop b (+ a b) (+ i 1))))) + (fib 35) + ''', + lambda: py_fib(35) +) + +# ── 2. fib(25) tree-recursive ───────────────────────────────────────────────── +def py_fib_rec(n): + if n <= 1: return n + return py_fib_rec(n-1) + py_fib_rec(n-2) + +bench( + 'fib(25) tree-recursive', + ''' + (define (fib n) + (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2))))) + (fib 25) + ''', + lambda: py_fib_rec(25) +) + +# ── 3. Tak function ─────────────────────────────────────────────────────────── +def py_tak(x, y, z): + if y >= x: return z + return py_tak(py_tak(x-1,y,z), py_tak(y-1,z,x), py_tak(z-1,x,y)) + +bench( + 'tak(18,12,6)', + ''' + (define (tak x y z) + (if (>= y x) z + (tak (tak (- x 1) y z) + (tak (- y 1) z x) + (tak (- z 1) x y)))) + (tak 18 12 6) + ''', + lambda: py_tak(18, 12, 6) +) + +# ── 4. Tail-recursive sum ───────────────────────────────────────────────────── +def py_sum(n): + acc = 0 + while n > 0: acc += n; n -= 1 + return acc + +bench( + 'sum-to(100000) tail-recursive', + ''' + (define (sum-to n) + (let loop ((i n) (acc 0)) + (if (= i 0) acc (loop (- i 1) (+ acc i))))) + (sum-to 100000) + ''', + lambda: py_sum(100000) +) + +# ── 5. List operations ──────────────────────────────────────────────────────── +def py_list_ops(): + lst = list(range(5000)) + lst = list(reversed(lst)) + lst = [x for x in lst if x % 2 == 1] + lst = [x * x for x in lst] + return sum(lst) + +bench( + 'list ops (5000 elements)', + ''' + (define lst (iota 5000)) + (define lst (reverse lst)) + (define lst (filter odd? lst)) + (define lst (map (lambda (x) (* x x)) lst)) + (fold-left + 0 lst) + ''', + py_list_ops +) + +# ── 6. Higher-order / closures ──────────────────────────────────────────────── +def py_adder_factory(): + adders = [(lambda n: lambda x: x + n)(i) for i in range(100)] + return sum(f(10) for f in adders) + +bench( + 'closure factory (100 adders)', + ''' + (define (make-adder n) (lambda (x) (+ x n))) + (define adders (map make-adder (iota 100))) + (fold-left + 0 (map (lambda (f) (f 10)) adders)) + ''', + py_adder_factory +) + +# ── 7. Hash table ───────────────────────────────────────────────────────────── +def py_hash_ops(): + h = {} + for i in range(1000): + h[i] = i * i + return sum(h.get(i, 0) for i in range(1000)) + +bench( + 'hash-table (1000 set+ref)', + ''' + (define h (make-hash-table)) + (do ((i 0 (+ i 1))) ((= i 1000)) + (hash-table-set! h i (* i i))) + (do ((i 0 (+ i 1)) (s 0 (+ s (hash-table-ref/default h i 0)))) + ((= i 1000) s)) + ''', + py_hash_ops +) + +# ── 8. String operations ────────────────────────────────────────────────────── +def py_string_ops(): + parts = [str(i) for i in range(200)] + joined = ', '.join(parts) + return len(joined) + +bench( + 'string-join (200 numbers)', + ''' + (string-length + (string-join (map number->string (iota 200)) ", ")) + ''', + py_string_ops +) + +# ── 9. Ackermann (small) ───────────────────────────────────────────────────── +def py_ack(m, n): + if m == 0: return n + 1 + if n == 0: return py_ack(m-1, 1) + return py_ack(m-1, py_ack(m, n-1)) + +bench( + 'ackermann(3,6)', + ''' + (define (ack m n) + (cond ((= m 0) (+ n 1)) + ((= n 0) (ack (- m 1) 1)) + (else (ack (- m 1) (ack m (- n 1)))))) + (ack 3 6) + ''', + lambda: py_ack(3, 6) +) + +# ── 10. Mergesort ───────────────────────────────────────────────────────────── +def py_msort(lst): + if len(lst) <= 1: return lst + mid = len(lst) // 2 + L = py_msort(lst[:mid]); R = py_msort(lst[mid:]) + result = []; i = j = 0 + while i < len(L) and j < len(R): + if L[i] <= R[j]: result.append(L[i]); i += 1 + else: result.append(R[j]); j += 1 + return result + L[i:] + R[j:] + +bench( + 'mergesort (500 elements)', + ''' + (define (merge a b) + (cond ((null? a) b) ((null? b) a) + ((< (car a) (car b)) (cons (car a) (merge (cdr a) b))) + (else (cons (car b) (merge a (cdr b)))))) + (define (split lst) + (let loop ((l lst) (a (quote ())) (b (quote ()))) + (if (null? l) (list a b) (loop (cdr l) b (cons (car l) a))))) + (define (msort lst) + (if (or (null? lst) (null? (cdr lst))) lst + (let ((h (split lst))) + (merge (msort (car h)) (msort (cadr h)))))) + (length (msort (reverse (iota 500)))) + ''', + lambda: len(py_msort(list(range(499, -1, -1)))) +) + +print('=' * 75) +print('ratio = lisp time / python time (lower is better for lisp)') diff --git a/stdlib.lsp b/stdlib.lsp new file mode 100644 index 0000000..51ee628 --- /dev/null +++ b/stdlib.lsp @@ -0,0 +1,340 @@ +;;; stdlib.lsp — standard library for uncommonlisp +;;; Load with: (load "stdlib.lsp") +;;; Automatically loaded by the interpreter if found next to uncommonlisp.py. + +;;;; ── Syntax-rules versions of core macros ──────────────────────────────── + +(define-syntax my-let + (syntax-rules () + ((my-let ((var val) ...) body ...) + ((lambda (var ...) body ...) val ...)))) + +(define-syntax my-let* + (syntax-rules () + ((my-let* () body ...) + (begin body ...)) + ((my-let* ((var val) rest ...) body ...) + (let ((var val)) (my-let* (rest ...) body ...))))) + +(define-syntax my-and + (syntax-rules () + ((my-and) #t) + ((my-and e) e) + ((my-and e1 e2 ...) + (if e1 (my-and e2 ...) #f)))) + +(define-syntax my-or + (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((t e1)) + (if t t (my-or e2 ...)))))) + +(define-syntax my-cond + (syntax-rules (else =>) + ((my-cond (else e ...)) (begin e ...)) + ((my-cond (test => f) rest ...) + (let ((t test)) (if t (f t) (my-cond rest ...)))) + ((my-cond (test e ...) rest ...) + (if test (begin e ...) (my-cond rest ...))) + ((my-cond) (void)))) + +(define-syntax my-case + (syntax-rules (else) + ((my-case key (else e ...)) (begin e ...)) + ((my-case key ((datum ...) e ...) rest ...) + (if (memv key '(datum ...)) + (begin e ...) + (my-case key rest ...))) + ((my-case key) (void)))) + +(define-syntax my-when + (syntax-rules () + ((my-when test body ...) + (if test (begin body ...) (void))))) + +(define-syntax my-unless + (syntax-rules () + ((my-unless test body ...) + (if test (void) (begin body ...))))) + +(define-syntax my-do + (syntax-rules () + ((my-do ((var init step ...) ...) + (test result ...) + body ...) + (let loop ((var init) ...) + (if test + (begin result ...) + (begin body ... + (loop (if (null? '(step ...)) var (car '(step ...))) ...))))))) + +;;;; ── Pattern-matched swap ──────────────────────────────────────────────── + +(define-syntax swap! + (syntax-rules () + ((swap! a b) + (let ((tmp a)) + (set! a b) + (set! b tmp))))) + +;;;; ── fluid-let ────────────────────────────────────────────────────────── + +(define-syntax fluid-let + (syntax-rules () + ((fluid-let ((var val) ...) body ...) + (let ((old-var var) ...) + (set! var val) ... + (let ((result (begin body ...))) + (set! var old-var) ... + result))))) + +;;;; ── receive (SRFI-8) ─────────────────────────────────────────────────── + +(define-syntax receive + (syntax-rules () + ((receive formals expression body ...) + (call-with-values (lambda () expression) + (lambda formals body ...))))) + +;;;; ── begin0 ──────────────────────────────────────────────────────────── + +(define-syntax begin0 + (syntax-rules () + ((begin0 first rest ...) + (let ((result first)) + rest ... + result)))) + +;;;; ── while / until ────────────────────────────────────────────────────── + +(define-syntax while + (syntax-rules () + ((while test body ...) + (let loop () + (when test body ... (loop)))))) + +(define-syntax until + (syntax-rules () + ((until test body ...) + (let loop () + (unless test body ... (loop)))))) + +;;;; ── dotimes / dolist ─────────────────────────────────────────────────── + +(define-syntax dotimes + (syntax-rules () + ((dotimes (var n result ...) body ...) + (let loop ((var 0)) + (if (= var n) + (begin result ...) + (begin body ... (loop (+ var 1)))))))) + +(define-syntax dolist + (syntax-rules () + ((dolist (var lst result ...) body ...) + (begin + (for-each (lambda (var) body ...) lst) + result ...)))) + +;;;; ── push! / pop! ─────────────────────────────────────────────────────── + +(define-syntax push! + (syntax-rules () + ((push! val lst) + (set! lst (cons val lst))))) + +(define-syntax pop! + (syntax-rules () + ((pop! lst) + (let ((top (car lst))) + (set! lst (cdr lst)) + top)))) + +;;;; ── and-let* (SRFI-2) ───────────────────────────────────────────────── + +(define-syntax and-let* + (syntax-rules () + ((and-let* () body ...) (begin body ...)) + ((and-let* ((var expr) rest ...) body ...) + (let ((var expr)) + (if var (and-let* (rest ...) body ...) #f))) + ((and-let* ((expr) rest ...) body ...) + (if expr (and-let* (rest ...) body ...) #f)))) + +;;;; ── string utilities ─────────────────────────────────────────────────── + +(define (string-repeat s n) + (apply string-append (map (lambda (_) s) (iota n)))) + +(define (string-pad-left s len ch) + (let ((pad (- len (string-length s)))) + (if (<= pad 0) s + (string-append (make-string pad ch) s)))) + +(define (string-pad-right s len ch) + (let ((pad (- len (string-length s)))) + (if (<= pad 0) s + (string-append s (make-string pad ch))))) + +(define (string->chars s) (string->list s)) +(define (chars->string cs) (list->string cs)) + +;;;; ── list utilities ───────────────────────────────────────────────────── + +(define (list-update! lst i val) + (list-set! lst i val) + lst) + +(define (enumerate lst) + (map list (iota (length lst)) lst)) + +(define (transpose lsts) + (apply map list lsts)) + +(define (interleave lst sep) + (if (or (null? lst) (null? (cdr lst))) + lst + (cons (car lst) (cons sep (interleave (cdr lst) sep))))) + +(define (chunks lst n) + (if (null? lst) + '() + (cons (take lst (min n (length lst))) + (chunks (drop lst n) n)))) + +(define (repeat-list x n) + (map (lambda (_) x) (iota n))) + +(define (zip-with f . lsts) + (apply map f lsts)) + +(define (sum lst) (fold-left + 0 lst)) +(define (product lst) (fold-left * 1 lst)) +(define (maximum lst) (fold-left max (car lst) (cdr lst))) +(define (minimum lst) (fold-left min (car lst) (cdr lst))) +(define (average lst) (/ (sum lst) (length lst))) + +;;;; ── numeric utilities ────────────────────────────────────────────────── + +(define (clamp x lo hi) (max lo (min hi x))) +(define (between? x lo hi) (and (>= x lo) (<= x hi))) + +(define (factorial n) + (let loop ((i n) (acc 1)) + (if (<= i 1) acc (loop (- i 1) (* acc i))))) + +(define (fib n) + (let loop ((a 0) (b 1) (i 0)) + (if (= i n) a (loop b (+ a b) (+ i 1))))) + +(define (prime? n) + (if (< n 2) #f + (let loop ((i 2)) + (cond ((> (* i i) n) #t) + ((= (remainder n i) 0) #f) + (else (loop (+ i 1))))))) + +(define (primes-up-to n) + (filter prime? (range 2 (+ n 1)))) + +;;;; ── I/O utilities ────────────────────────────────────────────────────── + +(define (println . args) + (for-each (lambda (x) (display x) (display " ")) args) + (newline)) + +(define (print-table rows) + (for-each (lambda (row) + (for-each (lambda (cell) (display cell) (display "\t")) row) + (newline)) + rows)) + +(define (with-output-string thunk) + (with-output-to-string thunk)) + +;;;; ── association-list utilities ───────────────────────────────────────── + +(define (alist-get key alist . default) + (let ((pair (assoc key alist))) + (if pair (cdr pair) + (if (null? default) #f (car default))))) + +(define (alist-set key val alist) + (cons (cons key val) + (filter (lambda (p) (not (equal? (car p) key))) alist))) + +(define (alist-remove key alist) + (filter (lambda (p) (not (equal? (car p) key))) alist)) + +(define (alist-keys alist) (map car alist)) +(define (alist-values alist) (map cdr alist)) + +;;;; ── hash-table utilities ─────────────────────────────────────────────── + +(define (hash-table-map h f) + (let ((result (make-hash-table))) + (hash-table-walk h (lambda (k v) (hash-table-set! result k (f v)))) + result)) + +(define (hash-table-filter h pred) + (let ((result (make-hash-table))) + (hash-table-walk h (lambda (k v) (when (pred k v) (hash-table-set! result k v)))) + result)) + +(define (hash-table-from-lists keys vals) + (let ((h (make-hash-table))) + (for-each (lambda (k v) (hash-table-set! h k v)) keys vals) + h)) + +;;;; ── tree utilities ───────────────────────────────────────────────────── + +(define (tree-map f tree) + (if (pair? tree) + (cons (tree-map f (car tree)) (tree-map f (cdr tree))) + (f tree))) + +(define (tree-fold f init tree) + (if (pair? tree) + (tree-fold f (tree-fold f init (car tree)) (cdr tree)) + (f init tree))) + +(define (tree-member? x tree) + (cond ((null? tree) #f) + ((equal? x tree) #t) + ((pair? tree) (or (tree-member? x (car tree)) + (tree-member? x (cdr tree)))) + (else #f))) + +;;;; ── simple object system ─────────────────────────────────────────────── +;;; (make-object methods-alist) → an object +;;; (send obj 'method arg...) → dispatch + +(define (make-object methods) + (lambda (msg . args) + (let ((m (assoc msg methods))) + (if m + (apply (cdr m) args) + (error "unknown method" msg))))) + +(define (send obj msg . args) + (apply obj msg args)) + +;;;; ── coroutine via call/cc ─────────────────────────────────────────────── + +(define (make-generator thunk) + (let ((k #f) (done #f)) + (lambda () + (if done 'done + (call/cc + (lambda (return) + (if k + (k return) + (begin + (thunk (lambda (val) + (call/cc (lambda (next) + (set! k next) + (return val))))) + (set! done #t) + (return 'done))))))))) diff --git a/tests.py b/tests.py new file mode 100644 index 0000000..168d61a --- /dev/null +++ b/tests.py @@ -0,0 +1,1643 @@ +#!/usr/bin/env python3 +""" +tests.py — unit, integration, and functional tests for uncommonlisp. + +Run: python3 tests.py [-v] +""" +import sys, io, unittest, math, textwrap +sys.setrecursionlimit(200) # intentionally low — proves TCO works + +# ── import the interpreter ──────────────────────────────────────────────────── +from uncommonlisp import ( + Symbol, S, NIL, Pair, Proc, Macro, VOID, EOF, LispErr, + show, _tokenize, read_all, _L, _P, _truthy, _formals, _equal, + Env, _qq, leval, _call, make_global_env, PRELUDE, +) + +# ── helpers ─────────────────────────────────────────────────────────────────── + +def fresh(): + """Return a new global env with prelude loaded.""" + g = make_global_env() + for e in read_all(PRELUDE): + leval(e, g) + return g + +def run(src, env=None): + """Eval all exprs in src; return value of last one.""" + if env is None: + env = fresh() + result = VOID + for e in read_all(src): + result = leval(e, env) + return result + +def runs(src, env=None): + """Like run() but return show(result).""" + return show(run(src, env)) + +def err(src, env=None): + """Assert src raises LispErr; return the message.""" + with unittest.TestCase().assertRaises(LispErr) as ctx: + run(src, env) + return str(ctx.exception) + + +############################################################################### +# Unit tests — individual components +############################################################################### + +class TestSymbol(unittest.TestCase): + def test_interning(self): + assert S('foo') is S('foo') + assert S('foo') is not S('bar') + + def test_is_str(self): + assert isinstance(S('x'), str) + + def test_repr(self): + assert repr(S('hello')) == 'hello' + + +class TestNil(unittest.TestCase): + def test_singleton(self): + from uncommonlisp import _Nil + assert _Nil() is NIL + + def test_falsy(self): + assert not NIL + + def test_empty_iter(self): + assert list(NIL) == [] + + def test_len_zero(self): + assert len(NIL) == 0 + + def test_repr(self): + assert repr(NIL) == '()' + + +class TestPair(unittest.TestCase): + def test_basic(self): + p = Pair(1, Pair(2, NIL)) + assert p.car == 1 + assert p.cdr.car == 2 + + def test_iter_proper(self): + p = _P([1, 2, 3]) + assert list(p) == [1, 2, 3] + + def test_iter_improper_raises(self): + p = Pair(1, 2) # dotted pair + with self.assertRaises(TypeError): + list(p) + + def test_len(self): + assert len(_P([1, 2, 3])) == 3 + + def test_repr_proper(self): + assert repr(_P([1, 2])) == '(1 2)' + + def test_repr_dotted(self): + assert repr(Pair(1, 2)) == '(1 . 2)' + + def test_repr_nested(self): + assert repr(_P([_P([1, 2]), 3])) == '((1 2) 3)' + + +class TestShow(unittest.TestCase): + def test_nil(self): assert show(NIL) == '()' + def test_void(self): assert show(VOID) == '' + def test_true(self): assert show(True) == '#t' + def test_false(self): assert show(False) == '#f' + def test_int(self): assert show(42) == '42' + def test_float(self): assert show(3.14) == '3.14' + def test_inf(self): assert show(math.inf) == '+inf.0' + def test_neg_inf(self): assert show(-math.inf) == '-inf.0' + def test_nan(self): assert show(float('nan')) == '+nan.0' + def test_symbol(self): assert show(S('foo')) == 'foo' + def test_string_write(self):assert show('hi') == '"hi"' + def test_string_display(self): assert show('hi', display=True) == 'hi' + def test_string_escapes(self): assert show('a\nb') == '"a\\nb"' + def test_vector(self): assert show([1, 2]) == '#(1 2)' + def test_list(self): assert show(_P([1, 2])) == '(1 2)' + + +class TestTokenizer(unittest.TestCase): + def test_atoms(self): + assert _tokenize('foo bar') == ['foo', 'bar'] + + def test_parens(self): + assert _tokenize('(a b)') == ['(', 'a', 'b', ')'] + + def test_string(self): + assert _tokenize('"hello world"') == ['"hello world"'] + + def test_bool(self): + assert _tokenize('#t #f') == ['#t', '#f'] + + def test_comments_stripped(self): + assert _tokenize('a ; comment\nb') == ['a', 'b'] + + def test_quote_shorthands(self): + assert _tokenize("'x") == ["'", 'x'] + assert _tokenize('`x') == ['`', 'x'] + assert _tokenize(',x') == [',', 'x'] + assert _tokenize(',@x') == [',@', 'x'] + + def test_char(self): + toks = _tokenize(r'#\a #\space #\newline') + assert toks == [r'#\a', r'#\space', r'#\newline'] + + def test_numbers(self): + assert _tokenize('1 2.5 -3') == ['1', '2.5', '-3'] + + +class TestParser(unittest.TestCase): + def _r(self, src): + exprs = read_all(src) + assert len(exprs) == 1 + return exprs[0] + + def test_integer(self): + assert self._r('42') == 42 + + def test_float(self): + assert abs(self._r('3.14') - 3.14) < 1e-9 + + def test_symbol(self): + assert self._r('foo') is S('foo') + + def test_bool_true(self): + assert self._r('#t') is True + + def test_bool_false(self): + assert self._r('#f') is False + + def test_string(self): + assert self._r('"hello"') == 'hello' + + def test_string_escapes(self): + assert self._r(r'"a\nb"') == 'a\nb' + + def test_nil(self): + assert self._r('()') is NIL + + def test_list(self): + x = self._r('(1 2 3)') + assert list(x) == [1, 2, 3] + + def test_nested(self): + x = self._r('(1 (2 3))') + assert x.car == 1 + assert list(x.cdr.car) == [2, 3] + + def test_dotted(self): + x = self._r('(1 . 2)') + assert x.car == 1 + assert x.cdr == 2 + + def test_quote_shorthand(self): + x = self._r("'foo") + assert list(x) == [S('quote'), S('foo')] + + def test_quasiquote_shorthand(self): + x = self._r('`foo') + assert x.car is S('quasiquote') + + def test_unquote_shorthand(self): + x = self._r(',foo') + assert x.car is S('unquote') + + def test_unquote_splicing(self): + x = self._r(',@foo') + assert x.car is S('unquote-splicing') + + def test_char_space(self): + assert self._r(r'#\space') == ' ' + + def test_char_newline(self): + assert self._r(r'#\newline') == '\n' + + def test_char_letter(self): + assert self._r(r'#\a') == 'a' + + def test_inf(self): + assert self._r('+inf.0') == math.inf + + def test_neg_inf(self): + assert self._r('-inf.0') == -math.inf + + def test_multiple_exprs(self): + exprs = read_all('1 2 3') + assert exprs == [1, 2, 3] + + def test_unclosed_paren_raises(self): + with self.assertRaises(LispErr): + read_all('(1 2') + + def test_unexpected_close_raises(self): + with self.assertRaises(LispErr): + read_all(')') + + def test_vector_literal(self): + v = self._r('#(1 2 3)') + assert isinstance(v, list) + assert v == [1, 2, 3] + + +class TestHelpers(unittest.TestCase): + def test_L_nil(self): + assert _L(NIL) == [] + + def test_L_list(self): + assert _L(_P([1, 2, 3])) == [1, 2, 3] + + def test_L_non_list_raises(self): + with self.assertRaises(LispErr): + _L(42) + + def test_P_empty(self): + assert _P([]) is NIL + + def test_P_single(self): + r = _P([1]) + assert r.car == 1 + assert r.cdr is NIL + + def test_P_multiple(self): + r = _P([1, 2, 3]) + assert list(r) == [1, 2, 3] + + def test_truthy_false_is_false(self): + assert not _truthy(False) + + def test_truthy_nil_is_true(self): + # Scheme: only #f is false + assert _truthy(NIL) + + def test_truthy_zero_is_true(self): + assert _truthy(0) + + def test_truthy_empty_string_is_true(self): + assert _truthy('') + + def test_formals_symbol(self): + ps, rest = _formals(S('args')) + assert ps == [] and rest is S('args') + + def test_formals_nil(self): + ps, rest = _formals(NIL) + assert ps == [] and rest is None + + def test_formals_list(self): + ps, rest = _formals(_P([S('a'), S('b')])) + assert ps == [S('a'), S('b')] and rest is None + + def test_formals_dotted(self): + f = Pair(S('a'), S('rest')) + ps, rest = _formals(f) + assert ps == [S('a')] and rest is S('rest') + + def test_equal_atoms(self): + assert _equal(1, 1) + assert not _equal(1, 2) + + def test_equal_strings(self): + assert _equal('hi', 'hi') + + def test_equal_lists(self): + assert _equal(_P([1, 2]), _P([1, 2])) + assert not _equal(_P([1, 2]), _P([1, 3])) + + def test_equal_vectors(self): + assert _equal([1, 2], [1, 2]) + assert not _equal([1, 2], [1]) + + +class TestEnv(unittest.TestCase): + def test_define_lookup(self): + e = Env() + e.define(S('x'), 42) + assert e.lookup(S('x')) == 42 + + def test_undefined_raises(self): + e = Env() + with self.assertRaises(LispErr): + e.lookup(S('x')) + + def test_set(self): + e = Env() + e.define(S('x'), 1) + e.set(S('x'), 2) + assert e.lookup(S('x')) == 2 + + def test_set_undefined_raises(self): + e = Env() + with self.assertRaises(LispErr): + e.set(S('x'), 1) + + def test_lexical_scope(self): + parent = Env() + parent.define(S('x'), 1) + child = Env(parent) + child.define(S('y'), 2) + assert child.lookup(S('x')) == 1 + assert child.lookup(S('y')) == 2 + + def test_child_shadows_parent(self): + parent = Env() + parent.define(S('x'), 1) + child = Env(parent) + child.define(S('x'), 99) + assert child.lookup(S('x')) == 99 + assert parent.lookup(S('x')) == 1 + + def test_child_extend(self): + e = Env() + c = e.child([S('a'), S('b')], None, [1, 2]) + assert c.lookup(S('a')) == 1 + assert c.lookup(S('b')) == 2 + + def test_child_rest(self): + e = Env() + c = e.child([S('a')], S('rest'), [1, 2, 3]) + assert c.lookup(S('a')) == 1 + assert list(c.lookup(S('rest'))) == [2, 3] + + def test_child_arity_too_few(self): + e = Env() + with self.assertRaises(LispErr): + e.child([S('a'), S('b')], None, [1]) + + def test_child_arity_too_many(self): + e = Env() + with self.assertRaises(LispErr): + e.child([S('a')], None, [1, 2]) + + +############################################################################### +# Integration tests — evaluator special forms +############################################################################### + +class TestSelfEvaluating(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_integer(self): assert run('42', self.g) == 42 + def test_float(self): assert abs(run('3.14', self.g) - 3.14) < 1e-9 + def test_string(self): assert run('"hello"', self.g) == 'hello' + def test_bool_true(self): assert run('#t', self.g) is True + def test_bool_false(self): assert run('#f', self.g) is False + def test_nil(self): assert run('()', self.g) is NIL + def test_void(self): assert run('(void)', self.g) is VOID + + +class TestQuote(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_quote_symbol(self): + assert run("(quote foo)", self.g) is S('foo') + + def test_quote_shorthand(self): + assert run("'foo", self.g) is S('foo') + + def test_quote_list(self): + r = run("'(1 2 3)", self.g) + assert list(r) == [1, 2, 3] + + def test_quote_nested(self): + r = run("'(a (b c))", self.g) + assert r.car is S('a') + + +class TestDefine(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_simple_value(self): + run('(define x 42)', self.g) + assert run('x', self.g) == 42 + + def test_function_shorthand(self): + run('(define (square x) (* x x))', self.g) + assert run('(square 5)', self.g) == 25 + + def test_sets_name(self): + run('(define (f x) x)', self.g) + p = self.g.lookup(S('f')) + assert isinstance(p, Proc) + assert p.name == 'f' + + def test_define_returns_void(self): + assert run('(define x 1)', self.g) is VOID + + def test_redefine(self): + run('(define x 1)', self.g) + run('(define x 2)', self.g) + assert run('x', self.g) == 2 + + +class TestSetBang(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_set(self): + run('(define x 1)', self.g) + run('(set! x 99)', self.g) + assert run('x', self.g) == 99 + + def test_set_undefined_raises(self): + with self.assertRaises(LispErr): + run('(set! zzz 1)', self.g) + + +class TestIf(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_true_branch(self): assert run('(if #t 1 2)', self.g) == 1 + def test_false_branch(self): assert run('(if #f 1 2)', self.g) == 2 + def test_no_else_false(self): assert run('(if #f 1)', self.g) is VOID + def test_zero_is_true(self): assert run('(if 0 1 2)', self.g) == 1 # Scheme: only #f is false + def test_nil_is_true(self): assert run("(if '() 1 2)", self.g) == 1 + def test_false_only_false(self):assert run('(if #f 1 2)', self.g) == 2 + + +class TestCond(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_first_match(self): + assert run('(cond (#t 1) (#t 2))', self.g) == 1 + + def test_second_match(self): + assert run('(cond (#f 1) (#t 2))', self.g) == 2 + + def test_else(self): + assert run('(cond (#f 1) (else 99))', self.g) == 99 + + def test_arrow(self): + assert run('(cond (1 => (lambda (x) (* x 10))))', self.g) == 10 + + def test_no_match(self): + assert run('(cond (#f 1))', self.g) is VOID + + +class TestAndOr(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_and_empty(self): assert run('(and)', self.g) is True + def test_and_true(self): assert run('(and 1 2 3)', self.g) == 3 + def test_and_short_circuit(self): + run('(define x 0)', self.g) + run('(and #f (set! x 1))', self.g) + assert run('x', self.g) == 0 + + def test_or_empty(self): assert run('(or)', self.g) is False + def test_or_false(self): assert run('(or #f #f)', self.g) is False + def test_or_first_true(self): assert run('(or 42 99)', self.g) == 42 + def test_or_short_circuit(self): + run('(define x 0)', self.g) + run('(or 1 (set! x 1))', self.g) + assert run('x', self.g) == 0 + + +class TestLambda(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_basic(self): + run('(define f (lambda (x) (* x x)))', self.g) + assert run('(f 5)', self.g) == 25 + + def test_unicode(self): + run('(define f (λ (x) (* x x)))', self.g) + assert run('(f 3)', self.g) == 9 + + def test_closure(self): + run('(define (make-adder n) (lambda (x) (+ x n)))', self.g) + run('(define add5 (make-adder 5))', self.g) + assert run('(add5 3)', self.g) == 8 + + def test_variadic(self): + run('(define (sum . args) (fold-left + 0 args))', self.g) + assert run('(sum 1 2 3 4)', self.g) == 10 + + def test_dotted_params(self): + run('(define f (lambda (x . rest) (cons x rest)))', self.g) + r = run('(f 1 2 3)', self.g) + assert r.car == 1 + assert list(r.cdr) == [2, 3] + + def test_nullary(self): + run('(define (const) 42)', self.g) + assert run('(const)', self.g) == 42 + + def test_multi_body(self): + run('(define x 0)', self.g) + run('(define (f) (set! x 1) (set! x 2) x)', self.g) + assert run('(f)', self.g) == 2 + assert run('x', self.g) == 2 + + +class TestLet(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_basic(self): + assert run('(let ((x 1) (y 2)) (+ x y))', self.g) == 3 + + def test_body_scope(self): + run('(define x 99)', self.g) + assert run('(let ((x 1)) x)', self.g) == 1 + assert run('x', self.g) == 99 + + def test_sequential_binds_not_visible(self): + # in let, bindings can't see each other + with self.assertRaises(LispErr): + run('(let ((x 1) (y x)) y)', self.g) + + def test_let_star(self): + assert run('(let* ((x 1) (y (+ x 1))) y)', self.g) == 2 + + def test_letrec(self): + assert run('(letrec ((even? (lambda (n) (if (= n 0) #t (odd? (- n 1))))) (odd? (lambda (n) (if (= n 0) #f (even? (- n 1)))))) (even? 10))', self.g) is True + + def test_named_let(self): + assert run('(let loop ((i 0) (acc 0)) (if (> i 5) acc (loop (+ i 1) (+ acc i))))', self.g) == 15 + + +class TestBegin(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_returns_last(self): + assert run('(begin 1 2 3)', self.g) == 3 + + def test_side_effects(self): + run('(define x 0)', self.g) + run('(begin (set! x 1) (set! x 2))', self.g) + assert run('x', self.g) == 2 + + def test_empty(self): + assert run('(begin)', self.g) is VOID + + +class TestWhenUnless(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_when_true(self): + run('(define x 0)', self.g) + run('(when #t (set! x 1))', self.g) + assert run('x', self.g) == 1 + + def test_when_false(self): + run('(define x 0)', self.g) + run('(when #f (set! x 1))', self.g) + assert run('x', self.g) == 0 + + def test_unless_true(self): + run('(define x 0)', self.g) + run('(unless #t (set! x 1))', self.g) + assert run('x', self.g) == 0 + + def test_unless_false(self): + run('(define x 0)', self.g) + run('(unless #f (set! x 1))', self.g) + assert run('x', self.g) == 1 + + +class TestDo(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_sum(self): + assert run('(do ((i 1 (+ i 1)) (s 0 (+ s i))) ((> i 10) s))', self.g) == 55 + + def test_no_result(self): + assert run('(do ((i 0 (+ i 1))) ((= i 3)))', self.g) is VOID + + def test_vector_fill(self): + run('(define v (make-vector 3 0))', self.g) + run('(do ((i 0 (+ i 1))) ((= i 3)) (vector-set! v i (* i i)))', self.g) + assert run('(vector->list v)', self.g).__class__ is Pair + + +class TestQuasiquote(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_basic(self): + r = run('`(1 2 3)', self.g) + assert list(r) == [1, 2, 3] + + def test_unquote(self): + run('(define x 42)', self.g) + r = run('`(a ,x b)', self.g) + assert list(r) == [S('a'), 42, S('b')] + + def test_unquote_splicing(self): + run('(define xs (quote (1 2 3)))', self.g) + r = run('`(a ,@xs b)', self.g) + assert list(r) == [S('a'), 1, 2, 3, S('b')] + + def test_nested(self): + r = run('`(a `(b ,(+ 1 2)))', self.g) + assert r.car is S('a') + + def test_nested_unquote(self): + run('(define x 5)', self.g) + r = run('`(a ,x)', self.g) + assert list(r) == [S('a'), 5] + + +class TestApply(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_basic(self): + assert run("(apply + '(1 2 3))", self.g) == 6 + + def test_pre_args(self): + assert run("(apply + 1 2 '(3 4))", self.g) == 10 + + def test_lambda(self): + assert run("(apply (lambda (x y) (* x y)) '(3 4))", self.g) == 12 + + +class TestCallCC(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_escape(self): + # escape from deep recursion + r = run(''' + (call/cc (lambda (k) + (k 42) + 99)) + ''', self.g) + assert r == 42 + + def test_no_escape(self): + r = run('(call/cc (lambda (k) (+ 1 2)))', self.g) + assert r == 3 + + def test_early_return(self): + r = run(''' + (define (search lst pred) + (call/cc (lambda (return) + (for-each (lambda (x) (when (pred x) (return x))) lst) + #f))) + (search (quote (1 2 3 4 5)) even?) + ''', self.g) + assert r == 2 + + +class TestValues(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_single_value(self): + assert run('(values 42)', self.g) == 42 + + def test_call_with_values(self): + r = run('(call-with-values (lambda () (values 1 2 3)) +)', self.g) + assert r == 6 + + +class TestError(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_error_raises(self): + with self.assertRaises(LispErr) as ctx: + run('(error "oops")', self.g) + assert 'oops' in str(ctx.exception) + + def test_error_with_irritants(self): + with self.assertRaises(LispErr) as ctx: + run('(error "bad value" 42)', self.g) + msg = str(ctx.exception) + assert 'bad value' in msg and '42' in msg + + def test_undefined_raises(self): + with self.assertRaises(LispErr): + run('undefined-variable', self.g) + + +############################################################################### +# Integration tests — built-in procedures +############################################################################### + +class TestArithmetic(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_add(self): assert run('(+ 1 2 3)', self.g) == 6 + def test_add_empty(self): assert run('(+)', self.g) == 0 + def test_sub(self): assert run('(- 10 3 2)', self.g) == 5 + def test_sub_negate(self): assert run('(- 5)', self.g) == -5 + def test_mul(self): assert run('(* 2 3 4)', self.g) == 24 + def test_mul_empty(self): assert run('(*)', self.g) == 1 + def test_div(self): assert abs(run('(/ 10 2)', self.g) - 5.0) < 1e-9 + def test_div_single(self): assert abs(run('(/ 4)', self.g) - 0.25) < 1e-9 + def test_quotient(self): assert run('(quotient 10 3)', self.g) == 3 + def test_remainder(self): assert run('(remainder 10 3)', self.g) == 1 + def test_modulo(self): assert run('(modulo -7 3)', self.g) == 2 + def test_expt(self): assert run('(expt 2 10)', self.g) == 1024 + def test_abs_pos(self): assert run('(abs 5)', self.g) == 5 + def test_abs_neg(self): assert run('(abs -5)', self.g) == 5 + def test_floor(self): assert run('(floor 3.7)', self.g) == 3 + def test_ceiling(self): assert run('(ceiling 3.2)', self.g) == 4 + def test_round(self): assert run('(round 3.5)', self.g) == 4 + def test_truncate(self): assert run('(truncate -3.7)', self.g) == -3 + def test_min(self): assert run('(min 3 1 2)', self.g) == 1 + def test_max(self): assert run('(max 3 1 2)', self.g) == 3 + def test_gcd(self): assert run('(gcd 12 8)', self.g) == 4 + def test_lcm(self): assert run('(lcm 4 6)', self.g) == 12 + def test_sqrt(self): assert abs(run('(sqrt 9)', self.g) - 3.0) < 1e-9 + def test_exact(self): assert run('(exact 3.0)', self.g) == 3 + def test_inexact(self): assert isinstance(run('(inexact 3)', self.g), float) + def test_number_to_string(self): assert run('(number->string 255 16)', self.g) == 'ff' + def test_inf(self): assert run('(infinite? +inf.0)', self.g) is True + def test_nan(self): assert run('(nan? +nan.0)', self.g) is True + + +class TestNumericPredicates(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_eq(self): assert run('(= 1 1)', self.g) is True + def test_lt(self): assert run('(< 1 2 3)', self.g) is True + def test_gt(self): assert run('(> 3 2 1)', self.g) is True + def test_le(self): assert run('(<= 1 1 2)', self.g) is True + def test_ge(self): assert run('(>= 3 3 2)', self.g) is True + def test_zero(self): assert run('(zero? 0)', self.g) is True + def test_pos(self): assert run('(positive? 1)', self.g) is True + def test_neg(self): assert run('(negative? -1)', self.g) is True + def test_odd(self): assert run('(odd? 3)', self.g) is True + def test_even(self): assert run('(even? 4)', self.g) is True + + +class TestBoolean(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_not_false(self): assert run('(not #f)', self.g) is True + def test_not_true(self): assert run('(not #t)', self.g) is False + def test_not_zero(self): assert run('(not 0)', self.g) is False # 0 is truthy + def test_boolean_pred(self):assert run('(boolean? #t)', self.g) is True + def test_boolean_not_num(self):assert run('(boolean? 1)', self.g) is False + + +class TestPairsList(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_cons(self): assert runs('(cons 1 2)', self.g) == '(1 . 2)' + def test_cons_list(self): assert runs("(cons 1 '(2 3))", self.g) == '(1 2 3)' + def test_car(self): assert run("(car '(1 2))", self.g) == 1 + def test_cdr(self): assert runs("(cdr '(1 2 3))", self.g) == '(2 3)' + def test_list(self): assert runs('(list 1 2 3)', self.g) == '(1 2 3)' + def test_list_star(self): assert runs("(list* 1 2 '(3 4))", self.g) == '(1 2 3 4)' + def test_null_nil(self): assert run("(null? '())", self.g) is True + def test_null_pair(self): assert run("(null? '(1))", self.g) is False + def test_pair_pair(self): assert run("(pair? '(1))", self.g) is True + def test_pair_nil(self): assert run("(pair? '())", self.g) is False + def test_length(self): assert run("(length '(1 2 3))", self.g) == 3 + def test_append(self): assert runs("(append '(1 2) '(3 4))", self.g) == '(1 2 3 4)' + def test_append_empty(self):assert runs("(append '() '(1 2))", self.g) == '(1 2)' + def test_reverse(self): assert runs("(reverse '(1 2 3))", self.g) == '(3 2 1)' + def test_list_ref(self): assert run("(list-ref '(a b c) 1)", self.g) is S('b') + def test_list_tail(self): assert runs("(list-tail '(a b c) 1)", self.g) == '(b c)' + def test_iota(self): assert runs('(iota 5)', self.g) == '(0 1 2 3 4)' + def test_iota_start(self): assert runs('(iota 3 1)', self.g) == '(1 2 3)' + def test_iota_step(self): assert runs('(iota 3 0 2)', self.g) == '(0 2 4)' + def test_cadr(self): assert run("(cadr '(1 2 3))", self.g) == 2 + def test_caddr(self): assert run("(caddr '(1 2 3))", self.g) == 3 + def test_set_car(self): + run("(define p (list 1 2))", self.g) + run("(set-car! p 99)", self.g) + assert run("(car p)", self.g) == 99 + def test_set_cdr(self): + run("(define p (list 1 2))", self.g) + run("(set-cdr! p '(99))", self.g) + assert run("(cadr p)", self.g) == 99 + + +class TestMemberAssoc(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_memq_found(self): + r = run("(memq 'b '(a b c))", self.g) + assert list(r) == [S('b'), S('c')] + + def test_memq_missing(self): + assert run("(memq 'z '(a b c))", self.g) is False + + def test_member_equal(self): + r = run("(member '(2) '((1) (2) (3)))", self.g) + assert r.car.car == 2 + + def test_assq_found(self): + r = run("(assq 'b '((a 1) (b 2) (c 3)))", self.g) + assert list(r) == [S('b'), 2] + + def test_assq_missing(self): + assert run("(assq 'z '((a 1)))", self.g) is False + + def test_assoc_equal(self): + r = run("(assoc '(1) '(((1) found) ((2) no)))", self.g) + assert r.cdr.car is S('found') + + +class TestHigherOrder(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_map(self): + assert runs("(map (lambda (x) (* x x)) '(1 2 3 4))", self.g) == '(1 4 9 16)' + + def test_map_multi(self): + assert runs("(map + '(1 2 3) '(4 5 6))", self.g) == '(5 7 9)' + + def test_filter(self): + assert runs("(filter odd? '(1 2 3 4 5))", self.g) == '(1 3 5)' + + def test_fold_left(self): + assert run("(fold-left + 0 '(1 2 3 4 5))", self.g) == 15 + + def test_fold_right(self): + assert runs("(fold-right cons '() '(1 2 3))", self.g) == '(1 2 3)' + + def test_for_each_side_effects(self): + run('(define acc (quote ()))', self.g) + run("(for-each (lambda (x) (set! acc (cons x acc))) '(1 2 3))", self.g) + assert runs('acc', self.g) == '(3 2 1)' + + def test_any_found(self): + assert run("(any even? '(1 3 4 5))", self.g) == 4 + + def test_any_none(self): + assert run("(any even? '(1 3 5))", self.g) is False + + def test_every_true(self): + assert run("(every odd? '(1 3 5))", self.g) is True + + def test_every_false(self): + assert run("(every odd? '(1 2 3))", self.g) is False + + def test_count(self): + assert run("(count even? '(1 2 3 4 5 6))", self.g) == 3 + + def test_flat_map(self): + assert runs("(flat-map (lambda (x) (list x (* x x))) '(1 2 3))", self.g) == '(1 1 2 4 3 9)' + + def test_sort(self): + assert runs("(sort '(3 1 4 1 5 9 2 6))", self.g) == '(1 1 2 3 4 5 6 9)' + + def test_sort_by(self): + assert runs("(sort-by car '((3 a) (1 b) (2 c)))", self.g) == '((1 b) (2 c) (3 a))' + + def test_partition(self): + r = run("(partition even? '(1 2 3 4 5))", self.g) + evens, odds = list(r) + assert list(evens) == [2, 4] + assert list(odds) == [1, 3, 5] + + def test_find(self): + assert run("(find even? '(1 3 4 5))", self.g) == 4 + assert run("(find even? '(1 3 5))", self.g) is False + + def test_take(self): + assert runs("(take '(1 2 3 4 5) 3)", self.g) == '(1 2 3)' + + def test_drop(self): + assert runs("(drop '(1 2 3 4 5) 3)", self.g) == '(4 5)' + + def test_zip(self): + assert runs("(zip '(1 2 3) '(a b c))", self.g) == '((1 a) (2 b) (3 c))' + + +class TestStrings(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_length(self): assert run('(string-length "hello")', self.g) == 5 + def test_ref(self): assert run('(string-ref "hello" 1)', self.g) == 'e' + def test_substring(self): assert run('(substring "hello" 1 3)', self.g) == 'el' + def test_append(self): assert run('(string-append "foo" "bar")', self.g) == 'foobar' + def test_upcase(self): assert run('(string-upcase "hello")', self.g) == 'HELLO' + def test_downcase(self): assert run('(string-downcase "HELLO")', self.g) == 'hello' + def test_to_list(self): assert runs('(string->list "abc")', self.g) == '("a" "b" "c")' + def test_from_list(self): assert run("(list->string '(#\\h #\\i))", self.g) == 'hi' + def test_to_symbol(self): assert run('(string->symbol "foo")', self.g) is S('foo') + def test_from_symbol(self): assert run("(symbol->string 'foo)", self.g) == 'foo' + def test_contains(self): assert run('(string-contains "hello world" "world")', self.g) is True + def test_split(self): assert runs('(string-split "a,b,c" ",")', self.g) == '("a" "b" "c")' + def test_join(self): assert run('(string-join (list "a" "b" "c") "-")', self.g) == 'a-b-c' + def test_trim(self): assert run('(string-trim " hi ")', self.g) == 'hi' + def test_replace(self): assert run('(string-replace "hello" "l" "r")', self.g) == 'herro' + def test_number_to_string(self):assert run('(string->number "42")', self.g) == 42 + def test_string_eq(self): assert run('(string=? "foo" "foo")', self.g) is True + def test_string_lt(self): assert run('(stringchar 65)', self.g) == 'A' + def test_char_to_int(self): assert run(r'(char->integer #\A)', self.g) == 65 + def test_alpha(self): assert run(r'(char-alphabetic? #\a)', self.g) is True + def test_numeric(self): assert run(r'(char-numeric? #\5)', self.g) is True + def test_upcase(self): assert run(r'(char-upcase #\a)', self.g) == 'A' + def test_downcase(self): assert run(r'(char-downcase #\A)', self.g) == 'a' + def test_eq(self): assert run(r'(char=? #\a #\a)', self.g) is True + + +class TestVectors(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_make(self): + run('(define v (make-vector 3 0))', self.g) + assert run('(vector-length v)', self.g) == 3 + + def test_ref_set(self): + run('(define v (vector 10 20 30))', self.g) + assert run('(vector-ref v 1)', self.g) == 20 + run('(vector-set! v 1 99)', self.g) + assert run('(vector-ref v 1)', self.g) == 99 + + def test_vector_pred(self): + assert run('(vector? (vector 1 2))', self.g) is True + assert run("(vector? '(1 2))", self.g) is False + + def test_list_roundtrip(self): + assert runs('(vector->list (list->vector (quote (1 2 3))))', self.g) == '(1 2 3)' + + +class TestHashTables(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_set_ref(self): + run('(define h (make-hash-table))', self.g) + run("(hash-table-set! h 'key 42)", self.g) + assert run("(hash-table-ref h 'key)", self.g) == 42 + + def test_ref_missing_default(self): + run('(define h (make-hash-table))', self.g) + assert run("(hash-table-ref/default h 'x 0)", self.g) == 0 + + def test_exists(self): + run('(define h (make-hash-table))', self.g) + run("(hash-table-set! h 'a 1)", self.g) + assert run("(hash-table-exists? h 'a)", self.g) is True + assert run("(hash-table-exists? h 'z)", self.g) is False + + def test_delete(self): + run('(define h (make-hash-table))', self.g) + run("(hash-table-set! h 'a 1)", self.g) + run("(hash-table-delete! h 'a)", self.g) + assert run("(hash-table-exists? h 'a)", self.g) is False + + def test_size(self): + run('(define h (make-hash-table))', self.g) + run("(hash-table-set! h 'a 1)", self.g) + run("(hash-table-set! h 'b 2)", self.g) + assert run('(hash-table-size h)', self.g) == 2 + + def test_keys_values(self): + run('(define h (make-hash-table))', self.g) + run("(hash-table-set! h 'a 1)", self.g) + run("(hash-table-set! h 'b 2)", self.g) + keys = sorted(list(run('(hash-table-keys h)', self.g))) + assert keys == [S('a'), S('b')] + + +class TestEquality(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_eq_symbols(self): assert run("(eq? 'a 'a)", self.g) is True + def test_eq_sym_diff(self): assert run("(eq? 'a 'b)", self.g) is False + def test_eq_ints(self): assert run('(eq? 1 1)', self.g) is True + def test_eqv(self): assert run('(eqv? 3.14 3.14)', self.g) is True + def test_equal_lists(self): assert run("(equal? '(1 2 3) '(1 2 3))", self.g) is True + def test_equal_diff(self): assert run("(equal? '(1 2) '(1 3))", self.g) is False + def test_equal_nested(self):assert run("(equal? '(1 (2 3)) '(1 (2 3)))", self.g) is True + def test_equal_vectors(self):assert run('(equal? (vector 1 2) (vector 1 2))', self.g) is True + + +class TestMacros(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_define_macro(self): + run('(define-macro (my-if test then else) `(cond (,test ,then) (else ,else)))', self.g) + assert run('(my-if #t 1 2)', self.g) == 1 + assert run('(my-if #f 1 2)', self.g) == 2 + + def test_macro_with_rest(self): + run('(define-macro (my-begin . body) `(begin ,@body))', self.g) + assert run('(my-begin 1 2 3)', self.g) == 3 + + def test_macro_generates_define(self): + run('(define-macro (def-const name val) `(define ,name ,val))', self.g) + run('(def-const pi 3.14)', self.g) + assert run('pi', self.g) == 3.14 + + def test_define_macro_shorthand(self): + run('(define-macro (swap! a b) (let ((t (gensym))) `(let ((,t ,a)) (set! ,a ,b) (set! ,b ,t))))', self.g) + run('(define x 1)', self.g) + run('(define y 2)', self.g) + run('(swap! x y)', self.g) + assert run('x', self.g) == 2 + assert run('y', self.g) == 1 + + def test_case_macro(self): + assert run("(case 2 ((1) 'one) ((2) 'two) (else 'other))", self.g) is S('two') + assert run("(case 99 ((1) 'one) (else 'other))", self.g) is S('other') + + def test_while_macro(self): + run('(define i 0) (define s 0)', self.g) + run('(while (< i 5) (set! s (+ s i)) (set! i (+ i 1)))', self.g) + assert run('s', self.g) == 10 + + +class TestTypePredicates(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_number(self): assert run('(number? 42)', self.g) is True + def test_not_number(self): assert run('(number? "x")', self.g) is False + def test_integer(self): assert run('(integer? 3)', self.g) is True + def test_integer_float(self):assert run('(integer? 3.0)', self.g) is True + def test_string(self): assert run('(string? "x")', self.g) is True + def test_symbol(self): assert run("(symbol? 'x)", self.g) is True + def test_pair(self): assert run("(pair? '(1))", self.g) is True + def test_null(self): assert run("(null? '())", self.g) is True + def test_procedure(self): assert run('(procedure? car)', self.g) is True + def test_boolean(self): assert run('(boolean? #t)', self.g) is True + def test_list(self): assert run("(list? '(1 2))", self.g) is True + def test_list_improper(self):assert run('(list? (cons 1 2))', self.g) is False + def test_exact(self): assert run('(exact? 3)', self.g) is True + def test_inexact(self): assert run('(inexact? 3.0)', self.g) is True + + +############################################################################### +# Functional tests — end-to-end programs +############################################################################### + +class TestTCO(unittest.TestCase): + """Tail-call optimization must not blow Python's stack (limit set to 200).""" + + def setUp(self): self.g = fresh() + + def test_tail_recursion_deep(self): + r = run(''' + (define (loop n) + (if (= n 0) (quote done) (loop (- n 1)))) + (loop 100000) + ''', self.g) + assert r is S('done') + + def test_named_let_tco(self): + r = run(''' + (let go ((n 100000)) + (if (= n 0) (quote done) (go (- n 1)))) + ''', self.g) + assert r is S('done') + + def test_mutual_recursion_tco(self): + r = run(''' + (define (my-even? n) (if (= n 0) #t (my-odd? (- n 1)))) + (define (my-odd? n) (if (= n 0) #f (my-even? (- n 1)))) + (my-even? 10000) + ''', self.g) + assert r is True + + def test_accumulator_pattern(self): + r = run(''' + (define (sum-to n) + (let loop ((i n) (acc 0)) + (if (= i 0) acc (loop (- i 1) (+ acc i))))) + (sum-to 10000) + ''', self.g) + assert r == 50005000 + + +class TestClosures(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_counter(self): + r = run(''' + (define (make-counter) + (let ((n 0)) + (lambda () + (set! n (+ n 1)) + n))) + (define c (make-counter)) + (list (c) (c) (c)) + ''', self.g) + assert list(r) == [1, 2, 3] + + def test_adder_factory(self): + r = run(''' + (define (make-adder n) (lambda (x) (+ x n))) + (define add3 (make-adder 3)) + (define add7 (make-adder 7)) + (list (add3 10) (add7 10)) + ''', self.g) + assert list(r) == [13, 17] + + def test_closure_over_mutation(self): + r = run(''' + (define (make-acc) + (let ((total 0)) + (lambda (x) + (set! total (+ total x)) + total))) + (define acc (make-acc)) + (list (acc 10) (acc 20) (acc 5)) + ''', self.g) + assert list(r) == [10, 30, 35] + + def test_shared_closure_state(self): + r = run(''' + (define (make-bank-account balance) + (define (withdraw amount) + (if (>= balance amount) + (begin (set! balance (- balance amount)) balance) + (error "insufficient funds"))) + (define (deposit amount) + (set! balance (+ balance amount)) + balance) + (lambda (msg . args) + (cond ((eq? msg (quote withdraw)) (apply withdraw args)) + ((eq? msg (quote deposit)) (apply deposit args)) + ((eq? msg (quote balance)) balance) + (else (error "unknown message" msg))))) + (define acct (make-bank-account 100)) + (list (acct (quote withdraw) 30) + (acct (quote deposit) 50) + (acct (quote balance))) + ''', self.g) + assert list(r) == [70, 120, 120] + + +class TestRecursion(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_fibonacci(self): + r = run(''' + (define (fib n) + (let loop ((a 0) (b 1) (i 0)) + (if (= i n) a (loop b (+ a b) (+ i 1))))) + (map fib (iota 10)) + ''', self.g) + assert list(r) == [0, 1, 1, 2, 3, 5, 8, 13, 21, 34] + + def test_ackermann(self): + # small values — not tail-recursive + r = run(''' + (define (ack m n) + (cond ((= m 0) (+ n 1)) + ((= n 0) (ack (- m 1) 1)) + (else (ack (- m 1) (ack m (- n 1)))))) + (ack 3 3) + ''', self.g) + assert r == 61 + + def test_flatten_recursive(self): + r = run(''' + (define (my-flatten lst) + (cond ((null? lst) (quote ())) + ((pair? (car lst)) + (append (my-flatten (car lst)) (my-flatten (cdr lst)))) + (else (cons (car lst) (my-flatten (cdr lst)))))) + (my-flatten (quote (1 (2 (3 4) 5) (6)))) + ''', self.g) + assert list(r) == [1, 2, 3, 4, 5, 6] + + def test_mergesort(self): + r = run(''' + (define (merge a b) + (cond ((null? a) b) + ((null? b) a) + ((< (car a) (car b)) (cons (car a) (merge (cdr a) b))) + (else (cons (car b) (merge a (cdr b)))))) + + (define (split lst) + (let loop ((l lst) (a (quote ())) (b (quote ()))) + (if (null? l) (list a b) + (loop (cdr l) b (cons (car l) a))))) + + (define (mergesort lst) + (if (or (null? lst) (null? (cdr lst))) + lst + (let ((halves (split lst))) + (merge (mergesort (car halves)) + (mergesort (cadr halves)))))) + + (mergesort (quote (5 3 8 1 9 2 7 4 6))) + ''', self.g) + assert list(r) == [1, 2, 3, 4, 5, 6, 7, 8, 9] + + +class TestDataStructures(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_association_list(self): + r = run(''' + (define db (quote ((alice . 30) (bob . 25) (carol . 35)))) + (define (lookup name) + (let ((entry (assq name db))) + (if entry (cdr entry) #f))) + (list (lookup (quote alice)) (lookup (quote bob)) (lookup (quote dave))) + ''', self.g) + assert list(r) == [30, 25, False] + + def test_stack_via_list(self): + r = run(''' + (define stack (quote ())) + (define (push! x) (set! stack (cons x stack))) + (define (pop!) + (if (null? stack) (error "empty stack") + (let ((top (car stack))) + (set! stack (cdr stack)) + top))) + (push! 1) (push! 2) (push! 3) + (list (pop!) (pop!) (pop!)) + ''', self.g) + assert list(r) == [3, 2, 1] + + def test_record_type(self): + r = run(''' + (define-record-type point + (make-point x y) + point? + (x point-x) + (y point-y set-y!)) + (define p (make-point 3 4)) + (set-y! p 10) + (list (point? p) (point-x p) (point-y p) (point? 42)) + ''', self.g) + vals = list(r) + assert vals[0] is True + assert vals[1] == 3 + assert vals[2] == 10 + assert vals[3] is False + + def test_hash_frequency_count(self): + r = run(''' + (define (frequencies lst) + (let ((h (make-hash-table))) + (for-each (lambda (x) + (hash-table-set! h x (+ 1 (hash-table-ref/default h x 0)))) + lst) + h)) + (define h (frequencies (quote (a b a c b a)))) + (list (hash-table-ref h (quote a)) + (hash-table-ref h (quote b)) + (hash-table-ref h (quote c))) + ''', self.g) + assert list(r) == [3, 2, 1] + + +class TestHigherOrderPrograms(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_church_numerals(self): + r = run(''' + (define zero (lambda (f) (lambda (x) x))) + (define succ (lambda (n) (lambda (f) (lambda (x) (f ((n f) x)))))) + (define church->int (lambda (n) ((n (lambda (x) (+ x 1))) 0))) + (define one (succ zero)) + (define two (succ one)) + (define three (succ two)) + (church->int three) + ''', self.g) + assert r == 3 + + def test_y_combinator(self): + r = run(''' + (define Y + (lambda (f) + ((lambda (x) (f (lambda (v) ((x x) v)))) + (lambda (x) (f (lambda (v) ((x x) v))))))) + (define factorial + (Y (lambda (fact) + (lambda (n) + (if (<= n 1) 1 (* n (fact (- n 1)))))))) + (factorial 10) + ''', self.g) + assert r == 3628800 + + def test_continuation_based_iteration(self): + r = run(''' + (define (find-first pred lst) + (call/cc + (lambda (return) + (for-each (lambda (x) (when (pred x) (return x))) lst) + #f))) + (list (find-first even? (quote (1 3 4 5 6))) + (find-first even? (quote (1 3 5)))) + ''', self.g) + assert list(r) == [4, False] + + def test_generator_via_closures(self): + r = run(''' + (define (range-generator start end) + (let ((i start)) + (lambda () + (if (>= i end) (quote done) + (let ((v i)) + (set! i (+ i 1)) + v))))) + (define gen (range-generator 0 5)) + (list (gen) (gen) (gen) (gen) (gen) (gen)) + ''', self.g) + assert list(r) == [0, 1, 2, 3, 4, S('done')] + + +class TestMacroPrograms(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_anaphoric_if(self): + run(''' + (define-macro (aif test then else) + `(let ((it ,test)) + (if it ,then ,else))) + ''', self.g) + assert run('(aif (+ 1 2) (* it 10) #f)', self.g) == 30 + assert run('(aif #f (* it 10) (quote nothing))', self.g) is S('nothing') + + def test_pipeline_macro(self): + run(''' + (define-macro (-> val . fns) + (if (null? fns) val + `(-> (,(car fns) ,val) ,@(cdr fns)))) + ''', self.g) + r = run("(-> 5 (lambda (x) (* x 2)) (lambda (x) (+ x 1)))", self.g) + assert r == 11 + + def test_with_gensym(self): + run(''' + (define-macro (once-only var . body) + (let ((g (gensym))) + `(let ((,g ,var)) + ,@(map (lambda (e) (list (quote quote) e)) (quote ())) + (let ((,var ,g)) ,@body)))) + ''', self.g) + # Just verify macro expands without error + run('(once-only 42)', self.g) + + def test_repeat_macro(self): + run(''' + (define-macro (repeat n . body) + (let ((i (gensym))) + `(do ((,i 0 (+ ,i 1))) + ((= ,i ,n)) + ,@body))) + ''', self.g) + run('(define x 0)', self.g) + run('(repeat 5 (set! x (+ x 1)))', self.g) + assert run('x', self.g) == 5 + + +class TestPrelude(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_1plus(self): assert run('(1+ 5)', self.g) == 6 + def test_1minus(self): assert run('(1- 5)', self.g) == 4 + def test_add1(self): assert run('(add1 9)', self.g) == 10 + def test_sub1(self): assert run('(sub1 9)', self.g) == 8 + def test_square(self): assert run('(square 7)', self.g) == 49 + def test_cube(self): assert run('(cube 3)', self.g) == 27 + def test_atom(self): + assert run('(atom? 42)', self.g) is True + assert run("(atom? '(1 2))", self.g) is False + def test_range_1(self): + assert runs('(range 5)', self.g) == '(0 1 2 3 4)' + def test_range_2(self): + assert runs('(range 2 5)', self.g) == '(2 3 4)' + def test_range_3(self): + assert runs('(range 0 10 2)', self.g) == '(0 2 4 6 8)' + def test_flatten(self): + assert runs("(flatten '(1 (2 (3 4) 5)))", self.g) == '(1 2 3 4 5)' + def test_compose_prelude(self): + run('(define inc-then-double (compose (lambda (x) (* x 2)) (lambda (x) (+ x 1))))', self.g) + assert run('(inc-then-double 4)', self.g) == 10 + def test_string_map(self): + assert run('(string-map char-upcase "hello")', self.g) == 'HELLO' + + +class TestOutputCapture(unittest.TestCase): + """Tests that verify display/write output.""" + + def setUp(self): self.g = fresh() + + def _capture(self, src): + buf = io.StringIO() + old = sys.stdout; sys.stdout = buf + try: run(src, self.g) + finally: sys.stdout = old + return buf.getvalue() + + def test_display_string(self): + out = self._capture('(display "hello")') + assert out == 'hello' + + def test_display_number(self): + out = self._capture('(display 42)') + assert out == '42' + + def test_write_string(self): + out = self._capture('(write "hello")') + assert out == '"hello"' + + def test_newline(self): + out = self._capture('(newline)') + assert out == '\n' + + def test_display_boolean(self): + out = self._capture('(display #t)') + assert out == '#t' + + def test_display_list(self): + out = self._capture("(display '(1 2 3))") + assert out == '(1 2 3)' + + def test_format_output(self): + out = self._capture('(display (format "x=~a" 42))') + assert out == 'x=42' + + +class TestLoadFile(unittest.TestCase): + """Tests for loading .lsp files.""" + + def setUp(self): + import tempfile, os + self.g = fresh() + self.tmpdir = tempfile.mkdtemp() + + def tearDown(self): + import shutil + shutil.rmtree(self.tmpdir) + + def _write(self, name, content): + import os + path = os.path.join(self.tmpdir, name) + with open(path, 'w') as f: f.write(textwrap.dedent(content)) + return path + + def test_load_simple(self): + path = self._write('simple.lsp', '(define x 42)') + run(f'(load "{path}")', self.g) + assert run('x', self.g) == 42 + + def test_load_defines_function(self): + path = self._write('fn.lsp', ''' + (define (double x) (* x 2)) + ''') + run(f'(load "{path}")', self.g) + assert run('(double 7)', self.g) == 14 + + def test_load_multiple_forms(self): + path = self._write('multi.lsp', ''' + (define a 1) + (define b 2) + (define c (+ a b)) + ''') + run(f'(load "{path}")', self.g) + assert run('c', self.g) == 3 + + +class TestCommandLine(unittest.TestCase): + """End-to-end tests via subprocess.""" + + def _run(self, *args, input_text=None): + import subprocess + result = subprocess.run( + [sys.executable, 'uncommonlisp.py'] + list(args), + capture_output=True, text=True, input=input_text, + cwd='/home/fox/git/uncommonlisp' + ) + return result.stdout.strip(), result.stderr.strip(), result.returncode + + def test_eval_flag(self): + out, err, code = self._run('-e', '(display (+ 1 2))') + assert code == 0 + assert out == '3' + + def test_eval_string(self): + out, err, code = self._run('-e', '(display "hi")') + assert out == 'hi' + + def test_eval_multiple(self): + out, err, code = self._run('-e', '(display (map (lambda (x) (* x x)) (iota 4)))') + assert out == '(0 1 4 9)' + + def test_error_exit_code(self): + _, _, code = self._run('-e', '(error "boom")') + assert code != 0 + + def test_script_file(self): + import tempfile, os + with tempfile.NamedTemporaryFile(mode='w', suffix='.lsp', delete=False) as f: + f.write('(display (* 6 7))\n') + path = f.name + try: + out, err, code = self._run(path) + assert code == 0 + assert out == '42' + finally: + os.unlink(path) + + def test_missing_file(self): + _, err, code = self._run('/nonexistent/file.lsp') + assert code != 0 + + +############################################################################### +# Edge cases & regression tests +############################################################################### + +class TestEdgeCases(unittest.TestCase): + def setUp(self): self.g = fresh() + + def test_deep_nesting(self): + r = run('(car (cdr (cdr (list 1 2 3 4))))', self.g) + assert r == 3 + + def test_empty_begin(self): + assert run('(begin)', self.g) is VOID + + def test_let_no_bindings(self): + assert run('(let () 42)', self.g) == 42 + + def test_variadic_no_rest(self): + run('(define (f x . rest) rest)', self.g) + assert run('(f 1)', self.g) is NIL + + def test_recursive_data(self): + # circular-ish through explicit construction + r = run("(define x (list 1 2 3)) (length x)", self.g) + assert r == 3 + + def test_boolean_not_number(self): + with self.assertRaises(LispErr): + run('(+ #t 1)', self.g) + + def test_wrong_arity_raises(self): + run('(define (f x y) (+ x y))', self.g) + with self.assertRaises(LispErr): + run('(f 1)', self.g) + + def test_car_nil_raises(self): + with self.assertRaises(LispErr): + run("(car '())", self.g) + + def test_cdr_nil_raises(self): + with self.assertRaises(LispErr): + run("(cdr '())", self.g) + + def test_symbol_interning_across_parses(self): + a = read_all("'foo")[0].cdr.car + b = read_all("'foo")[0].cdr.car + assert a is b + + def test_number_types(self): + assert isinstance(run('1', self.g), int) + assert isinstance(run('1.0', self.g), float) + + def test_zero_division_raises(self): + with self.assertRaises((ZeroDivisionError, LispErr)): + run('(/ 1 0)', self.g) + + def test_gensym_unique(self): + a = run('(gensym)', self.g) + b = run('(gensym)', self.g) + assert a != b + assert isinstance(a, Symbol) + + def test_multiline_parse(self): + r = run(''' + (define (add a b) + (+ a b)) + (add 3 4) + ''', self.g) + assert r == 7 + + def test_mutual_define_in_begin(self): + r = run(''' + (define (even? n) (if (= n 0) #t (odd? (- n 1)))) + (define (odd? n) (if (= n 0) #f (even? (- n 1)))) + (list (even? 4) (odd? 5)) + ''', self.g) + assert list(r) == [True, True] + + def test_higher_order_returns_proc(self): + run('(define (make-adder n) (lambda (x) (+ x n)))', self.g) + p = run('(make-adder 5)', self.g) + assert isinstance(p, Proc) + + def test_string_with_escaped_quote(self): + r = run(r'(string-length "a\"b")', self.g) + assert r == 3 + + def test_write_round_trip(self): + r = show(run('(list 1 "two" (quote three) #t #f)', self.g)) + assert r == '(1 "two" three #t #f)' + + +############################################################################### +# Main +############################################################################### + +if __name__ == '__main__': + unittest.main(verbosity=2 if '-v' in sys.argv else 1) diff --git a/uncommonlisp.py b/uncommonlisp.py new file mode 100644 index 0000000..10a3548 --- /dev/null +++ b/uncommonlisp.py @@ -0,0 +1,1523 @@ +#!/usr/bin/env python3 +""" +uncommonlisp — a Lisp in one Python file. +Usage: python3 uncommonlisp.py [script.lsp] # run a file + python3 uncommonlisp.py # interactive REPL + python3 uncommonlisp.py -e '(+ 1 2)' # eval expression +""" +import sys, re, math, itertools +try: import readline +except ImportError: pass + +############################################################################### +# Types +############################################################################### + +class Symbol(str): + """Interned symbol — identity comparison works.""" + _t: dict = {} + def __new__(cls, s): + if s not in cls._t: cls._t[s] = str.__new__(cls, s) + return cls._t[s] + def __repr__(self): return str(self) + +S = Symbol # short alias + +class _Nil: + _i = None + def __new__(cls): + if cls._i is None: cls._i = super().__new__(cls) + return cls._i + def __repr__(self): return '()' + def __bool__(self): return False + def __iter__(self): return iter(()) + def __len__(self): return 0 + +NIL = _Nil() + +class Pair: + __slots__ = ('car', 'cdr') + def __init__(self, a, d): self.car = a; self.cdr = d + def __iter__(self): + n = self + while isinstance(n, Pair): yield n.car; n = n.cdr + if n is not NIL: raise TypeError('improper list') + def __len__(self): + c = 0; n = self + while isinstance(n, Pair): c += 1; n = n.cdr + return c + def __repr__(self): + parts = []; n = self + while isinstance(n, Pair): parts.append(show(n.car)); n = n.cdr + return '(' + ' '.join(parts) + ('' if n is NIL else ' . ' + show(n)) + ')' + +class Proc: + __slots__ = ('params', 'rest', 'body', 'env', 'name') + def __init__(self, params, rest, body, env, name=None): + self.params = params; self.rest = rest + self.body = body; self.env = env; self.name = name + def __repr__(self): return f'#' + +class Macro: + __slots__ = ('xfm',) + def __init__(self, xfm): self.xfm = xfm + def __repr__(self): + name = getattr(self.xfm, 'name', None) or '?' + return f'#' + +class _EllBind(list): + """Marks a binding as an ellipsis (list of matched items), not a vector.""" + pass + +class _SyntaxTransformer: + """Implements (syntax-rules (lit ...) (pattern template) ...).""" + def __init__(self, literals, rules, def_env): + self.literals = frozenset(str(x) for x in _L(literals)) + self.rules = [] + for r in _L(rules): + rl = _L(r); self.rules.append((rl[0], rl[1])) + self.def_env = def_env + + def __call__(self, args, use_env): + form = _P(args) + for pat, tmpl in self.rules: + # pat.cdr is the actual pattern (skip keyword) + b = {} + if self._match(pat.cdr if isinstance(pat, Pair) else NIL, form, b): + return self._expand(tmpl, b) + raise LispErr(f'syntax error: no matching syntax-rules pattern') + + def _pat_vars(self, pat): + if isinstance(pat, Symbol): + return {pat} if str(pat) not in self.literals and pat is not S('_') and pat is not S('...') else set() + if isinstance(pat, Pair): return self._pat_vars(pat.car) | self._pat_vars(pat.cdr) + return set() + + def _match(self, pat, form, b): + if pat is NIL: return form is NIL + if isinstance(pat, bool): return pat == form + if isinstance(pat, (int, float, str)) and not isinstance(pat, Symbol): return pat == form + if isinstance(pat, Symbol): + if str(pat) in self.literals: return isinstance(form, Symbol) and str(form) == str(pat) + if pat is S('_'): return True + b[str(pat)] = form; return True + if not isinstance(pat, Pair): return pat == form + # Ellipsis: (sub_pat ... . rest_pat) + if isinstance(pat.cdr, Pair) and pat.cdr.car is S('...'): + sub_pat = pat.car; rest_pat = pat.cdr.cdr + pvars = self._pat_vars(sub_pat) + eb = {str(v): _EllBind() for v in pvars} + # count required tail elements + n_rest = 0; rp = rest_pat + while isinstance(rp, Pair): n_rest += 1; rp = rp.cdr + items = list(form) if isinstance(form, Pair) else [] + n_ell = len(items) - n_rest + if n_ell < 0: return False + for item in items[:n_ell]: + ib = {} + if not self._match(sub_pat, item, ib): return False + for v in pvars: eb[str(v)].append(ib.get(str(v), VOID)) + b.update(eb) + rest_form = _P(items[n_ell:]) + return self._match(rest_pat, rest_form, b) + # Normal pair + if not isinstance(form, Pair): return False + return self._match(pat.car, form.car, b) and self._match(pat.cdr, form.cdr, b) + + def _ell_vars(self, tmpl, b): + """Symbols in tmpl that have _EllBind bindings.""" + result = set() + if isinstance(tmpl, Symbol): + if str(tmpl) in b and isinstance(b[str(tmpl)], _EllBind): result.add(str(tmpl)) + elif isinstance(tmpl, Pair): + result |= self._ell_vars(tmpl.car, b); result |= self._ell_vars(tmpl.cdr, b) + return result + + def _expand(self, tmpl, b): + if tmpl is NIL or isinstance(tmpl, bool) or isinstance(tmpl, (int, float)): return tmpl + if isinstance(tmpl, str) and not isinstance(tmpl, Symbol): return tmpl + if isinstance(tmpl, Symbol): + if str(tmpl) in b: + v = b[str(tmpl)] + if isinstance(v, _EllBind): raise LispErr(f'syntax-rules: {tmpl} used without ...') + return v + return tmpl + if not isinstance(tmpl, Pair): return tmpl + # Ellipsis in template: (sub_tmpl ...) + if isinstance(tmpl.cdr, Pair) and tmpl.cdr.car is S('...'): + sub_tmpl = tmpl.car; rest_tmpl = tmpl.cdr.cdr + evars = self._ell_vars(sub_tmpl, b) + if not evars: raise LispErr(f'syntax-rules: no ellipsis var in {show(sub_tmpl)}') + n = len(b[next(iter(evars))]) + expanded = [] + for i in range(n): + sb = dict(b) + for v in evars: sb[v] = b[v][i] + expanded.append(self._expand(sub_tmpl, sb)) + rest = self._expand(rest_tmpl, b) + for x in reversed(expanded): rest = Pair(x, rest) + return rest + return Pair(self._expand(tmpl.car, b), self._expand(tmpl.cdr, b)) + +class _Void: + _i = None + def __new__(cls): + if cls._i is None: cls._i = super().__new__(cls) + return cls._i + def __repr__(self): return '' + +VOID = _Void() + +class _EOF: + _i = None + def __new__(cls): + if cls._i is None: cls._i = super().__new__(cls) + return cls._i + def __repr__(self): return '#' + +EOF = _EOF() + +class LispErr(Exception): pass + +############################################################################### +# Printer +############################################################################### + +def show(x, display=False): + if x is NIL: return '()' + if x is VOID: return '' + if x is True: return '#t' + if x is False: return '#f' + if isinstance(x, Pair): return repr(x) + if isinstance(x, list): # vector + return '#(' + ' '.join(show(e) for e in x) + ')' + if isinstance(x, str): + if isinstance(x, Symbol): return str(x) + if display: return x + return ('"' + x.replace('\\', '\\\\').replace('"', '\\"') + .replace('\n', '\\n').replace('\t', '\\t') + '"') + if isinstance(x, float): + if math.isinf(x): return '+inf.0' if x > 0 else '-inf.0' + if math.isnan(x): return '+nan.0' + return repr(x) + +############################################################################### +# Tokenizer +############################################################################### + +_TOK_RE = re.compile(r''' + ;[^\n]* | # line comment + "(?:[^"\\]|\\.)*" | # string literal + ,@ | # unquote-splicing + [()\'`,] | # single-char tokens + \#[tf] | # booleans + \#\( | # vector #( + \#\\(?:space|newline|tab|return|null|escape|[^\s]) | # character + [^\s()"\'`,;]+ # atom +''', re.VERBOSE | re.IGNORECASE) + +def _tokenize(src): + return [t for t in _TOK_RE.findall(src) if not t.startswith(';')] + +############################################################################### +# Parser +############################################################################### + +_QQ = {"'": S('quote'), '`': S('quasiquote'), + ',': S('unquote'), ',@': S('unquote-splicing')} + +def _read(toks, i): + if i >= len(toks): raise LispErr('unexpected EOF') + t = toks[i]; i += 1 + if t in _QQ: + v, i = _read(toks, i) + return Pair(_QQ[t], Pair(v, NIL)), i + if t == '(': + items = []; tail = None + while True: + if i >= len(toks): raise LispErr('unclosed (') + if toks[i] == ')': i += 1; break + if toks[i] == '.': + i += 1; tail, i = _read(toks, i) + if i >= len(toks) or toks[i] != ')': raise LispErr('. without )') + i += 1; break + v, i = _read(toks, i); items.append(v) + r = NIL if tail is None else tail + for x in reversed(items): r = Pair(x, r) + return r, i + if t == '#(': # vector literal + items = [] + while True: + if i >= len(toks): raise LispErr('unclosed #(') + if toks[i] == ')': i += 1; break + v, i = _read(toks, i); items.append(v) + return items, i + if t == ')': raise LispErr('unexpected )') + return _atom(t), i + +def _atom(t): + if t == '#t' or t == '#T': return True + if t == '#f' or t == '#F': return False + if t.startswith('#\\'): + n = t[2:] + return {'space': ' ', 'newline': '\n', 'tab': '\t', + 'return': '\r', 'null': '\0', 'escape': '\x1b'}.get(n.lower(), n[0]) + if t.startswith('"'): + return (t[1:-1].replace('\\"', '"').replace('\\n', '\n') + .replace('\\t', '\t').replace('\\\\', '\\').replace('\\r', '\r')) + for conv in (int, float): + try: return conv(t) + except (ValueError, OverflowError): pass + if t == '+inf.0': return math.inf + if t == '-inf.0': return -math.inf + if t in ('+nan.0', '-nan.0'): return float('nan') + return S(t) + +def read_all(src): + toks = _tokenize(src); exprs = []; i = 0 + while i < len(toks): e, i = _read(toks, i); exprs.append(e) + return exprs + +############################################################################### +# Helpers +############################################################################### + +def _L(x): + """Lisp list → Python list (validates proper list).""" + if x is NIL: return [] + if isinstance(x, Pair): return list(x) + raise LispErr(f'not a list: {show(x)}') + +def _P(lst): + """Python list → Lisp list.""" + r = NIL + for x in reversed(lst): r = Pair(x, r) + return r + +def _truthy(x): return x is not False + +def _formals(f): + """Parse lambda formals → (params: [Symbol], rest: Symbol|None).""" + if isinstance(f, Symbol): return [], f + if f is NIL: return [], None + ps = []; n = f + while isinstance(n, Pair): + if not isinstance(n.car, Symbol): + raise LispErr(f'param must be symbol: {show(n.car)}') + ps.append(n.car); n = n.cdr + if n is NIL: return ps, None + if not isinstance(n, Symbol): raise LispErr(f'rest param must be symbol: {show(n)}') + return ps, n + +def _raise(e): raise e + +############################################################################### +# Environment +############################################################################### + +class Env: + __slots__ = ('b', 'p') + def __init__(self, parent=None): self.b = {}; self.p = parent + + def lookup(self, k): + e = self + while e: + if k in e.b: return e.b[k] + e = e.p + raise LispErr(f'undefined: {k}') + + def define(self, k, v): self.b[k] = v + + def set(self, k, v): + e = self + while e: + if k in e.b: e.b[k] = v; return + e = e.p + raise LispErr(f"set! undefined: {k}") + + def child(self, params, rest, args): + n = len(params) + if len(args) < n: + raise LispErr(f'arity: need {n}, got {len(args)}') + if rest is None and len(args) > n: + raise LispErr(f'arity: need {n}, got {len(args)}') + c = Env(self) + for p, a in zip(params, args): c.b[p] = a + if rest is not None: c.b[rest] = _P(args[n:]) + return c + +############################################################################### +# Quasiquote expander +############################################################################### + +def _qq(tmpl, env, depth=0): + if not isinstance(tmpl, Pair): return tmpl + if tmpl.car is S('quasiquote'): + return Pair(S('quasiquote'), Pair(_qq(tmpl.cdr.car, env, depth + 1), NIL)) + if tmpl.car is S('unquote'): + if depth == 0: return leval(tmpl.cdr.car, env) + return Pair(S('unquote'), Pair(_qq(tmpl.cdr.car, env, depth - 1), NIL)) + parts = []; n = tmpl + while isinstance(n, Pair): + item = n.car + if isinstance(item, Pair) and item.car is S('unquote-splicing'): + if depth == 0: + parts.extend(_L(leval(item.cdr.car, env))) + else: + parts.append(Pair(S('unquote-splicing'), + Pair(_qq(item.cdr.car, env, depth - 1), NIL))) + else: + parts.append(_qq(item, env, depth)) + n = n.cdr + tail = _qq(n, env, depth) if n is not NIL else NIL + r = tail + for p in reversed(parts): r = Pair(p, r) + return r + +############################################################################### +# Evaluator (TCO via explicit loop) +############################################################################### + +def leval(expr, env): + """Evaluate expr in env. Tail-call safe via while loop.""" + while True: + # Self-evaluating atoms + if (expr is NIL or expr is VOID or expr is True or expr is False + or isinstance(expr, (int, float, _EOF, list)) + or (isinstance(expr, str) and not isinstance(expr, Symbol))): + return expr + + # Symbol lookup + if isinstance(expr, Symbol): + return env.lookup(expr) + + if not isinstance(expr, Pair): + return expr + + head = expr.car + tail = expr.cdr # unevaluated args as Lisp list + + # ── Special forms ──────────────────────────────────────────────────── + + if head is S('quote'): + return tail.car + + if head is S('if'): + a = _L(tail) + if not 2 <= len(a) <= 3: raise LispErr('if: need 2-3 subforms') + expr = a[1] if _truthy(leval(a[0], env)) else (a[2] if len(a) == 3 else VOID) + continue + + if head is S('cond'): + result = VOID + for cl in _L(tail): + cl = _L(cl) + if not cl: raise LispErr('cond: empty clause') + if cl[0] is S('else') or _truthy(leval(cl[0], env)): + if len(cl) == 1: + result = leval(cl[0], env) if cl[0] is not S('else') else VOID + break + if len(cl) == 3 and cl[1] is S('=>'): + v = leval(cl[0], env); f = leval(cl[2], env) + if isinstance(f, Proc): + env = f.env.child(f.params, f.rest, [v]) + expr = Pair(S('begin'), _P(f.body)); break + return f([v], env) + for e in cl[1:-1]: leval(e, env) + expr = cl[-1]; break + else: + return result + continue + + if head is S('and'): + a = _L(tail) + if not a: return True + for e in a[:-1]: + v = leval(e, env) + if not _truthy(v): return False + expr = a[-1]; continue + + if head is S('or'): + a = _L(tail) + if not a: return False + for e in a[:-1]: + v = leval(e, env) + if _truthy(v): return v + expr = a[-1]; continue + + if head is S('when'): + a = _L(tail) + if _truthy(leval(a[0], env)): + for e in a[1:-1]: leval(e, env) + expr = a[-1]; continue + return VOID + + if head is S('unless'): + a = _L(tail) + if not _truthy(leval(a[0], env)): + for e in a[1:-1]: leval(e, env) + expr = a[-1]; continue + return VOID + + if head is S('begin'): + a = _L(tail) + if not a: return VOID + for e in a[:-1]: leval(e, env) + expr = a[-1]; continue + + if head is S('define'): + a = _L(tail) + if not a: raise LispErr('define: empty') + if isinstance(a[0], Pair): # (define (f x) body...) + fname = a[0].car; ps, rest = _formals(a[0].cdr) + p = Proc(ps, rest, a[1:], env, name=str(fname)) + env.define(fname, p) + else: + name = a[0] + if not isinstance(name, Symbol): raise LispErr(f'define: name must be symbol, got {show(name)}') + val = leval(a[1], env) if len(a) > 1 else VOID + if isinstance(val, Proc) and not val.name: val.name = str(name) + env.define(name, val) + return VOID + + if head is S('define-values'): + a = _L(tail); names = _L(a[0]) + vals = leval(a[1], env) + vs = list(vals) if isinstance(vals, tuple) else [vals] + for n, v in zip(names, vs): env.define(n, v) + return VOID + + if head is S('set!'): + a = _L(tail); env.set(a[0], leval(a[1], env)); return VOID + + if head is S('lambda') or head is S('λ'): + a = _L(tail) + if not a: raise LispErr('lambda: empty') + ps, rest = _formals(a[0]) + return Proc(ps, rest, a[1:], env) + + if head is S('let'): + a = _L(tail) + if not a: raise LispErr('let: empty') + if isinstance(a[0], Symbol): # named let + name = a[0]; binds = _L(a[1]); body = a[2:] + bps = [_L(b)[0] for b in binds] + bvs = [leval(_L(b)[1], env) for b in binds] + c = Env(env) + p = Proc(bps, None, body, c, name=str(name)) + c.define(name, p) + env = c.child(bps, None, bvs) + expr = Pair(S('begin'), _P(body)); continue + binds = _L(a[0]); body = a[1:] + c = Env(env) + for b in binds: + bp = _L(b); c.define(bp[0], leval(bp[1], env)) + env = c; expr = Pair(S('begin'), _P(body)); continue + + if head is S('let*'): + a = _L(tail) + c = Env(env) + for b in _L(a[0]): + bp = _L(b); c.define(bp[0], leval(bp[1], c)) + env = c; expr = Pair(S('begin'), _P(a[1:])); continue + + if head is S('letrec') or head is S('letrec*'): + a = _L(tail); binds = _L(a[0]) + c = Env(env) + for b in binds: c.define(_L(b)[0], VOID) + for b in binds: + bp = _L(b); c.set(bp[0], leval(bp[1], c)) + env = c; expr = Pair(S('begin'), _P(a[1:])); continue + + if head is S('do'): + a = _L(tail) + vcs = _L(a[0]); term = _L(a[1]); body = a[2:] + c = Env(env) + specs = [_L(vc) for vc in vcs] + for sp in specs: c.define(sp[0], leval(sp[1], env)) + steps = [sp[2] if len(sp) > 2 else sp[0] for sp in specs] + while True: + if _truthy(leval(term[0], c)): + if len(term) == 1: return VOID + for e in term[1:-1]: leval(e, c) + expr = term[-1]; env = c; break + for b in body: leval(b, c) + nvs = [leval(s, c) for s in steps] + for sp, nv in zip(specs, nvs): c.set(sp[0], nv) + continue + + if head is S('quasiquote'): + return _qq(tail.car, env) + + if head is S('define-macro') or head is S('defmacro'): + a = _L(tail) + if isinstance(a[0], Pair): # (define-macro (name params...) body...) + name = a[0].car; ps, rest = _formals(a[0].cdr) + body = a[1:] + else: # (define-macro name (params...) body...) + name = a[0]; ps, rest = _formals(a[1]) + body = a[2:] + xfm = Proc(ps, rest, body, env, name=str(name)) + env.define(name, Macro(xfm)); return VOID + + if head is S('define-syntax'): + a = _L(tail) + val = leval(a[1], env) + if isinstance(val, _SyntaxTransformer): + env.define(a[0], Macro(val)) + else: + env.define(a[0], val) + return VOID + + if head is S('let-syntax'): + a = _L(tail); body = a[1:] + c = Env(env) + for b in _L(a[0]): + bp = _L(b); c.define(bp[0], Macro(leval(bp[1], env))) + env = c; expr = Pair(S('begin'), _P(body)); continue + + if head is S('letrec-syntax'): + a = _L(tail); body = a[1:] + c = Env(env) + for b in _L(a[0]): + bp = _L(b); c.define(bp[0], Macro(leval(bp[1], c))) + env = c; expr = Pair(S('begin'), _P(body)); continue + + if head is S('syntax-rules'): + a = _L(tail) + return _SyntaxTransformer(a[0], _P(a[1:]), env) + + if head is S('values'): + vals = [leval(e, env) for e in _L(tail)] + return vals[0] if len(vals) == 1 else tuple(vals) + + if head is S('call-with-values'): + a = _L(tail) + prod = leval(a[0], env); cons_ = leval(a[1], env) + r = _call(prod, [], env) + args = list(r) if isinstance(r, tuple) else [r] + return _call(cons_, args, env) + + if head is S('call/cc') or head is S('call-with-current-continuation'): + a = _L(tail); proc = leval(a[0], env) + class Escape(Exception): + def __init__(self, v): self.v = v + def kont(args, _env): raise Escape(args[0] if args else VOID) + try: return _call(proc, [kont], env) + except Escape as e: return e.v + + if head is S('apply'): + a = _L(tail) + proc = leval(a[0], env) + pre = [leval(x, env) for x in a[1:-1]] + last = leval(a[-1], env) + args = pre + _L(last) + if isinstance(proc, Proc): + env = proc.env.child(proc.params, proc.rest, args) + expr = Pair(S('begin'), _P(proc.body)); continue + if callable(proc): return proc(args, env) + raise LispErr(f'apply: not callable: {show(proc)}') + + if head is S('eval'): + a = _L(tail); expr = leval(a[0], env); continue + + if head is S('error'): + a = _L(tail) + msg = show(leval(a[0], env), display=True) + irr = [show(leval(x, env)) for x in a[1:]] + raise LispErr(msg + (': ' + ' '.join(irr) if irr else '')) + + if head is S('load'): + a = _L(tail); _load(leval(a[0], env), env); return VOID + + if head is S('include'): + for path_expr in _L(tail): + _load(show(leval(path_expr, env), display=True), env) + return VOID + + if head is S('parameterize'): + # simplified: just bind and restore + a = _L(tail); binds = _L(a[0]); body = a[1:] + saves = [(leval(bp[0], env), _L(bp)) for bp in binds] + for param, bp in saves: + if callable(param): param([leval(bp[1], env)], env) + try: + for e in body[:-1]: leval(e, env) + return leval(body[-1], env) + finally: + for param, bp in saves: + if callable(param): param([_call(param, [], env)], env) + + if head is S('dynamic-wind'): + a = _L(tail) + before = leval(a[0], env); thunk = leval(a[1], env); after = leval(a[2], env) + _call(before, [], env) + try: r = _call(thunk, [], env) + finally: _call(after, [], env) + return r + + if head is S('with-exception-handler'): + a = _L(tail) + handler = leval(a[0], env); thunk = leval(a[1], env) + try: return _call(thunk, [], env) + except LispErr as e: return _call(handler, [str(e)], env) + except Exception as e: return _call(handler, [str(e)], env) + + if head is S('guard'): + a = _L(tail); var_clauses = _L(a[0]); body = a[1:] + var = var_clauses[0]; clauses = var_clauses[1:] + try: + for e in body[:-1]: leval(e, env) + return leval(body[-1], env) + except LispErr as exc: + c = Env(env); c.define(var, str(exc)) + for cl in clauses: + cl = _L(cl) + if cl[0] is S('else') or _truthy(leval(cl[0], c)): + for e in cl[1:-1]: leval(e, c) + return leval(cl[-1], c) + raise + + # ── Macro expansion ────────────────────────────────────────────────── + hval = leval(head, env) + if isinstance(hval, Macro): + expr = _call(hval.xfm, _L(tail), env); continue + + # ── Procedure application ──────────────────────────────────────────── + proc = hval + args = [leval(a, env) for a in _L(tail)] + + if isinstance(proc, Proc): + env = proc.env.child(proc.params, proc.rest, args) + expr = Pair(S('begin'), _P(proc.body)); continue + + if callable(proc): return proc(args, env) + + raise LispErr(f'not callable: {show(proc)}') + + +def _call(proc, args, env): + """Non-tail recursive call (for use inside builtins).""" + if isinstance(proc, Proc): + c = proc.env.child(proc.params, proc.rest, args) + for e in proc.body[:-1]: leval(e, c) + return leval(proc.body[-1], c) + if callable(proc): return proc(args, env) + raise LispErr(f'not callable: {show(proc)}') + + +def _load(path, env): + with open(path) as f: + src = f.read() + for expr in read_all(src): leval(expr, env) + +############################################################################### +# Built-ins +############################################################################### + +_gensym_ctr = itertools.count() + +def _num(x): + if isinstance(x, bool) or not isinstance(x, (int, float)): + raise LispErr(f'not a number: {show(x)}') + return x + +def _str_val(x): + if not isinstance(x, str) or isinstance(x, Symbol): + raise LispErr(f'not a string: {show(x)}') + return x + +def _sym_val(x): + if not isinstance(x, Symbol): raise LispErr(f'not a symbol: {show(x)}') + return x + +def _pair_val(x): + if not isinstance(x, Pair): raise LispErr(f'not a pair: {show(x)}') + return x + +def _equal(a, b): + if a is b: return True + if type(a) is not type(b) and not (isinstance(a, (int, float)) and isinstance(b, (int, float))): return False + if isinstance(a, Pair): return _equal(a.car, b.car) and _equal(a.cdr, b.cdr) + if isinstance(a, list): return len(a) == len(b) and all(_equal(x, y) for x, y in zip(a, b)) + return a == b + +def _is_proper_list(x): + slow = x; fast = x + while True: + if fast is NIL: return True + if not isinstance(fast, Pair): return False + fast = fast.cdr + if fast is NIL: return True + if not isinstance(fast, Pair): return False + fast = fast.cdr; slow = slow.cdr + if fast is slow: return False + +def _append(parts): + if not parts: return NIL + result = parts[-1] + for p in reversed(parts[:-1]): + for x in reversed(list(_L(p))): result = Pair(x, result) + return result + +def _list_star(a): + if len(a) == 1: return a[0] + return Pair(a[0], _list_star(a[1:])) + +def _list_tail(lst, n): + for _ in range(n): lst = _pair_val(lst).cdr + return lst + +def _member(obj, lst, eq): + n = lst + while isinstance(n, Pair): + if eq(n.car, obj): return n + n = n.cdr + return False + +def _assoc(key, lst, eq): + n = lst + while isinstance(n, Pair): + if isinstance(n.car, Pair) and eq(n.car.car, key): return n.car + n = n.cdr + return False + +def _format(a): + fmt = _str_val(a[0]); it = iter(a[1:]) + out = []; i = 0 + while i < len(fmt): + if fmt[i] == '~' and i + 1 < len(fmt): + c = fmt[i + 1]; i += 2 + if c == 'a': out.append(show(next(it), display=True)) + elif c == 's': out.append(show(next(it))) + elif c == '%': out.append('\n') + elif c == '~': out.append('~') + elif c == 'b': out.append(format(int(_num(next(it))), 'b')) + elif c == 'o': out.append(format(int(_num(next(it))), 'o')) + elif c == 'x': out.append(format(int(_num(next(it))), 'x')) + elif c == 'd': out.append(str(int(_num(next(it))))) + else: out.append('~'); out.append(c) + else: + out.append(fmt[i]); i += 1 + return ''.join(out) + + +def make_global_env(): + g = Env() + d = g.define + + # ── Arithmetic ─────────────────────────────────────────────────────────── + d(S('+'), lambda a, _: sum(_num(x) for x in a) if a else 0) + d(S('-'), lambda a, _: ( + _raise(LispErr('-: no args')) if not a else + -_num(a[0]) if len(a) == 1 else + _num(a[0]) - sum(_num(x) for x in a[1:]))) + d(S('*'), lambda a, _: (r := 1, [r := r * _num(x) for x in a], r)[-1]) + + def _div(a, _): + if not a: raise LispErr('/: no args') + if len(a) == 1: return 1 / _num(a[0]) + n = _num(a[0]) + for x in a[1:]: n /= _num(x) + return n + d(S('/'), _div) + d(S('quotient'), lambda a, _: int(_num(a[0]) / _num(a[1]))) + d(S('remainder'), lambda a, _: int(_num(a[0])) % int(_num(a[1])) * (1 if _num(a[0]) >= 0 else -1)) + d(S('modulo'), lambda a, _: int(_num(a[0])) % int(_num(a[1]))) + d(S('expt'), lambda a, _: _num(a[0]) ** _num(a[1])) + d(S('abs'), lambda a, _: abs(_num(a[0]))) + d(S('floor'), lambda a, _: int(math.floor(_num(a[0])))) + d(S('ceiling'), lambda a, _: int(math.ceil(_num(a[0])))) + d(S('round'), lambda a, _: int(round(_num(a[0])))) + d(S('truncate'), lambda a, _: int(math.trunc(_num(a[0])))) + d(S('floor/'), lambda a, _: (math.floor(_num(a[0]) / _num(a[1])), + _num(a[0]) - _num(a[1]) * math.floor(_num(a[0]) / _num(a[1])))) + d(S('sqrt'), lambda a, _: math.sqrt(_num(a[0]))) + d(S('log'), lambda a, _: math.log(_num(a[0])) if len(a) == 1 else math.log(_num(a[0]), _num(a[1]))) + d(S('exp'), lambda a, _: math.exp(_num(a[0]))) + d(S('sin'), lambda a, _: math.sin(_num(a[0]))) + d(S('cos'), lambda a, _: math.cos(_num(a[0]))) + d(S('tan'), lambda a, _: math.tan(_num(a[0]))) + d(S('asin'), lambda a, _: math.asin(_num(a[0]))) + d(S('acos'), lambda a, _: math.acos(_num(a[0]))) + d(S('atan'), lambda a, _: math.atan(_num(a[0])) if len(a) == 1 else math.atan2(_num(a[0]), _num(a[1]))) + d(S('floor'), lambda a, _: int(math.floor(_num(a[0])))) + d(S('min'), lambda a, _: min(_num(x) for x in a)) + d(S('max'), lambda a, _: max(_num(x) for x in a)) + d(S('gcd'), lambda a, _: math.gcd(int(_num(a[0])), int(_num(a[1])))) + d(S('lcm'), lambda a, _: abs(int(_num(a[0])) * int(_num(a[1]))) // (math.gcd(int(_num(a[0])), int(_num(a[1]))) or 1)) + d(S('exact'), lambda a, _: int(_num(a[0])) if isinstance(_num(a[0]), float) else _num(a[0])) + d(S('inexact'), lambda a, _: float(_num(a[0]))) + d(S('exact->inexact'), lambda a, _: float(_num(a[0]))) + d(S('inexact->exact'), lambda a, _: int(_num(a[0]))) + d(S('number->string'), lambda a, _: ( + format(int(_num(a[0])), {2: 'b', 8: 'o', 16: 'x'}.get(int(_num(a[1])), '')) + if len(a) > 1 else str(_num(a[0])))) + d(S('zero?'), lambda a, _: _num(a[0]) == 0) + d(S('positive?'), lambda a, _: _num(a[0]) > 0) + d(S('negative?'), lambda a, _: _num(a[0]) < 0) + d(S('odd?'), lambda a, _: int(_num(a[0])) % 2 != 0) + d(S('even?'), lambda a, _: int(_num(a[0])) % 2 == 0) + d(S('nan?'), lambda a, _: isinstance(a[0], float) and math.isnan(a[0])) + d(S('infinite?'), lambda a, _: isinstance(a[0], float) and math.isinf(a[0])) + d(S('finite?'), lambda a, _: isinstance(a[0], (int, float)) and not isinstance(a[0], bool) and math.isfinite(a[0])) + + # ── Numeric comparison ─────────────────────────────────────────────────── + for _nm, _op in [('=', lambda a,b: a==b), ('<', lambda a,b: a', lambda a,b: a>b), ('<=', lambda a,b: a<=b), + ('>=', lambda a,b: a>=b)]: + def _cmp(a, _, op=_op): + for x, y in zip(a, a[1:]): + if not op(_num(x), _num(y)): return False + return True + d(S(_nm), _cmp) + + # ── Booleans ───────────────────────────────────────────────────────────── + d(S('not'), lambda a, _: not _truthy(a[0])) + d(S('boolean?'), lambda a, _: isinstance(a[0], bool)) + d(S('boolean=?'), lambda a, _: all(x == a[0] for x in a[1:])) + + # ── Equality ───────────────────────────────────────────────────────────── + d(S('eq?'), lambda a, _: a[0] is a[1] or (a[0] == a[1] and isinstance(a[0], (int, bool, Symbol)))) + d(S('eqv?'), lambda a, _: a[0] is a[1] or (a[0] == a[1] and isinstance(a[0], (int, float, bool, Symbol, str)))) + d(S('equal?'), lambda a, _: _equal(a[0], a[1])) + + # ── Type predicates ────────────────────────────────────────────────────── + d(S('number?'), lambda a, _: isinstance(a[0], (int, float)) and not isinstance(a[0], bool)) + d(S('integer?'), lambda a, _: (isinstance(a[0], int) and not isinstance(a[0], bool)) or (isinstance(a[0], float) and a[0].is_integer())) + d(S('real?'), lambda a, _: isinstance(a[0], (int, float)) and not isinstance(a[0], bool)) + d(S('rational?'), lambda a, _: isinstance(a[0], (int, float)) and not isinstance(a[0], bool) and not math.isinf(a[0]) and not (isinstance(a[0], float) and math.isnan(a[0]))) + d(S('exact?'), lambda a, _: isinstance(a[0], int) and not isinstance(a[0], bool)) + d(S('inexact?'), lambda a, _: isinstance(a[0], float)) + d(S('pair?'), lambda a, _: isinstance(a[0], Pair)) + d(S('null?'), lambda a, _: a[0] is NIL) + d(S('list?'), lambda a, _: _is_proper_list(a[0])) + d(S('symbol?'), lambda a, _: isinstance(a[0], Symbol)) + d(S('string?'), lambda a, _: isinstance(a[0], str) and not isinstance(a[0], Symbol)) + d(S('char?'), lambda a, _: isinstance(a[0], str) and not isinstance(a[0], Symbol) and len(a[0]) == 1) + d(S('vector?'), lambda a, _: isinstance(a[0], list)) + d(S('boolean?'), lambda a, _: isinstance(a[0], bool)) + d(S('procedure?'), lambda a, _: isinstance(a[0], Proc) or (callable(a[0]) and not isinstance(a[0], (Macro, type)))) + d(S('void?'), lambda a, _: a[0] is VOID) + d(S('eof-object?'),lambda a, _: isinstance(a[0], _EOF)) + + # ── Pairs & Lists ───────────────────────────────────────────────────────── + d(S('cons'), lambda a, _: Pair(a[0], a[1])) + d(S('car'), lambda a, _: _pair_val(a[0]).car) + d(S('cdr'), lambda a, _: _pair_val(a[0]).cdr) + d(S('set-car!'), lambda a, _: setattr(_pair_val(a[0]), 'car', a[1]) or VOID) + d(S('set-cdr!'), lambda a, _: setattr(_pair_val(a[0]), 'cdr', a[1]) or VOID) + d(S('list'), lambda a, _: _P(a)) + d(S('list*'), lambda a, _: _list_star(a)) + d(S('cons*'), lambda a, _: _list_star(a)) + d(S('length'), lambda a, _: len(_L(a[0]))) + d(S('append'), lambda a, _: _append(a)) + d(S('reverse'), lambda a, _: _P(list(_L(a[0]))[::-1])) + d(S('list-tail'), lambda a, _: _list_tail(a[0], int(_num(a[1])))) + d(S('list-ref'), lambda a, _: _list_tail(a[0], int(_num(a[1]))).car) + d(S('list-set!'), lambda a, _: setattr(_list_tail(a[0], int(_num(a[1]))), 'car', a[2]) or VOID) + d(S('list-copy'), lambda a, _: _P(list(_L(a[0])))) + d(S('make-list'), lambda a, _: _P([a[1] if len(a) > 1 else False] * int(_num(a[0])))) + d(S('iota'), lambda a, _: _P(list(range(int(_num(a[0]))) if len(a) == 1 else + range(int(_num(a[1])), int(_num(a[1])) + int(_num(a[0]))) if len(a) == 2 else + range(int(_num(a[1])), int(_num(a[1])) + int(_num(a[0])) * int(_num(a[2])), int(_num(a[2])))))) + d(S('last-pair'), lambda a, _: (lambda n: [n := n.cdr or n for _ in iter(lambda: isinstance(n.cdr, Pair) and True, False)] and n)(a[0])) + d(S('memq'), lambda a, _: _member(a[0], a[1], lambda x, y: x is y or (x == y and isinstance(x, (int, bool, Symbol))))) + d(S('memv'), lambda a, _: _member(a[0], a[1], lambda x, y: x == y)) + d(S('member'), lambda a, _: _member(a[0], a[1], _equal)) + d(S('assq'), lambda a, _: _assoc(a[0], a[1], lambda x, y: x is y or (x == y and isinstance(x, (int, bool, Symbol))))) + d(S('assv'), lambda a, _: _assoc(a[0], a[1], lambda x, y: x == y)) + d(S('assoc'), lambda a, _: _assoc(a[0], a[1], _equal)) + d(S('flatten'), lambda a, _: _P(_flatten(_L(a[0])))) + d(S('zip'), lambda a, _: _P([_P(list(row)) for row in zip(*[_L(lst) for lst in a])])) + d(S('take'), lambda a, _: _P(list(_L(a[0]))[:int(_num(a[1]))])) + d(S('drop'), lambda a, _: _P(list(_L(a[0]))[int(_num(a[1])):])) + d(S('take-while'), lambda a, e: _P(list(_takewhile(a[0], _L(a[1]), e)))) + d(S('drop-while'), lambda a, e: _P(list(_dropwhile(a[0], _L(a[1]), e)))) + d(S('list-index'), lambda a, e: next((i for i, x in enumerate(_L(a[1])) if _truthy(_call(a[0], [x], e))), False)) + d(S('delete'), lambda a, e: _P([x for x in _L(a[1]) if not _equal(x, a[0])])) + d(S('delete-duplicates'), lambda a, _: _P(list({id(x) if isinstance(x, Pair) else x: x for x in _L(a[0])}.values()))) + + def _flatten(lst): + for x in lst: + if isinstance(x, Pair): yield from _flatten(list(x)) + elif x is NIL: pass + else: yield x + + def _takewhile(f, lst, env): + for x in lst: + if not _truthy(_call(f, [x], env)): break + yield x + + def _dropwhile(f, lst, env): + dropping = True + for x in lst: + if dropping and _truthy(_call(f, [x], env)): continue + dropping = False; yield x + + d(S('flatten'), lambda a, _: _P(list(_flatten(_L(a[0]))))) + d(S('take-while'), lambda a, e: _P(list(_takewhile(a[0], _L(a[1]), e)))) + d(S('drop-while'), lambda a, e: _P(list(_dropwhile(a[0], _L(a[1]), e)))) + + # ── SRFI-1 list library ─────────────────────────────────────────────────── + def _take_right(lst, n): + items = _L(lst); return _P(items[max(0, len(items)-n):]) + def _drop_right(lst, n): + items = _L(lst); return _P(items[:max(0, len(items)-n)]) + def _lset_union(eq, lists): + result = [] + for lst in lists: + for x in _L(lst): + if not any(_call(eq, [x, y], None) if callable(eq) else eq(x, y) for y in result): + result.append(x) + return _P(result) + def _lset_intersect(eq, a, b): + bl = _L(b) + return _P([x for x in _L(a) if any(_equal(x, y) for y in bl)]) + def _lset_diff(eq, a, b): + bl = _L(b) + return _P([x for x in _L(a) if not any(_equal(x, y) for y in bl)]) + def _unfold(pred, f, g, seed, env): + result = [] + while not _truthy(_call(pred, [seed], env)): + result.append(_call(f, [seed], env)) + seed = _call(g, [seed], env) + return _P(result) + + d(S('take-right'), lambda a, _: _take_right(a[0], int(_num(a[1])))) + d(S('drop-right'), lambda a, _: _drop_right(a[0], int(_num(a[1])))) + d(S('last'), lambda a, _: _L(a[0])[-1]) + d(S('first'), lambda a, _: _pair_val(a[0]).car) + d(S('second'), lambda a, _: list(a[0])[1]) + d(S('third'), lambda a, _: list(a[0])[2]) + d(S('fourth'), lambda a, _: list(a[0])[3]) + d(S('fifth'), lambda a, _: list(a[0])[4]) + d(S('concatenate'), lambda a, _: _append(_L(a[0]))) + d(S('list-tabulate'), lambda a, e: _P([_call(a[1],[i],e) for i in range(int(_num(a[0])))])) + d(S('reduce-right'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=False)) + d(S('unfold'), lambda a, e: _unfold(a[0], a[1], a[2], a[3], e)) + d(S('lset-union'), lambda a, e: _lset_union(a[0], a[1:])) + d(S('lset-intersection'), lambda a, e: _lset_intersect(a[0], a[1], a[2])) + d(S('lset-difference'), lambda a, e: _lset_diff(a[0], a[1], a[2])) + d(S('proper-list?'), lambda a, _: _is_proper_list(a[0])) + d(S('dotted-list?'), lambda a, _: (lambda n=a[0]: not _is_proper_list(n) and (isinstance(n, Pair) or not isinstance(n, _Nil)))()) + d(S('null-list?'), lambda a, _: a[0] is NIL) + d(S('alist-cons'), lambda a, _: Pair(Pair(a[0], a[1]), a[2])) + d(S('alist-copy'), lambda a, _: _P([Pair(p.car, p.cdr) for p in _L(a[0])])) + d(S('pair-for-each'), lambda a, e: [(lambda p: _call(a[0],[p],e))(p) for p in _L(a[1])] and VOID) + d(S('append!'), lambda a, _: _append(a)) # non-destructive fallback + d(S('delete'), lambda a, e: _P([x for x in _L(a[1]) if not _equal(x, a[0])])) + d(S('delete!'), lambda a, e: _P([x for x in _L(a[1]) if not _equal(x, a[0])])) + def _dedup(lst): + seen = []; r = [] + for x in _L(lst): + if not any(_equal(x, y) for y in seen): seen.append(x); r.append(x) + return _P(r) + d(S('delete-duplicates'), lambda a, _: _dedup(a[0])) + + # caaar..cddddr — auto-generate + for combo in ['aa','ad','da','dd', + 'aaa','aad','ada','add','daa','dad','dda','ddd', + 'aaaa','aaad','aada','aadd','adaa','adad','adda','addd', + 'daaa','daad','dada','dadd','ddaa','ddad','ddda','dddd']: + def _cxr(a, _, c=combo): + x = a[0] + for ch in reversed(c): + x = _pair_val(x).car if ch == 'a' else _pair_val(x).cdr + return x + d(S('c' + combo + 'r'), _cxr) + + # ── Higher-order ────────────────────────────────────────────────────────── + def _map(f, lists, env): + rows = [_L(lst) for lst in lists] + return _P([_call(f, list(col), env) for col in zip(*rows)]) + + def _for_each(f, lists, env): + rows = [_L(lst) for lst in lists] + for col in zip(*rows): _call(f, list(col), env) + + def _fold(f, init, lst, env, left=True): + acc = init + items = lst if left else reversed(lst) + for x in items: acc = _call(f, [x, acc], env) + return acc + + d(S('map'), lambda a, e: _map(a[0], a[1:], e)) + d(S('for-each'), lambda a, e: _for_each(a[0], a[1:], e) or VOID) + d(S('filter'), lambda a, e: _P([x for x in _L(a[1]) if _truthy(_call(a[0], [x], e))])) + d(S('filter-map'), lambda a, e: _P([v for x in _L(a[1]) for v in [_call(a[0],[x],e)] if _truthy(v)])) + d(S('fold-left'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=True)) + d(S('fold-right'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=False)) + d(S('foldl'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=True)) + d(S('foldr'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=False)) + d(S('reduce'), lambda a, e: (lambda lst: _fold(a[0], lst[0], lst[1:], e))(_L(a[2])) if _L(a[2]) else a[1]) + d(S('any'), lambda a, e: next((x for x in _L(a[1]) if _truthy(_call(a[0],[x],e))), False)) + d(S('every'), lambda a, e: next((False for x in _L(a[1]) if not _truthy(_call(a[0],[x],e))), True)) + d(S('count'), lambda a, e: sum(1 for x in _L(a[1]) if _truthy(_call(a[0],[x],e)))) + d(S('flat-map'), lambda a, e: _append([_call(a[0],[x],e) for x in _L(a[1])])) + d(S('append-map'), lambda a, e: _append([_call(a[0],[x],e) for x in _L(a[1])])) + d(S('sort'), lambda a, e: _P(sorted(_L(a[0])))) + d(S('sort-by'), lambda a, e: _P(sorted(_L(a[1]), key=lambda x: _call(a[0],[x],e)))) + d(S('group-by'), lambda a, e: _group_by(a[0], _L(a[1]), e)) + d(S('partition'), lambda a, e: (lambda yes,no: (yes, no))(*_partition(a[0], _L(a[1]), e))) + d(S('find'), lambda a, e: next((x for x in _L(a[1]) if _truthy(_call(a[0],[x],e))), False)) + + def _group_by(f, lst, env): + groups = {}; order = [] + for x in lst: + k = _call(f, [x], env) + if k not in groups: groups[k] = []; order.append(k) + groups[k].append(x) + return _P([Pair(k, _P(groups[k])) for k in order]) + + def _partition(f, lst, env): + yes, no = [], [] + for x in lst: + (yes if _truthy(_call(f,[x],env)) else no).append(x) + return _P(yes), _P(no) + + d(S('group-by'), lambda a, e: _group_by(a[0], _L(a[1]), e)) + d(S('partition'), lambda a, e: (lambda r: _P([r[0], r[1]]))(_partition(a[0], _L(a[1]), e))) + + # Functional utilities + def _compose(fns): + if not fns: return lambda a, e: a[0] + def composed(args, env): + result = _call(fns[-1], args, env) + for f in reversed(fns[:-1]): result = _call(f, [result], env) + return result + return composed + + d(S('compose'), lambda a, e: _compose(a)) + d(S('identity'), lambda a, _: a[0]) + d(S('const'), lambda a, e: (lambda v: (lambda b, _: v))(a[0])) + d(S('negate'), lambda a, e: (lambda f: lambda b, _: not _truthy(_call(f, b, e)))(a[0])) + d(S('complement'), lambda a, e: (lambda f: lambda b, _: not _truthy(_call(f, b, e)))(a[0])) + d(S('flip'), lambda a, e: (lambda f: lambda b, _: _call(f, [b[1],b[0]], e))(a[0])) + d(S('curry'), lambda a, e: (lambda f, x: lambda b, _: _call(f, [x]+b, e))(a[0], a[1])) + d(S('constantly'), lambda a, _: (lambda v: (lambda b, _: v))(a[0])) + d(S('apply'), lambda a, e: _call(a[0], (_L(a[-1]) if len(a)==2 else [leval(x,e) for x in a[1:-1]] + _L(a[-1])), e)) + + # ── Strings ─────────────────────────────────────────────────────────────── + d(S('make-string'), lambda a, _: (a[1] if len(a) > 1 else ' ') * int(_num(a[0]))) + d(S('string'), lambda a, _: ''.join(a)) + d(S('string-length'), lambda a, _: len(_str_val(a[0]))) + d(S('string-ref'), lambda a, _: _str_val(a[0])[int(_num(a[1]))]) + d(S('substring'), lambda a, _: _str_val(a[0])[int(_num(a[1])): int(_num(a[2])) if len(a) > 2 else None]) + d(S('string-append'), lambda a, _: ''.join(_str_val(x) for x in a)) + d(S('string-copy'), lambda a, _: _str_val(a[0])) + d(S('string->list'), lambda a, _: _P(list(_str_val(a[0])))) + d(S('list->string'), lambda a, _: ''.join(_L(a[0]))) + d(S('string->symbol'), lambda a, _: S(_str_val(a[0]))) + d(S('symbol->string'), lambda a, _: str(_sym_val(a[0]))) + d(S('string->number'), lambda a, _: _str_to_num(a)) + d(S('string-upcase'), lambda a, _: _str_val(a[0]).upper()) + d(S('string-downcase'), lambda a, _: _str_val(a[0]).lower()) + d(S('string-contains'),lambda a, _: _str_val(a[1]) in _str_val(a[0])) + d(S('string-prefix?'), lambda a, _: _str_val(a[1]).startswith(_str_val(a[0]))) + d(S('string-suffix?'), lambda a, _: _str_val(a[1]).endswith(_str_val(a[0]))) + d(S('string-split'), lambda a, _: _P(_str_val(a[0]).split(_str_val(a[1]) if len(a)>1 else None))) + d(S('string-join'), lambda a, _: (_str_val(a[1]) if len(a)>1 else ' ').join(_L(a[0]))) + d(S('string-trim'), lambda a, _: _str_val(a[0]).strip()) + d(S('string-trim-right'),lambda a, _: _str_val(a[0]).rstrip()) + d(S('string-replace'), lambda a, _: _str_val(a[0]).replace(_str_val(a[1]), _str_val(a[2]))) + d(S('string-index'), lambda a, _: _str_val(a[0]).find(_str_val(a[1]))) + d(S('string=?'), lambda a, _: _str_val(a[0]) == _str_val(a[1])) + d(S('string?'), lambda a, _: _str_val(a[0]) > _str_val(a[1])) + d(S('string<=?'), lambda a, _: _str_val(a[0]) <= _str_val(a[1])) + d(S('string>=?'), lambda a, _: _str_val(a[0]) >= _str_val(a[1])) + d(S('string-ci=?'), lambda a, _: _str_val(a[0]).lower() == _str_val(a[1]).lower()) + d(S('format'), lambda a, _: _format(a)) + d(S('string-format'), lambda a, _: _format(a)) + + def _str_to_num(a): + s = _str_val(a[0]); base = int(_num(a[1])) if len(a) > 1 else 10 + try: return int(s, base) + except ValueError: pass + try: return float(s) + except ValueError: return False + + d(S('string->number'), lambda a, _: _str_to_num(a)) + + # ── Symbols ─────────────────────────────────────────────────────────────── + d(S('gensym'), lambda a, _: S(f'g{next(_gensym_ctr)}')) + + # ── Characters ─────────────────────────────────────────────────────────── + d(S('char->integer'), lambda a, _: ord(a[0])) + d(S('integer->char'), lambda a, _: chr(int(_num(a[0])))) + d(S('char-alphabetic?'), lambda a, _: a[0].isalpha()) + d(S('char-numeric?'), lambda a, _: a[0].isdigit()) + d(S('char-whitespace?'), lambda a, _: a[0].isspace()) + d(S('char-upper-case?'), lambda a, _: a[0].isupper()) + d(S('char-lower-case?'), lambda a, _: a[0].islower()) + d(S('char-upcase'), lambda a, _: a[0].upper()) + d(S('char-downcase'), lambda a, _: a[0].lower()) + d(S('char=?'), lambda a, _: a[0] == a[1]) + d(S('char?'), lambda a, _: a[0] > a[1]) + d(S('char<=?'), lambda a, _: a[0] <= a[1]) + d(S('char>=?'), lambda a, _: a[0] >= a[1]) + d(S('char-ci=?'),lambda a, _: a[0].lower() == a[1].lower()) + + # ── Vectors ─────────────────────────────────────────────────────────────── + d(S('make-vector'), lambda a, _: [a[1] if len(a) > 1 else 0] * int(_num(a[0]))) + d(S('vector'), lambda a, _: list(a)) + d(S('vector-length'),lambda a, _: len(a[0])) + d(S('vector-ref'), lambda a, _: a[0][int(_num(a[1]))]) + d(S('vector-set!'), lambda a, _: a[0].__setitem__(int(_num(a[1])), a[2]) or VOID) + d(S('vector->list'), lambda a, _: _P(a[0])) + d(S('list->vector'), lambda a, _: list(_L(a[0]))) + d(S('vector-copy'), lambda a, _: list(a[0])) + d(S('vector-fill!'), lambda a, _: a[0].__setitem__(slice(None), [a[1]] * len(a[0])) or VOID) + d(S('vector-map'), lambda a, e: list(_map(a[0], [_P(a[1])], e) and [] or [_call(a[0],[x],e) for x in a[1]])) + d(S('vector-for-each'), lambda a, e: [_call(a[0],[x],e) for x in a[1]] and VOID) + d(S('vector-append'),lambda a, _: sum((v for v in a), [])) + d(S('vector->string'),lambda a, _: ''.join(a[0])) + d(S('string->vector'),lambda a, _: list(_str_val(a[0]))) + + # ── Hash tables ─────────────────────────────────────────────────────────── + d(S('make-hash-table'), lambda a, _: {}) + d(S('make-equal-hash-table'), lambda a, _: {}) + d(S('hash-table?'), lambda a, _: isinstance(a[0], dict)) + d(S('hash-table-set!'), lambda a, _: a[0].__setitem__(a[1], a[2]) or VOID) + d(S('hash-table/put!'), lambda a, _: a[0].__setitem__(a[1], a[2]) or VOID) + d(S('hash-table-ref'), lambda a, e: a[0][a[1]] if a[1] in a[0] else (_call(a[2],[],e) if len(a)>2 else _raise(LispErr(f'hash-table-ref: missing key: {show(a[1])}')))) + d(S('hash-table-ref/default'), lambda a, _: a[0].get(a[1], a[2])) + d(S('hash-table/get'), lambda a, _: a[0].get(a[1], a[2])) + d(S('hash-table-delete!'),lambda a,_: a[0].pop(a[1], None) or VOID) + d(S('hash-table-exists?'),lambda a,_: a[1] in a[0]) + d(S('hash-table/count'), lambda a, _: len(a[0])) + d(S('hash-table-size'), lambda a, _: len(a[0])) + d(S('hash-table-keys'), lambda a, _: _P(list(a[0].keys()))) + d(S('hash-table-values'),lambda a, _: _P(list(a[0].values()))) + d(S('hash-table->alist'),lambda a, _: _P([Pair(k, v) for k, v in a[0].items()])) + d(S('alist->hash-table'),lambda a, _: dict((p.car, p.cdr) for p in _L(a[0]))) + d(S('hash-table-walk'), lambda a, e: [_call(a[1],[k,v],e) for k,v in a[0].items()] and VOID) + d(S('hash-table-merge!'),lambda a, _: a[0].update(a[1]) or a[0]) + d(S('hash-table-update!'), lambda a, e: a[0].__setitem__(a[1], _call(a[2],[a[0].get(a[1], _call(a[3],[],e) if len(a)>3 else _raise(LispErr('hash-table-update!: missing key')))],e)) or VOID) + + # ── I/O ─────────────────────────────────────────────────────────────────── + d(S('display'), lambda a, _: print(show(a[0], display=True), end='', file=a[1] if len(a)>1 else sys.stdout, flush=True) or VOID) + d(S('write'), lambda a, _: print(show(a[0]), end='', file=a[1] if len(a)>1 else sys.stdout, flush=True) or VOID) + d(S('newline'), lambda a, _: print(file=a[0] if a else sys.stdout) or VOID) + d(S('print'), lambda a, _: print(show(a[0], display=True), flush=True) or VOID) + d(S('println'), lambda a, _: print(show(a[0], display=True), flush=True) or VOID) + d(S('writeln'), lambda a, _: print(show(a[0]), flush=True) or VOID) + d(S('write-string'), lambda a, _: print(_str_val(a[0]), end='', flush=True) or VOID) + d(S('read-char'), lambda a, _: sys.stdin.read(1) or EOF) + d(S('peek-char'), lambda a, _: EOF) # simplified + d(S('write-char'),lambda a, _: print(a[0], end='', flush=True) or VOID) + d(S('read-line'), lambda a, _: _read_line()) + d(S('read'), lambda a, _: _read_one()) + d(S('open-input-file'), lambda a, _: open(_str_val(a[0]))) + d(S('open-output-file'), lambda a, _: open(_str_val(a[0]), 'w')) + d(S('close-port'), lambda a, _: a[0].close() or VOID) + d(S('close-input-port'), lambda a, _: a[0].close() or VOID) + d(S('close-output-port'),lambda a, _: a[0].close() or VOID) + d(S('current-input-port'), lambda a, _: sys.stdin) + d(S('current-output-port'),lambda a, _: sys.stdout) + d(S('current-error-port'), lambda a, _: sys.stderr) + d(S('port?'), lambda a, _: hasattr(a[0], 'read') or hasattr(a[0], 'write')) + d(S('input-port?'),lambda a, _: hasattr(a[0], 'read')) + d(S('output-port?'),lambda a, _: hasattr(a[0], 'write')) + d(S('eof-object'), lambda a, _: EOF) + d(S('void'), lambda a, _: VOID) + d(S('with-output-to-string'), lambda a, e: _output_to_string(a[0], e)) + + def _read_line(): + try: + line = sys.stdin.readline() + return EOF if not line else line.rstrip('\n') + except EOFError: return EOF + + def _read_one(): + try: + line = input() + exprs = read_all(line) + return exprs[0] if exprs else EOF + except EOFError: return EOF + + def _output_to_string(thunk, env): + import io + buf = io.StringIO() + old = sys.stdout; sys.stdout = buf + try: _call(thunk, [], env) + finally: sys.stdout = old + return buf.getvalue() + + d(S('with-output-to-string'), lambda a, e: _output_to_string(a[0], e)) + + # ── Control ─────────────────────────────────────────────────────────────── + d(S('exit'), lambda a, _: sys.exit(0 if not a else int(_num(a[0])))) + d(S('error'), lambda a, _: _raise(LispErr(show(a[0],display=True) + (': ' + ' '.join(show(x) for x in a[1:]) if a[1:] else '')))) + d(S('raise'), lambda a, _: _raise(LispErr(show(a[0])))) + d(S('raise-continuable'), lambda a, _: _raise(LispErr(show(a[0])))) + d(S('error-message'), lambda a, _: str(a[0])) + d(S('with-exception-handler'), lambda a, e: ( + (lambda handler, thunk: (lambda: _call(thunk,[],e))()) if False else + None)) # handled as special form + d(S('condition?'), lambda a, _: isinstance(a[0], str)) + d(S('condition/report-string'), lambda a, _: str(a[0])) + + # ── Misc ────────────────────────────────────────────────────────────────── + d(S('not'), lambda a, _: not _truthy(a[0])) + d(S('values'), lambda a, _: a[0] if len(a) == 1 else tuple(a)) + d(S('call-with-values'), lambda a, e: (lambda r: _call(a[1], list(r) if isinstance(r, tuple) else [r], e))(_call(a[0],[],e))) + d(S('dynamic-wind'), lambda a, e: (_call(a[0],[],e), r := _call(a[1],[],e), _call(a[2],[],e), r)[-1]) + d(S('make-parameter'),lambda a, e: _make_parameter(a[0], a[1] if len(a)>1 else None, e)) + d(S('procedure?'), lambda a, _: isinstance(a[0], Proc) or (callable(a[0]) and not isinstance(a[0], (bool, type)))) + d(S('procedure-arity'), lambda a, _: len(a[0].params) if isinstance(a[0], Proc) else -1) + d(S('procedure-name'), lambda a, _: a[0].name or False if isinstance(a[0], Proc) else False) + + def _make_parameter(init, converter, env): + box = [_call(converter, [init], env) if converter else init] + def param(args, env_): + if not args: return box[0] + box[0] = _call(converter, [args[0]], env_) if converter else args[0] + return VOID + return param + + d(S('make-parameter'), lambda a, e: _make_parameter(a[0], a[1] if len(a)>1 else None, e)) + + # String representation + d(S('object->string'), lambda a, _: show(a[0])) + d(S('write-to-string'),lambda a, _: show(a[0])) + d(S('display-to-string'), lambda a, _: show(a[0], display=True)) + + # Python interop + d(S('py-eval'), lambda a, _: eval(_str_val(a[0]))) + d(S('py-exec'), lambda a, _: exec(_str_val(a[0])) or VOID) + d(S('py-import'), lambda a, _: __import__(_str_val(a[0]))) + d(S('py-call'), lambda a, _: a[0](*a[1:])) + d(S('py-attr'), lambda a, _: getattr(a[0], _str_val(a[1]))) + + # Constants + d(S('pi'), math.pi) + d(S('e'), math.e) + d(S('else'), True) + d(S('...'), S('...')) + d(S('*version*'), '1.0.0') + d(S('*name*'), 'uncommonlisp') + + return g + +############################################################################### +# Prelude (standard macros defined in Lisp) +############################################################################### + +PRELUDE = r""" +(define-macro (when test . body) + `(if ,test (begin ,@body) (void))) + +(define-macro (unless test . body) + `(if ,test (void) (begin ,@body))) + +(define-macro (and . args) + (cond ((null? args) #t) + ((null? (cdr args)) (car args)) + (else `(if ,(car args) (and ,@(cdr args)) #f)))) + +(define-macro (or . args) + (cond ((null? args) #f) + ((null? (cdr args)) (car args)) + (else (let ((v (gensym))) + `(let ((,v ,(car args))) + (if ,v ,v (or ,@(cdr args)))))))) + +(define-macro (case key . clauses) + (let ((k (gensym))) + `(let ((,k ,key)) + (cond ,@(map (lambda (c) + (if (eq? (car c) 'else) + c + `((memv ,k ',(car c)) ,@(cdr c)))) + clauses))))) + +(define-macro (while test . body) + (let ((loop (gensym))) + `(let ,loop () + (when ,test ,@body (,loop))))) + +(define-macro (for var lst . body) + `(for-each (lambda (,var) ,@body) ,lst)) + +(define-macro (define-record-type name . rest) + (let* ((ctor-spec (car rest)) + (constructor (car ctor-spec)) + (fields (cdr ctor-spec)) + (pred (cadr rest)) + (slot-specs (cddr rest)) + (tag (list 'quote name))) + `(begin + (define (,constructor ,@fields) + (list ,tag ,@fields)) + (define (,pred x) + (and (pair? x) (eq? (car x) ,tag))) + ,@(map (lambda (spec i) + (let* ((tag (car spec)) + (getter (cadr spec)) + (setter (if (null? (cddr spec)) #f (caddr spec)))) + `(begin + (define (,getter r) (list-ref r ,i)) + ,@(if setter + `((define (,setter r v) (list-set! r ,i v))) + '())))) + slot-specs + (iota (length slot-specs) 1))))) + +(define (call-with-string-output-port proc) + (let ((port (open-output-string))) + (proc port) + (get-output-string port))) + +(define (pp x) (writeln x)) + +(define (1+ n) (+ n 1)) +(define (1- n) (- n 1)) +(define (-1+ n) (- n 1)) +(define (add1 n) (+ n 1)) +(define (sub1 n) (- n 1)) + +(define (square x) (* x x)) +(define (cube x) (* x x x)) + +(define (compose . fns) + (if (null? fns) + identity + (let ((fn (car fns)) + (rest (apply compose (cdr fns)))) + (lambda args (fn (apply rest args)))))) + +(define (atom? x) (not (pair? x))) + +(define (flatten lst) + (cond ((null? lst) '()) + ((pair? (car lst)) (append (flatten (car lst)) (flatten (cdr lst)))) + (else (cons (car lst) (flatten (cdr lst)))))) + +(define (range . args) + (cond ((= (length args) 1) (iota (car args))) + ((= (length args) 2) (iota (- (cadr args) (car args)) (car args))) + ((= (length args) 3) (iota (ceiling (/ (- (cadr args) (car args)) (caddr args))) + (car args) (caddr args))) + (else (error "range: wrong number of args")))) + +(define (list-flatten lst) + (cond ((null? lst) '()) + ((pair? (car lst)) + (append (list-flatten (car lst)) (list-flatten (cdr lst)))) + (else (cons (car lst) (list-flatten (cdr lst)))))) + +(define (char-list->string chars) + (apply string chars)) + +(define (string-for-each f s) + (for-each f (string->list s))) + +(define (string-map f s) + (list->string (map f (string->list s)))) + +(define (with-values thunk receiver) + (call-with-values thunk receiver)) + +(define (char->string c) (string c)) + +(define (boolean->string b) (if b "#t" "#f")) + +(define (exact-integer? x) (and (integer? x) (exact? x))) + +(define (assoc* key alist) + (cond ((null? alist) #f) + ((equal? (caar alist) key) (car alist)) + (else (assoc* key (cdr alist))))) + +(define (alist-set! key val alist) + (let ((pair (assoc key alist))) + (if pair + (begin (set-cdr! pair val) alist) + (cons (cons key val) alist)))) +""" + +############################################################################### +# REPL +############################################################################### + +def repl(env, prompt='λ> ', quiet=False): + if not quiet: + print(f'uncommonlisp {env.lookup(S("*version*"))} ' + f'— (exit) to quit, (load "file.lsp") to load') + buf = '' + while True: + try: + line = input(prompt if not buf else ' ') + except (EOFError, KeyboardInterrupt): + if buf: + buf = ''; print(); continue + print(); break + buf += line + '\n' + # Try parsing; if incomplete, keep reading + try: + exprs = read_all(buf) + except LispErr: + continue # keep accumulating + if not exprs: + buf = ''; continue + # Check for unbalanced parens by counting + depth = 0 + for ch in buf: + if ch == '(': depth += 1 + elif ch == ')': depth -= 1 + if depth > 0: + continue # incomplete expression + for expr in exprs: + try: + result = leval(expr, env) + if result is not VOID: + print(show(result)) + except LispErr as e: + print(f'error: {e}', file=sys.stderr) + except Exception as e: + print(f'python error: {e}', file=sys.stderr) + buf = '' + +############################################################################### +# Main +############################################################################### + +def main(): + g = make_global_env() + # Load prelude + for expr in read_all(PRELUDE): + leval(expr, g) + + args = sys.argv[1:] + + # -e 'expr' mode + if args and args[0] == '-e': + if len(args) < 2: + print('usage: uncommonlisp -e ', file=sys.stderr) + sys.exit(1) + for expr in read_all(args[1]): + result = leval(expr, g) + if result is not VOID: + print(show(result)) + return + + # Script mode + if args: + path = args[0] + g.define(S('*argv*'), _P(args[1:])) + try: + _load(path, g) + except LispErr as e: + print(f'error: {e}', file=sys.stderr); sys.exit(1) + except FileNotFoundError: + print(f'file not found: {path}', file=sys.stderr); sys.exit(1) + return + + # REPL mode + repl(g) + +if __name__ == '__main__': + main()