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

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)))))))))