From 52d14a2f599c7f02170b89f96902e212de84702e Mon Sep 17 00:00:00 2001
From: "russell@unturf.com" <russell@unturf.com>
Date: Mon, 13 Apr 2026 13:32:11 -0400
Subject: [PATCH] Add parameterize fix, let-values, case=>, arithmetic,
 FS/system builtins, tracing, SRFI-64
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

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)
---
 stdlib.lsp      |  45 +++++++++
 tests.py        | 262 ++++++++++++++++++++++++++++++++++++++++++++++++
 uncommonlisp.py | 106 +++++++++++++++++---
 3 files changed, 401 insertions(+), 12 deletions(-)

diff --git a/stdlib.lsp b/stdlib.lsp
index 51ee628..74e6ef7 100644
--- a/stdlib.lsp
+++ b/stdlib.lsp
@@ -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")))))))
diff --git a/tests.py b/tests.py
index db1978d..50840ba 100644
--- a/tests.py
+++ b/tests.py
@@ -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
 ###############################################################################
diff --git a/uncommonlisp.py b/uncommonlisp.py
index 1a2fb2e..05a7a1a 100644
--- a/uncommonlisp.py
+++ b/uncommonlisp.py
@@ -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 = ''