engineering/lumbda
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add parameterize fix, let-values, case=>, arithmetic, FS/system builtins, tracing, SRFI-64

Browse source 
Correctness:
- Fix parameterize: was restoring current value instead of saved old value
- Add let-values and let*-values special forms (R7RS multi-value binding)
- Update case macro to handle (datum... => proc) clauses

Numeric tower:
- truncate-quotient, truncate-remainder, floor-quotient, floor-remainder
- square, exact-integer?

Vectors:
- vector-copy now accepts optional start/end bounds
- vector-copy! for destination-vector mutation

File system and system interface:
- file-exists?, delete-file, rename-file, current-directory,
  set-current-directory!, directory-files, make-directory,
  file-size, file-directory?, file-regular?
- command-line, get-environment-variable, current-time,
  current-jiffy, jiffies-per-second, flush-output-port

Debuggability:
- Call stack tracing: _call_stack captured in LispErr.call_stack
  _call() pushes/pops frames; REPL prints last 5 frames on error
- trace/untrace macros + make-traced/untrace-proc builtins
  (set! f (make-traced f 'f)) wraps f to print args and return values

stdlib.lsp:
- SRFI-64 lightweight test framework: test-begin, test-end,
  test-assert, test-equal, test-error macros

Tests: 455 → 491 (+36 new tests)
This commit is contained in:
russell@unturf.com 2026-04-13 13:32:11 -04:00
parent 66977049f1
commit 52d14a2f59
3 changed files with 401 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

45
stdlib.lsp
View file

@ -338,3 +338,48 @@
(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")))))))

262
tests.py
View file

@ -2029,6 +2029,268 @@ class TestRationals(unittest.TestCase):
assert runs('(* 7 (/ 1 7))', self.g) == '1'
###############################################################################
# New feature tests
###############################################################################
class TestParameterize(unittest.TestCase):
"""Verify parameterize restores the old value, not the current value."""
def setUp(self): self.g = fresh()
def test_restore_after_body(self):
# After parameterize, original value is restored
r = run("""
(define p (make-parameter 1))
(parameterize ((p 42))
(p))
""", self.g)
assert r == 42, f'expected 42, got {r}'
r2 = run('(p)', self.g)
assert r2 == 1, f'expected 1 restored, got {r2}'
def test_restore_on_exception(self):
# Even if body raises, old value is restored
g = fresh()
run('(define p (make-parameter 10))', g)
try:
run('(parameterize ((p 99)) (error "boom"))', g)
except LispErr:
pass
assert run('(p)', g) == 10
def test_nested_parameterize(self):
g = fresh()
r = run("""
(define p (make-parameter 0))
(parameterize ((p 1))
(parameterize ((p 2))
(p)))
""", g)
assert r == 2
assert run('(p)', g) == 0
def test_parameterize_restores_outer(self):
g = fresh()
run('(define p (make-parameter 5))', g)
inner = run('(parameterize ((p 10)) (p))', g)
assert inner == 10
after = run('(p)', g)
assert after == 5, f'expected 5 after parameterize, got {after}'
class TestLetValues(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_basic_let_values(self):
r = run('(let-values (((a b) (values 1 2))) (+ a b))', self.g)
assert r == 3
def test_multiple_bindings(self):
r = run('(let-values (((a b) (values 3 4)) ((c) (values 5))) (+ a b c))', self.g)
assert r == 12
def test_let_star_values_sequential(self):
# let*-values: second binding can use first
r = run("""
(let*-values (((a b) (values 1 2))
((c) (values (+ a b))))
c)
""", self.g)
assert r == 3
def test_single_value(self):
r = run('(let-values (((x) (values 7))) x)', self.g)
assert r == 7
class TestCaseArrow(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_case_no_arrow(self):
r = run('(case 2 ((1) "one") ((2) "two") (else "other"))', self.g)
assert r == 'two'
def test_case_arrow(self):
# (datum => proc): proc is called with the key value
# (* 2 3) = 6; key 5 is in (2 3 5 7), so proc should be called with 5
r = run('(case 5 ((2 3 5 7) => (lambda (x) (* x 10))) (else 0))', self.g)
assert r == 50
def test_case_else_no_arrow(self):
r = run('(case 99 ((1) 1) (else 42))', self.g)
assert r == 42
def test_case_else_arrow(self):
r = run('(case 5 ((1 2) "low") (else => (lambda (x) (+ x 100))))', self.g)
assert r == 105
class TestR7RSArithmetic(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_truncate_quotient(self):
assert run('(truncate-quotient 10 3)', self.g) == 3
assert run('(truncate-quotient -10 3)', self.g) == -3
def test_truncate_remainder(self):
assert run('(truncate-remainder 10 3)', self.g) == 1
assert run('(truncate-remainder -10 3)', self.g) == -1
def test_floor_quotient(self):
assert run('(floor-quotient 10 3)', self.g) == 3
assert run('(floor-quotient -10 3)', self.g) == -4
def test_floor_remainder(self):
assert run('(floor-remainder 10 3)', self.g) == 1
assert run('(floor-remainder -10 3)', self.g) == 2
def test_square(self):
assert run('(square 5)', self.g) == 25
assert run('(square -3)', self.g) == 9
def test_exact_integer(self):
assert run('(exact-integer? 42)', self.g) is True
assert run('(exact-integer? 42.0)', self.g) is False
assert run('(exact-integer? #t)', self.g) is False
class TestVectorCopy(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_vector_copy_full(self):
r = run('(vector-copy #(1 2 3 4 5))', self.g)
assert r == [1, 2, 3, 4, 5]
def test_vector_copy_start(self):
r = run('(vector-copy #(1 2 3 4 5) 2)', self.g)
assert r == [3, 4, 5]
def test_vector_copy_range(self):
r = run('(vector-copy #(1 2 3 4 5) 1 3)', self.g)
assert r == [2, 3]
def test_vector_copy_bang(self):
r = run("""
(define v (vector 1 2 3 4 5))
(vector-copy! v 1 #(10 20 30))
v
""", self.g)
assert r == [1, 10, 20, 30, 5]
def test_vector_copy_bang_partial(self):
r = run("""
(define v (vector 0 0 0 0 0))
(vector-copy! v 0 #(9 8 7) 1 2)
v
""", self.g)
assert r == [8, 0, 0, 0, 0]
class TestFileSystem(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_current_directory(self):
import os
r = run('(current-directory)', self.g)
assert isinstance(r, str)
assert os.path.isdir(r)
def test_file_exists_missing(self):
r = run('(file-exists? "/tmp/__no_such_file_xyzzy__")', self.g)
assert r is False
def test_file_exists_present(self):
import tempfile, os
with tempfile.NamedTemporaryFile(delete=False) as f:
path = f.name
try:
src = f'(file-exists? "{path}")'
assert run(src, self.g) is True
finally:
os.unlink(path)
def test_file_directory(self):
r = run('(file-directory? "/tmp")', self.g)
assert r is True
def test_file_regular(self):
import tempfile, os
with tempfile.NamedTemporaryFile(delete=False) as f:
path = f.name
try:
src = f'(file-regular? "{path}")'
assert run(src, self.g) is True
finally:
os.unlink(path)
def test_get_environment_variable(self):
import os
os.environ['_UCL_TEST_VAR'] = 'hello'
r = run('(get-environment-variable "_UCL_TEST_VAR")', self.g)
assert r == 'hello'
del os.environ['_UCL_TEST_VAR']
def test_get_environment_variable_missing(self):
r = run('(get-environment-variable "__NO_SUCH_VAR_XYZ__")', self.g)
assert r is False
def test_jiffies_per_second(self):
r = run('(jiffies-per-second)', self.g)
assert r == 1000
def test_current_jiffy(self):
r = run('(current-jiffy)', self.g)
assert isinstance(r, int)
assert r > 0
class TestCallStack(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_call_stack_attribute_exists(self):
# LispErr should carry a call_stack attribute
try:
run('(error "oops")', self.g)
assert False, 'expected LispErr'
except LispErr as e:
assert hasattr(e, 'call_stack')
assert isinstance(e.call_stack, list)
def test_call_stack_captured_via_call(self):
# map uses _call internally, so g should appear in the call stack
try:
run('(define (g x) (error "boom" x)) (map g (list 1 2 3))', self.g)
assert False, 'expected LispErr'
except LispErr as e:
assert 'g' in e.call_stack
class TestTracing(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_make_traced_still_works(self):
# make-traced wraps without breaking functionality
run('(define (double x) (* x 2))', self.g)
run('(trace double)', self.g)
r = run('(double 5)', self.g)
assert r == 10
def test_untrace_restores(self):
run('(define (add1 x) (+ x 1))', self.g)
run('(trace add1)', self.g)
run('(untrace add1)', self.g)
r = run('(add1 3)', self.g)
assert r == 4
###############################################################################
# Main
###############################################################################

106
uncommonlisp.py
View file

@ -5,7 +5,7 @@ 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
import sys, re, math, itertools, os as _os
from fractions import Fraction
try: import readline
except ImportError: pass
@ -187,6 +187,7 @@ EOF = _EOF()
class LispErr(Exception):
def __init__(self, msg, obj=None):
super().__init__(msg); self.obj = obj # obj is ErrorObject or None
self.call_stack = list(_call_stack)
class ErrorObject:
"""R7RS error object — carried by LispErr when raised via (error ...)."""
@ -717,6 +718,28 @@ def leval(expr, env):
if _has_internal_defines(body): body = _body_env(body, c)
env = c; expr = Pair(S('begin'), _P(body)); continue
if head is S('let-values'):
a = _L(tail); binds = _L(a[0]); body = a[1:]
c = Env(env)
for bind in binds:
bp = _L(bind); formals = bp[0]; val = leval(bp[1], env)
vs = list(val) if isinstance(val, tuple) else [val]
fmls = _L(formals) if isinstance(formals, Pair) else ([formals] if isinstance(formals, Symbol) else [])
for name, v in zip(fmls, vs): c.define(name, v)
body2 = _body_env(body, c) if _has_internal_defines(body) else body
env = c; expr = Pair(S('begin'), _P(body2)); continue
if head is S('let*-values'):
a = _L(tail); binds = _L(a[0]); body = a[1:]
c = Env(env)
for bind in binds:
bp = _L(bind); formals = bp[0]; val = leval(bp[1], c)
vs = list(val) if isinstance(val, tuple) else [val]
fmls = _L(formals) if isinstance(formals, Pair) else ([formals] if isinstance(formals, Symbol) else [])
for name, v in zip(fmls, vs): c.define(name, v)
body2 = _body_env(body, c) if _has_internal_defines(body) else body
env = c; expr = Pair(S('begin'), _P(body2)); continue
if head is S('do'):
a = _L(tail)
vcs = _L(a[0]); term = _L(a[1]); body = a[2:]
@ -866,17 +889,15 @@ def leval(expr, 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)
params_new = [(leval(_L(bp)[0], env), leval(_L(bp)[1], env)) for bp in binds]
saved = [(p, _call(p, [], env)) for p, _ in params_new]
for p, nv in params_new: _call(p, [nv], 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)
for p, ov in saved: _call(p, [ov], env)
if head is S('dynamic-wind'):
a = _L(tail)
@ -934,8 +955,13 @@ def _call(proc, args, env):
if isinstance(proc, Proc):
c = proc.env.child(proc.params, proc.rest, args)
body = _body_env(proc.body, c) if proc.has_defs else proc.body
for e in body[:-1]: leval(e, c)
return leval(body[-1], c)
frame = proc.name or 'λ'
_call_stack.append(frame)
try:
for e in body[:-1]: leval(e, c)
return leval(body[-1], c)
finally:
if _call_stack: _call_stack.pop()
if callable(proc): return proc(args, env)
raise LispErr(f'not callable: {show(proc)}')
@ -953,6 +979,8 @@ _gensym_ctr = itertools.count()
_modules: dict = {} # module-name → Env
_mod_exports: dict = {} # module-name → [export-names]
_record_types: dict = {} # record-name → {'fields': [...], 'parent': name|None}
_call_stack: list = [] # call stack for error reporting
_traced_originals: dict = {} # name → original proc (for untrace)
def _num(x):
if isinstance(x, bool) or not isinstance(x, (int, float, Fraction)):
@ -1150,6 +1178,12 @@ def make_global_env():
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]))
d(S('truncate-quotient'), lambda a, _: int(math.trunc(_num(a[0]) / _num(a[1]))))
d(S('truncate-remainder'), lambda a, _: _num(a[0]) - int(math.trunc(_num(a[0]) / _num(a[1]))) * _num(a[1]))
d(S('floor-quotient'), lambda a, _: int(math.floor(_num(a[0]) / _num(a[1]))))
d(S('floor-remainder'), lambda a, _: _num(a[0]) - int(math.floor(_num(a[0]) / _num(a[1]))) * _num(a[1]))
d(S('square'), lambda a, _: _num(a[0]) ** 2)
d(S('exact-integer?'), lambda a, _: isinstance(a[0], int) and not isinstance(a[0], bool))
# ── Numeric comparison ───────────────────────────────────────────────────
for _nm, _op in [('=', lambda a,b: a==b), ('<', lambda a,b: a<b),
@ -1480,7 +1514,8 @@ def make_global_env():
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-copy'), lambda a, _: list(a[0][ int(_num(a[1])) if len(a)>1 else 0 : int(_num(a[2])) if len(a)>2 else None ]))
d(S('vector-copy!'), lambda a, _: [a[0].__setitem__(int(_num(a[1]))+i, v) for i, v in enumerate(a[2][ int(_num(a[3])) if len(a)>3 else 0 : int(_num(a[4])) if len(a)>4 else None ])] and VOID)
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)
@ -1590,6 +1625,41 @@ def make_global_env():
d(S('with-output-to-string'), lambda a, e: _output_to_string(a[0], e))
# ── File system ──────────────────────────────────────────────────────────
d(S('file-exists?'), lambda a, _: _os.path.exists(_str_val(a[0])))
d(S('delete-file'), lambda a, _: _os.unlink(_str_val(a[0])) or VOID)
d(S('rename-file'), lambda a, _: _os.rename(_str_val(a[0]), _str_val(a[1])) or VOID)
d(S('current-directory'), lambda a, _: _os.getcwd())
d(S('set-current-directory!'),lambda a, _: _os.chdir(_str_val(a[0])) or VOID)
d(S('directory-files'), lambda a, _: _P(sorted(_os.listdir(_str_val(a[0]) if a else _os.getcwd()))))
d(S('make-directory'), lambda a, _: _os.makedirs(_str_val(a[0]), exist_ok=True) or VOID)
d(S('file-size'), lambda a, _: _os.path.getsize(_str_val(a[0])))
d(S('file-directory?'), lambda a, _: _os.path.isdir(_str_val(a[0])))
d(S('file-regular?'), lambda a, _: _os.path.isfile(_str_val(a[0])))
# ── System ────────────────────────────────────────────────────────────────
d(S('command-line'), lambda a, _: _P(sys.argv))
d(S('get-environment-variable'), lambda a, _: _os.environ.get(_str_val(a[0]), False))
d(S('current-time'), lambda a, _: __import__('time').time())
d(S('current-jiffy'), lambda a, _: int(__import__('time').monotonic_ns() // 1000000))
d(S('jiffies-per-second'), lambda a, _: 1000)
d(S('flush-output-port'), lambda a, _: (a[0] if a else sys.stdout).flush() or VOID)
# ── Tracing ───────────────────────────────────────────────────────────────
def _make_traced(proc, name):
sname = str(name) if name else getattr(proc, 'name', None) or 'λ'
_traced_originals[sname] = proc
def traced(args, env):
arg_str = ' '.join(show(a)[:30] for a in args[:4])
print(f' [trace {sname}] ({sname} {arg_str})', file=sys.stderr)
result = _call(proc, args, env)
print(f' [trace {sname}] => {show(result)[:60]}', file=sys.stderr)
return result
return traced
d(S('make-traced'), lambda a, _: _make_traced(a[0], a[1] if len(a) > 1 else None))
d(S('untrace-proc'), lambda a, _: _traced_originals.get(str(a[0]), a[0]))
# ── Control ───────────────────────────────────────────────────────────────
d(S('exit'), lambda a, _: sys.exit(0 if not a else int(_num(a[0]))))
d(S('error'), lambda a, _: (lambda obj: _raise(LispErr(str(obj), obj=obj)))(
@ -1678,8 +1748,12 @@ PRELUDE = r"""
`(let ((,k ,key))
(cond ,@(map (lambda (c)
(if (eq? (car c) 'else)
c
`((memv ,k ',(car c)) ,@(cdr c))))
(if (and (= (length c) 3) (eq? (cadr c) '=>))
`(else (,(caddr c) ,k))
c)
(if (and (= (length c) 3) (eq? (cadr c) '=>))
`((memv ,k ',(car c)) => (lambda (_) (,(caddr c) ,k)))
`((memv ,k ',(car c)) ,@(cdr c)))))
clauses)))))
(define-macro (while test . body)
@ -1761,6 +1835,12 @@ PRELUDE = r"""
(if pair
(begin (set-cdr! pair val) alist)
(cons (cons key val) alist))))
(define-macro (trace name)
`(set! ,name (make-traced ,name ',name)))
(define-macro (untrace name)
`(set! ,name (untrace-proc ',name)))
"""
###############################################################################
@ -1801,6 +1881,8 @@ def repl(env, prompt='λ> ', quiet=False):
print(show(result))
except LispErr as e:
print(f'error: {e}', file=sys.stderr)
if e.call_stack:
print(f' in: {" → ".join(e.call_stack[-5:])}', file=sys.stderr)
except Exception as e:
print(f'python error: {e}', file=sys.stderr)
buf = ''