russell@unturf.com
f7352b51b0
Historical internal name "uncommonlisp" retired in favor of the
public name "lumbda" ahead of lumbda.com going live. Scope of
this commit:
Source files renamed:
uncommonlisp.py -> lumbda.py
asm/uncommonlisp.s -> asm/lumbda.s
c/uncommonlisp.h -> c/lumbda.h
whitepaper/uncommonlisp-whitepaper -> whitepaper/lumbda-whitepaper (.rst + .pdf)
Binaries renamed (tracked ones; c/ was always gitignored):
asm/uncommonlisp, asm/uncommonlisp-gc, asm/uncommonlisp.o,
asm/uncommonlisp-gc.o -> asm/lumbda(-gc)(.o)
c/.gitignore -> ignores lumbda
Internal string updates (sed pass ordered longest-first):
asm/uncommonlisp -> asm/lumbda
c/uncommonlisp -> c/lumbda
uncommonlisp.py -> lumbda.py
UNCOMMONLISP_BIN -> LUMBDA_BIN (asm/test.sh env var)
"uncommonlisp> " -> "lumbda> " (asm REPL prompt baked into binary)
UNCOMMONLISP -> LUMBDA (macros, comments)
uncommonlisp -> lumbda (prose)
Binary portal magic updated:
"ULPORTAL" -> "LUMBDAB1" # "Lumbda Binary v1"
Old portal files are not backward-compatible — this is a deliberate
break since it's the rename moment. S-expression portals already
carry their own ";; lumbda-portal v1" header and remain cleanly
versioned.
WHITEPAPER.pdf / WHITEPAPER.rst symlinks repointed to the renamed
files. Makefile's whitepaper target targets lumbda-whitepaper.pdf.
Not changed (intentional, separate phases):
- Filesystem directory /home/fox/git/uncommonlisp itself
(fox renames locally and the gitlab repo URL in a follow-up)
- tests.py hardcoded cwd=/home/fox/git/uncommonlisp
(matches the current on-disk location; will flip when the
directory rename ships)
- Git history (immutable; old commits still say uncommonlisp,
which is correct — that's what they were)
Verified:
137 asm no-GC + 137 asm GC + 571 Python + 83 C + 189 shared
functional tests all pass under the new names.
bench-gc-http (2000 req): all 4 cells behave as expected
(cells 1/2 flat, 3 leaks, 4 bounded at 1 chunk).
Python REPL, C REPL, asm REPL all start cleanly.
385 lines
13 KiB
Text
385 lines
13 KiB
Text
;;; stdlib.lsp — standard library for lumbda
|
|
;;; Load with: (load "stdlib.lsp")
|
|
;;; Automatically loaded by the interpreter if found next to lumbda.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)))))))))
|
|
|
|
;;; ─── SRFI-64 lightweight test framework ─────────────────────────────────────
|
|
|
|
(define *test-pass* 0)
|
|
(define *test-fail* 0)
|
|
(define *test-group* "")
|
|
(define *test-verbose* #f)
|
|
|
|
(define (test-begin name)
|
|
(set! *test-group* name)
|
|
(set! *test-pass* 0)
|
|
(set! *test-fail* 0)
|
|
(display (string-append "--- " name " ---\n")))
|
|
|
|
(define (test-end)
|
|
(display (string-append *test-group* ": "
|
|
(number->string *test-pass*) " passed, "
|
|
(number->string *test-fail*) " failed\n"))
|
|
(= *test-fail* 0))
|
|
|
|
(define (test-assert msg val)
|
|
(if val
|
|
(begin (set! *test-pass* (+ *test-pass* 1))
|
|
(when *test-verbose* (display (string-append " OK " msg "\n"))))
|
|
(begin (set! *test-fail* (+ *test-fail* 1))
|
|
(display (string-append " FAIL " msg "\n")))))
|
|
|
|
(define-macro (test-equal msg expected expr)
|
|
(let ((r (gensym)) (e (gensym)))
|
|
`(let ((,r ,expr) (,e ,expected))
|
|
(if (equal? ,r ,e)
|
|
(begin (set! *test-pass* (+ *test-pass* 1))
|
|
(when *test-verbose* (display (string-append " OK " ,msg "\n"))))
|
|
(begin (set! *test-fail* (+ *test-fail* 1))
|
|
(display (string-append " FAIL " ,msg ": got " (write-to-string ,r)
|
|
" expected " (write-to-string ,e) "\n")))))))
|
|
|
|
(define-macro (test-error msg expr)
|
|
(let ((ok (gensym)))
|
|
`(let ((,ok (guard (e (#t #t)) ,expr #f)))
|
|
(if ,ok
|
|
(begin (set! *test-pass* (+ *test-pass* 1))
|
|
(when *test-verbose* (display (string-append " OK " ,msg " (error)\n"))))
|
|
(begin (set! *test-fail* (+ *test-fail* 1))
|
|
(display (string-append " FAIL " ,msg " (expected error)\n")))))))
|