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

Add string ports, error objects, rationals, modules, record inheritance, pretty-print

Browse source 
Core additions:
- StringInputPort / StringOutputPort — open-input-string, open-output-string,
  get-output-string, read/read-char/peek-char/read-line on ports
- R7RS ErrorObject class — error-object?, error-object-message,
  error-object-irritants; guard and with-exception-handler now receive
  ErrorObject instances instead of raw strings
- Exact rational arithmetic via Fraction — (/ 1 3) => 1/3, literal 1/3
  syntax, numerator/denominator, exact/inexact conversions
- Module system — (module name (export ...) body...) and (import name) /
  (import (name sym ...)) for selective import
- define-record-type now a Python special form supporting (inherit parent)
  for single-inheritance with subtype predicates
- Pretty-printer — pp/pretty-print with configurable line width

Correctness:
- R7RS letrec* body semantics for internal defines — names pre-declared
  before any initializer runs, enabling mutual recursion in let bodies
- string->number detects #x/#b/#o/#d and 0x/0b/0o prefixes
- show() guarantees decimal point in float output
- number->string rounds through show() for consistent float representation

Performance:
- _body_env fast path: skip scan when first body form is not define/begin
- Proc.has_defs flag: skip _body_env entirely for procs without internal defines
- Single-form body optimization: skip begin wrapper, set expr directly

Tests: 396 → 455 (+59 new tests covering all new features)
This commit is contained in:
russell@unturf.com 2026-04-13 12:27:06 -04:00
parent d0247b2729
commit 66977049f1
3 changed files with 821 additions and 93 deletions
Download patch file Download diff file Expand all files Collapse all files

22
README.md
View file

@ -29,6 +29,12 @@ python3 uncommonlisp.py -e '(+ 1 2)' # eval an expression
- `values` / `call-with-values`
- `dynamic-wind`, `guard`, `with-exception-handler`
- `quasiquote` / `unquote` / `unquote-splicing` with proper nesting
- R7RS internal defines → letrec* body semantics (mutual recursion in bodies)
- R7RS error objects — `error-object?` `error-object-message` `error-object-irritants`
- Exact rational arithmetic via `Fraction` — `(/ 1 3)` → `1/3`, `(+ 1/4 3/4)` → `1`
- String ports — `open-input-string` `open-output-string` `get-output-string` `read` on ports
- Module system — `module` / `import` with explicit export lists
- `define-record-type` with `(inherit parent)` for single-inheritance
**Special forms**
`define` `set!` `lambda` `λ` `if` `cond` `case` `and` `or` `when` `unless`
@ -36,24 +42,28 @@ python3 uncommonlisp.py -e '(+ 1 2)' # eval an expression
`quasiquote` `define-macro` `define-syntax` `syntax-rules`
`let-syntax` `letrec-syntax` `apply` `eval` `values` `call/cc`
`dynamic-wind` `guard` `parameterize` `load` `error`
`module` `import` `define-record-type`
**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
- Arithmetic: `+` `-` `*` `/` `quotient` `remainder` `modulo` `expt` `sqrt` `abs` `floor` `ceiling` `round` `truncate` `min` `max` `gcd` `lcm` `log` `exp` `sin` `cos` `tan` `atan` `numerator` `denominator` and more
- Rationals: `(/ 1 3)` → `1/3`, literal `1/3` syntax, exact arithmetic, `exact` / `inexact` conversion
- 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
- Strings: `string-length` `string-ref` `substring` `string-append` `string-upcase` `string-downcase` `string->list` `list->string` `string->symbol` `symbol->string` `string->number` (with `#x`/`0x`/`#b`/`#o` prefix detection) `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`
- Type predicates: `number?` `integer?` `real?` `rational?` `string?` `symbol?` `pair?` `null?` `list?` `char?` `vector?` `boolean?` `procedure?` `exact?` `inexact?`
- I/O: `display` `write` `newline` `read` `read-char` `peek-char` `read-line` `load` `with-output-to-string` `open-input-string` `open-output-string` `get-output-string`
- Error objects: `error-object?` `error-object-message` `error-object-irritants`
- Pretty-print: `pp` / `pretty-print` — indented output respecting line width
- 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`
`when` `unless` `case` `while` `for` `define-record-type` (with inheritance) `1+` `1-` `add1` `sub1` `square` `cube` `compose` `atom?` `range` `flatten` `string-map` `string-for-each` `call-with-string-output-port`
**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`
@ -119,7 +129,7 @@ Syntax-rules versions of `let`/`and`/`or`/`cond`/`case`/`do`, `fluid-let`, `rece
## Running tests
```bash
make test # run 396 tests
make test # run 455 tests
make test-verbose # verbose output
```

394
tests.py
View file

@ -1635,6 +1635,400 @@ class TestEdgeCases(unittest.TestCase):
assert r == '(1 "two" three #t #f)'
###############################################################################
# String ports
###############################################################################
class TestStringPorts(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_open_output_string_display(self):
r = run('(let ((p (open-output-string))) (display "hello" p) (get-output-string p))', self.g)
assert r == 'hello'
def test_open_output_string_write(self):
r = run('(let ((p (open-output-string))) (write "hello" p) (get-output-string p))', self.g)
assert r == '"hello"'
def test_open_output_string_multiple(self):
r = run('(let ((p (open-output-string))) (display 1 p) (display 2 p) (display 3 p) (get-output-string p))', self.g)
assert r == '123'
def test_open_input_string_read(self):
r = run('(let ((p (open-input-string "(+ 1 2)"))) (read p))', self.g)
assert runs('(let ((p (open-input-string "(+ 1 2)"))) (read p))', self.g) == '(+ 1 2)'
def test_open_input_string_read_multiple(self):
r = runs('(let ((p (open-input-string "1 2 3"))) (list (read p) (read p) (read p)))', self.g)
assert r == '(1 2 3)'
def test_open_input_string_eof(self):
r = run('(let ((p (open-input-string ""))) (read p))', self.g)
from uncommonlisp import EOF
assert r is EOF
def test_open_input_string_read_char(self):
r = run('(let ((p (open-input-string "abc"))) (read-char p))', self.g)
assert r == 'a'
def test_open_input_string_peek_char(self):
r = run('(let ((p (open-input-string "abc"))) (list (peek-char p) (read-char p) (read-char p)))', self.g)
assert list(r) == ['a', 'a', 'b']
def test_read_line_from_string_port(self):
r = run('(let ((p (open-input-string "line1\nline2"))) (read-line p))', self.g)
assert r == 'line1'
def test_call_with_string_output_port(self):
r = run('(call-with-string-output-port (lambda (p) (display 42 p) (display " hi" p)))', self.g)
assert r == '42 hi'
def test_string_port_predicate(self):
assert run('(string-port? (open-output-string))', self.g) is True
assert run('(string-port? (open-input-string "x"))', self.g) is True
assert run('(output-port? (open-output-string))', self.g) is True
assert run('(input-port? (open-input-string "x"))', self.g) is True
def test_read_all_from_port(self):
r = runs('''
(let ((p (open-input-string "1 2 3")))
(let loop ((acc (quote ())))
(let ((x (read p)))
(if (eof-object? x)
(reverse acc)
(loop (cons x acc))))))
''', self.g)
assert r == '(1 2 3)'
###############################################################################
# Error objects
###############################################################################
class TestErrorObjects(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_error_object_predicate(self):
r = run('(guard (e (#t (error-object? e))) (error "test"))', self.g)
assert r is True
def test_error_object_message(self):
r = run('(guard (e (#t (error-object-message e))) (error "oops"))', self.g)
assert r == 'oops'
def test_error_object_irritants(self):
r = runs('(guard (e (#t (error-object-irritants e))) (error "bad" 1 2 3))', self.g)
assert r == '(1 2 3)'
def test_error_object_irritants_empty(self):
r = run('(guard (e (#t (error-object-irritants e))) (error "no-irritants"))', self.g)
from uncommonlisp import NIL
assert r is NIL
def test_with_exception_handler_gets_error_object(self):
r = run('(with-exception-handler (lambda (e) (error-object? e)) (lambda () (error "boom")))', self.g)
assert r is True
def test_with_exception_handler_message(self):
r = run('(with-exception-handler (lambda (e) (error-object-message e)) (lambda () (error "msg" 1)))', self.g)
assert r == 'msg'
def test_error_not_caught_reraises(self):
with self.assertRaises(Exception):
run('(guard (e ((string? e) "string-error")) (error "not-a-string-check"))', self.g)
###############################################################################
# string->number extended
###############################################################################
class TestStringToNumberExtended(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_hex_prefix_hash(self):
assert run('(string->number "#xff")', self.g) == 255
assert run('(string->number "#xAB")', self.g) == 171
def test_bin_prefix_hash(self):
assert run('(string->number "#b1010")', self.g) == 10
def test_oct_prefix_hash(self):
assert run('(string->number "#o17")', self.g) == 15
def test_hex_prefix_0x(self):
assert run('(string->number "0xff")', self.g) == 255
def test_bin_prefix_0b(self):
assert run('(string->number "0b101")', self.g) == 5
def test_oct_prefix_0o(self):
assert run('(string->number "0o77")', self.g) == 63
def test_decimal_prefix(self):
assert run('(string->number "#d42")', self.g) == 42
def test_explicit_base_still_works(self):
assert run('(string->number "ff" 16)', self.g) == 255
assert run('(string->number "1010" 2)', self.g) == 10
def test_invalid_returns_false(self):
assert run('(string->number "not-a-number")', self.g) is False
assert run('(string->number "")', self.g) is False
###############################################################################
# Internal defines (letrec* body semantics)
###############################################################################
class TestInternalDefines(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_mutual_recursion_in_body(self):
r = run('''
(define (f)
(define (even? n) (if (= n 0) #t (odd? (- n 1))))
(define (odd? n) (if (= n 0) #f (even? (- n 1))))
(list (even? 4) (odd? 3)))
(f)
''', self.g)
assert list(r) == [True, True]
def test_sequential_body_defines(self):
r = run('''
(define (f)
(define x 1)
(define y 2)
(+ x y))
(f)
''', self.g)
assert r == 3
def test_internal_define_in_let(self):
r = run('(let ((x 10)) (define y (* x 2)) y)', self.g)
assert r == 20
def test_internal_define_in_letrec(self):
r = run('(letrec ((x 5)) (define y (+ x 1)) y)', self.g)
assert r == 6
def test_internal_define_shadowing(self):
run('(define x 100)', self.g)
r = run('''
(define (f)
(define x 1)
x)
(list (f) x)
''', self.g)
assert list(r) == [1, 100]
def test_predeclared_names_allow_mutual_ref(self):
# Both names pre-declared → each closure can reference the other
# ping(5)→pong(4)→ping(3)→pong(2)→ping(1)→pong(0) = "pong"
r = run('''
(let ()
(define (ping n) (if (= n 0) "ping" (pong (- n 1))))
(define (pong n) (if (= n 0) "pong" (ping (- n 1))))
(ping 5))
''', self.g)
assert r == 'pong'
###############################################################################
# Module system
###############################################################################
class TestModuleSystem(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_module_define_and_import(self):
run('''
(module mymath
(export square cube)
(define (square x) (* x x))
(define (cube x) (* x x x)))
''', self.g)
run('(import mymath)', self.g)
assert run('(square 5)', self.g) == 25
assert run('(cube 3)', self.g) == 27
def test_module_hides_private(self):
run('''
(module secret
(export public-fn)
(define private-val 42)
(define (public-fn) private-val))
''', self.g)
run('(import secret)', self.g)
assert run('(public-fn)', self.g) == 42
with self.assertRaises(Exception):
run('private-val', self.g)
def test_selective_import(self):
run('''
(module tools
(export add mul)
(define (add a b) (+ a b))
(define (mul a b) (* a b)))
''', self.g)
run('(import (tools add))', self.g)
assert run('(add 3 4)', self.g) == 7
with self.assertRaises(Exception):
run('(mul 3 4)', self.g)
def test_module_import_unknown_raises(self):
with self.assertRaises(Exception):
run('(import no-such-module)', self.g)
###############################################################################
# define-record-type with inheritance
###############################################################################
class TestRecordTypeInheritance(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_basic_record_unchanged(self):
run('''
(define-record-type vec2
(make-vec2 x y)
vec2?
(x vec2-x)
(y vec2-y set-vec2-y!))
''', self.g)
run('(define v (make-vec2 3 4))', self.g)
assert run('(vec2? v)', self.g) is True
assert run('(vec2-x v)', self.g) == 3
assert run('(vec2-y v)', self.g) == 4
run('(set-vec2-y! v 99)', self.g)
assert run('(vec2-y v)', self.g) == 99
def test_inherited_predicate(self):
run('''
(define-record-type animal
(make-animal name)
animal?
(name animal-name))
(define-record-type dog
(inherit animal)
(make-dog name breed)
dog?
(name animal-name)
(breed dog-breed))
''', self.g)
run('(define a (make-animal "cat"))', self.g)
run('(define d (make-dog "rex" "lab"))', self.g)
assert run('(animal? a)', self.g) is True
assert run('(animal? d)', self.g) is True # dog is subtype of animal
assert run('(dog? d)', self.g) is True
assert run('(dog? a)', self.g) is False
def test_inherited_accessor(self):
run('''
(define-record-type shape
(make-shape color)
shape?
(color shape-color))
(define-record-type circle
(inherit shape)
(make-circle color radius)
circle?
(color shape-color)
(radius circle-radius))
''', self.g)
run('(define c (make-circle "red" 5))', self.g)
assert run('(shape-color c)', self.g) == 'red'
assert run('(circle-radius c)', self.g) == 5
assert run('(shape? c)', self.g) is True
def test_deep_inheritance(self):
run('''
(define-record-type a (make-a x) a? (x a-x))
(define-record-type b (inherit a) (make-b x y) b? (x a-x) (y b-y))
(define-record-type c (inherit b) (make-c x y z) c? (x a-x) (y b-y) (z c-z))
''', self.g)
run('(define obj (make-c 1 2 3))', self.g)
assert run('(a? obj)', self.g) is True
assert run('(b? obj)', self.g) is True
assert run('(c? obj)', self.g) is True
assert run('(a-x obj)', self.g) == 1
assert run('(b-y obj)', self.g) == 2
assert run('(c-z obj)', self.g) == 3
###############################################################################
# Rational numbers
###############################################################################
class TestRationals(unittest.TestCase):
def setUp(self): self.g = fresh()
def test_division_exact(self):
assert runs('(/ 1 3)', self.g) == '1/3'
def test_division_simplifies(self):
assert runs('(/ 2 4)', self.g) == '1/2'
def test_division_whole(self):
assert run('(/ 6 3)', self.g) == 2
assert isinstance(run('(/ 6 3)', self.g), int)
def test_rational_literal(self):
assert runs('1/3', self.g) == '1/3'
def test_rational_add(self):
assert runs('(+ 1/3 1/6)', self.g) == '1/2'
def test_rational_mul(self):
assert runs('(* 2/3 3/4)', self.g) == '1/2'
def test_rational_sub(self):
assert runs('(- 1 1/3)', self.g) == '2/3'
def test_rational_add_to_int(self):
assert run('(+ 1/4 1/4 1/4 1/4)', self.g) == 1
assert isinstance(run('(+ 1/4 1/4 1/4 1/4)', self.g), int)
def test_rational_exact(self):
assert run('(exact? 1/3)', self.g) is True
assert run('(inexact? 1/3)', self.g) is False
def test_rational_predicates(self):
assert run('(number? 1/3)', self.g) is True
assert run('(rational? 1/3)', self.g) is True
assert run('(integer? 1/3)', self.g) is False
def test_rational_comparison(self):
assert run('(= 1/2 0.5)', self.g) is True
assert run('(< 1/3 1/2)', self.g) is True
assert run('(> 2/3 1/2)', self.g) is True
def test_rational_inexact(self):
r = run('(inexact 1/4)', self.g)
assert abs(r - 0.25) < 1e-10
def test_numerator_denominator(self):
assert run('(numerator 2/3)', self.g) == 2
assert run('(denominator 2/3)', self.g) == 3
assert run('(numerator 3)', self.g) == 3
assert run('(denominator 3)', self.g) == 1
def test_number_to_string_rational(self):
assert run('(number->string 1/3)', self.g) == '1/3'
def test_string_to_number_rational(self):
assert runs('(string->number "1/3")', self.g) == '1/3'
assert runs('(string->number "2/4")', self.g) == '1/2'
def test_rational_mixed_arithmetic(self):
# Mix of int, rational, float
r = run('(+ 1/2 0.5)', self.g)
assert abs(r - 1.0) < 1e-10
def test_one_over_n(self):
assert runs('(/ 1 7)', self.g) == '1/7'
assert runs('(* 7 (/ 1 7))', self.g) == '1'
###############################################################################
# Main
###############################################################################

498
uncommonlisp.py
View file

@ -6,6 +6,7 @@ Usage: python3 uncommonlisp.py [script.lsp] # run a file
python3 uncommonlisp.py -e '(+ 1 2)' # eval expression
"""
import sys, re, math, itertools
from fractions import Fraction
try: import readline
except ImportError: pass
@ -51,11 +52,17 @@ class Pair:
while isinstance(n, Pair): parts.append(show(n.car)); n = n.cdr
return '(' + ' '.join(parts) + ('' if n is NIL else ' . ' + show(n)) + ')'
def _has_internal_defines(body):
"""Check if body starts with a define form (for fast path in _body_env)."""
return bool(body) and isinstance(body[0], Pair) and (
body[0].car is S('define') or body[0].car is S('begin'))
class Proc:
__slots__ = ('params', 'rest', 'body', 'env', 'name')
__slots__ = ('params', 'rest', 'body', 'env', 'name', 'has_defs')
def __init__(self, params, rest, body, env, name=None):
self.params = params; self.rest = rest
self.body = body; self.env = env; self.name = name
self.has_defs = _has_internal_defines(body)
def __repr__(self): return f'#<procedure {self.name or "λ"}>'
class Macro:
@ -177,7 +184,56 @@ class _EOF:
EOF = _EOF()
class LispErr(Exception): pass
class LispErr(Exception):
def __init__(self, msg, obj=None):
super().__init__(msg); self.obj = obj # obj is ErrorObject or None
class ErrorObject:
"""R7RS error object — carried by LispErr when raised via (error ...)."""
__slots__ = ('msg', 'irritants')
def __init__(self, msg, irritants=()):
self.msg = msg; self.irritants = list(irritants)
def __str__(self):
if self.irritants:
return self.msg + ': ' + ' '.join(show(x) for x in self.irritants)
return self.msg
def __repr__(self): return f'#<error-object {self.msg!r}>'
class StringInputPort:
"""String input port — (open-input-string s)."""
def __init__(self, s): self._src = s; self._pos = 0
def read(self, n=-1):
if n < 0: r = self._src[self._pos:]; self._pos = len(self._src); return r
r = self._src[self._pos:self._pos+n]; self._pos += len(r); return r
def readline(self):
end = self._src.find('\n', self._pos)
if end < 0: r = self._src[self._pos:]; self._pos = len(self._src)
else: r = self._src[self._pos:end+1]; self._pos = end+1
return r
def read_datum(self):
"""Read one Lisp datum, advance position past it."""
remaining = self._src[self._pos:]
tok_spans = [(m.group(), m.end()) for m in _TOK_RE.finditer(remaining)
if not m.group().startswith(';')]
if not tok_spans: return EOF
toks = [t for t, _ in tok_spans]
try:
expr, n = _read(toks, 0)
self._pos += tok_spans[n - 1][1]
return expr
except (LispErr, IndexError): return EOF
def peek_char(self):
return self._src[self._pos] if self._pos < len(self._src) else EOF
def char_ready(self): return self._pos < len(self._src)
def close(self): pass
class StringOutputPort:
"""String output port — (open-output-string)."""
def __init__(self): self._buf = []
def write(self, s): self._buf.append(s); return len(s)
def flush(self): pass
def close(self): pass
def getvalue(self): return ''.join(self._buf)
###############################################################################
# Printer
@ -188,6 +244,8 @@ def show(x, display=False):
if x is VOID: return ''
if x is True: return '#t'
if x is False: return '#f'
if isinstance(x, ErrorObject): return repr(x)
if isinstance(x, Fraction): return f'{x.numerator}/{x.denominator}'
if isinstance(x, Pair): return repr(x)
if isinstance(x, list): # vector
return '#(' + ' '.join(show(e) for e in x) + ')'
@ -199,6 +257,11 @@ def show(x, display=False):
if isinstance(x, float):
if math.isinf(x): return '+inf.0' if x > 0 else '-inf.0'
if math.isnan(x): return '+nan.0'
s = repr(x)
# Ensure a decimal point for Scheme compatibility
if '.' not in s and 'e' not in s and 'n' not in s and 'i' not in s:
s += '.0'
return s
return repr(x)
###############################################################################
@ -271,6 +334,12 @@ def _atom(t):
if t == '+inf.0': return math.inf
if t == '-inf.0': return -math.inf
if t in ('+nan.0', '-nan.0'): return float('nan')
# Rational literal n/d (e.g. 1/3, -2/5)
if re.fullmatch(r'-?\d+/-?\d+', t):
try:
f = Fraction(t)
return f if f.denominator != 1 else f.numerator
except (ValueError, ZeroDivisionError): pass
return S(t)
def read_all(src):
@ -311,6 +380,32 @@ def _formals(f):
def _raise(e): raise e
def _body_env(forms, env):
"""Implement R7RS letrec* semantics for body internal defines.
Scans leading (define ...) forms, pre-declares all names as VOID in env,
returns the full form list unchanged (defines are re-evaluated sequentially).
This allows mutual recursion: both names exist before either body runs.
Short-circuits immediately when first form is not a define (common case)."""
# Fast path: no internal defines
if not forms: return forms
if not (isinstance(forms[0], Pair) and (forms[0].car is S('define') or forms[0].car is S('begin'))):
return forms
i = 0
while i < len(forms):
f = forms[i]
if isinstance(f, Pair) and f.car is S('define'):
a = _L(f.cdr)
name = a[0].car if isinstance(a[0], Pair) else a[0]
if isinstance(name, Symbol): env.define(name, VOID)
i += 1
elif isinstance(f, Pair) and f.car is S('begin'):
# Splice top-level begin (R7RS splicing begin in body)
spliced = _L(f.cdr)
forms = list(forms[:i]) + spliced + list(forms[i+1:])
else:
break
return forms
###############################################################################
# Environment
###############################################################################
@ -378,6 +473,92 @@ def _qq(tmpl, env, depth=0):
# Evaluator (TCO via explicit loop)
###############################################################################
def _define_record_type(a, env):
"""Implement (define-record-type name [(inherit parent)] ctor pred slot...)
Representation: (tag field...) as a Lisp list.
(inherit parent) establishes the subtype relationship so parent? is true
of child instances. The child ctor lists ALL fields it stores (not auto-inherited).
Parent accessors work on child instances when child preserves parent's field layout."""
name = a[0]
rest = a[1:]
# Check for (inherit parent) clause
parent_name = None
if rest and isinstance(rest[0], Pair) and rest[0].car is S('inherit'):
parent_name = str(_L(rest[0])[1])
rest = rest[1:]
# ctor-spec: (constructor field-name...)
ctor_spec = _L(rest[0])
ctor_name = ctor_spec[0]
all_fields = [str(s) for s in ctor_spec[1:]]
pred_name = rest[1]
slot_specs = [_L(s) for s in rest[2:]]
# Register in type registry (for subtype checks)
_record_types[str(name)] = {'fields': all_fields, 'parent': parent_name}
# Constructor: produces (name field1 field2 ...)
tag = Pair(S('quote'), Pair(name, NIL))
all_syms = [S(f) for f in all_fields]
ctor_body = Pair(S('list'), Pair(tag, _P(all_syms)))
ctor_proc = Proc(all_syms, None, [ctor_body], env, name=str(ctor_name))
env.define(ctor_name, ctor_proc)
# Predicate: true if instance's type tag is `name` or a subtype of `name`
def _is_subtype(child_tag, ancestor):
"""Is child_tag equal to or a descendant of ancestor?"""
if child_tag == ancestor: return True
rt = _record_types.get(child_tag)
while rt and rt['parent']:
if rt['parent'] == ancestor: return True
rt = _record_types.get(rt['parent'])
return False
def _make_pred(type_name):
sname = str(type_name)
def pred(args, _env):
x = args[0]
if not isinstance(x, Pair): return False
t = x.car
return isinstance(t, Symbol) and _is_subtype(str(t), sname)
return pred
env.define(pred_name, _make_pred(name))
# Accessors / mutators: each slot spec is (field-name getter) or (field-name getter setter)
# field-name in the spec is the slot identity tag (for documentation); getter/setter are names
for spec in slot_specs:
field_tag = spec[0]
getter_name = spec[1]
setter_name = spec[2] if len(spec) > 2 else None
field_str = str(field_tag)
try:
idx = all_fields.index(field_str) + 1 # +1 to skip type tag
except ValueError:
raise LispErr(f'define-record-type {name}: field {field_str!r} not in {all_fields}')
def _make_getter(i):
def getter_fn(args, _):
lst = args[0]
for _ in range(i): lst = _pair_val(lst).cdr
return _pair_val(lst).car
return getter_fn
def _make_setter(i):
def setter_fn(args, _):
lst = args[0]
for _ in range(i - 1): lst = _pair_val(lst).cdr
lst.cdr.car = args[1]
return VOID
return setter_fn
env.define(getter_name, _make_getter(idx))
if setter_name:
env.define(setter_name, _make_setter(idx))
return VOID
def leval(expr, env):
"""Evaluate expr in env. Tail-call safe via while loop."""
while True:
@ -507,19 +688,24 @@ def leval(expr, env):
p = Proc(bps, None, body, c, name=str(name))
c.define(name, p)
env = c.child(bps, None, bvs)
if _has_internal_defines(body): body = _body_env(body, env)
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
env = c
if _has_internal_defines(body): body = _body_env(body, env)
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
body = a[1:]
if _has_internal_defines(body): body = _body_env(body, c)
env = c; expr = Pair(S('begin'), _P(body)); continue
if head is S('letrec') or head is S('letrec*'):
a = _L(tail); binds = _L(a[0])
@ -527,7 +713,9 @@ def leval(expr, 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
body = a[1:]
if _has_internal_defines(body): body = _body_env(body, c)
env = c; expr = Pair(S('begin'), _P(body)); continue
if head is S('do'):
a = _L(tail)
@ -614,7 +802,10 @@ def leval(expr, 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
body = _body_env(proc.body, env) if proc.has_defs else proc.body
if len(body) == 1: expr = body[0]
else: expr = Pair(S('begin'), _P(body))
continue
if callable(proc): return proc(args, env)
raise LispErr(f'apply: not callable: {show(proc)}')
@ -624,8 +815,47 @@ def leval(expr, env):
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 ''))
irr = [leval(x, env) for x in a[1:]]
obj = ErrorObject(msg, irr)
raise LispErr(str(obj), obj=obj)
if head is S('define-record-type'):
return _define_record_type(_L(tail), env)
if head is S('module'):
# (module name (export sym ...) body...)
a = _L(tail)
mod_name = str(a[0])
export_list = _L(a[1]) if isinstance(a[1], Pair) and a[1].car is S('export') else []
explicit_exports = [str(s) for s in export_list[1:]] if export_list else []
body = a[2:]
mod_env = Env(env)
for e in body[:-1]: leval(e, mod_env)
if body: leval(body[-1], mod_env)
exports = explicit_exports if explicit_exports else list(mod_env.b.keys())
_modules[mod_name] = mod_env
_mod_exports[mod_name] = exports
return VOID
if head is S('import'):
# (import module-name) or (import (module-name sym ...))
for spec in _L(tail):
if isinstance(spec, Symbol):
name = str(spec)
if name not in _modules: raise LispErr(f'import: unknown module: {name}')
mod = _modules[name]
for k in _mod_exports.get(name, list(mod.b.keys())):
if k in mod.b: env.define(S(k), mod.b[k])
elif isinstance(spec, Pair):
items = _L(spec)
name = str(items[0])
if name not in _modules: raise LispErr(f'import: unknown module: {name}')
mod = _modules[name]
syms = [str(s) for s in items[1:]] if len(items) > 1 else _mod_exports.get(name, list(mod.b.keys()))
for k in syms:
if k in mod.b: env.define(S(k), mod.b[k])
else: raise LispErr(f'import: {name} has no export: {k}')
return VOID
if head is S('load'):
a = _L(tail); _load(leval(a[0], env), env); return VOID
@ -660,7 +890,7 @@ def leval(expr, env):
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 LispErr as e: return _call(handler, [e.obj if e.obj else str(e)], env)
except Exception as e: return _call(handler, [str(e)], env)
if head is S('guard'):
@ -670,7 +900,7 @@ def leval(expr, env):
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))
c = Env(env); c.define(var, exc.obj if exc.obj else str(exc))
for cl in clauses:
cl = _L(cl)
if cl[0] is S('else') or _truthy(leval(cl[0], c)):
@ -689,7 +919,10 @@ def leval(expr, env):
if isinstance(proc, Proc):
env = proc.env.child(proc.params, proc.rest, args)
expr = Pair(S('begin'), _P(proc.body)); continue
body = _body_env(proc.body, env) if proc.has_defs else proc.body
if len(body) == 1: expr = body[0]
else: expr = Pair(S('begin'), _P(body))
continue
if callable(proc): return proc(args, env)
@ -700,8 +933,9 @@ 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)
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)
if callable(proc): return proc(args, env)
raise LispErr(f'not callable: {show(proc)}')
@ -716,9 +950,12 @@ def _load(path, env):
###############################################################################
_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}
def _num(x):
if isinstance(x, bool) or not isinstance(x, (int, float)):
if isinstance(x, bool) or not isinstance(x, (int, float, Fraction)):
raise LispErr(f'not a number: {show(x)}')
return x
@ -737,7 +974,8 @@ def _pair_val(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
_numeric = (int, float, Fraction)
if type(a) is not type(b) and not (isinstance(a, _numeric) and isinstance(b, _numeric)): 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
@ -802,23 +1040,67 @@ def _format(a):
return ''.join(out)
def _pprint(x, indent=0, width=72):
"""Pretty-print a Lisp value with indentation."""
s = show(x)
if len(s) + indent <= width or not isinstance(x, Pair): return s
items = list(x)
if not items: return '()'
# (keyword arg1 arg2 ...) style: indent args under keyword
head = show(items[0])
if isinstance(items[0], Symbol) and len(items) > 1:
# Try to fit head + first arg on one line
first_col = indent + 2 + len(head)
parts = [_pprint(item, first_col, width) for item in items[1:]]
inner = ('\n' + ' ' * first_col).join(parts)
candidate = f'({head} {inner})'
if len(candidate.split('\n')[0]) + indent <= width or '\n' in inner:
return candidate
# Fall back: one item per line, indented by 1
col = indent + 1
parts = [_pprint(item, col, width) for item in items]
inner = ('\n' + ' ' * col).join(parts)
return f'({inner})'
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 _add(a, _):
if not a: return 0
result = _num(a[0])
for x in a[1:]: result = result + _num(x)
return result.numerator if isinstance(result, Fraction) and result.denominator == 1 else result
def _sub(a, _):
if not a: raise LispErr('-: no args')
if len(a) == 1: return -_num(a[0])
result = _num(a[0])
for x in a[1:]: result = result - _num(x)
return result.numerator if isinstance(result, Fraction) and result.denominator == 1 else result
def _mul(a, _):
result = 1
for x in a: result = result * _num(x)
return result.numerator if isinstance(result, Fraction) and result.denominator == 1 else result
d(S('+'), _add)
d(S('-'), _sub)
d(S('*'), _mul)
def _div(a, _):
if not a: raise LispErr('/: no args')
if len(a) == 1: return 1 / _num(a[0])
if len(a) == 1:
n = _num(a[0])
return Fraction(1, n) if isinstance(n, int) else 1.0 / n
n = _num(a[0])
for x in a[1:]: n /= _num(x)
for x in a[1:]:
x = _num(x)
# Exact division: int/int or Fraction/int → Fraction, then simplify
if isinstance(n, (int, Fraction)) and isinstance(x, (int, Fraction)):
f = Fraction(n, x) if not isinstance(n, Fraction) else n / Fraction(x)
n = f.numerator if f.denominator == 1 else f
else:
n = float(n) / float(x)
return n
d(S('/'), _div)
d(S('quotient'), lambda a, _: int(_num(a[0]) / _num(a[1])))
@ -846,13 +1128,20 @@ def make_global_env():
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('exact'), lambda a, _: (Fraction(_num(a[0])).limit_denominator() 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('inexact->exact'), lambda a, _: (Fraction(_num(a[0])).limit_denominator() if isinstance(_num(a[0]), float) else _num(a[0])))
d(S('numerator'), lambda a, _: _num(a[0]).numerator if isinstance(_num(a[0]), Fraction) else (int(_num(a[0])) if isinstance(_num(a[0]), int) else _num(a[0])))
d(S('denominator'),lambda a, _: _num(a[0]).denominator if isinstance(_num(a[0]), Fraction) else 1)
def _num_to_str(a):
n = _num(a[0])
if len(a) > 1:
base = int(_num(a[1]))
return format(int(n), {2: 'b', 8: 'o', 16: 'x'}.get(base, ''))
if isinstance(n, Fraction): return f'{n.numerator}/{n.denominator}'
return show(n) # uses show for floats (decimal point guaranteed)
d(S('number->string'), lambda a, _: _num_to_str(a))
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)
@ -883,11 +1172,11 @@ def make_global_env():
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('number?'), lambda a, _: isinstance(a[0], (int, float, Fraction)) 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()) or (isinstance(a[0], Fraction) and a[0].denominator == 1))
d(S('real?'), lambda a, _: isinstance(a[0], (int, float, Fraction)) and not isinstance(a[0], bool))
d(S('rational?'), lambda a, _: isinstance(a[0], (int, Fraction)) and not isinstance(a[0], bool) or (isinstance(a[0], float) and math.isfinite(a[0])))
d(S('exact?'), lambda a, _: (isinstance(a[0], int) or isinstance(a[0], Fraction)) 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)
@ -1133,10 +1422,33 @@ def make_global_env():
def _str_to_num(a):
s = _str_val(a[0]); base = int(_num(a[1])) if len(a) > 1 else 10
orig = s
# R7RS/Scheme radix prefixes: #b #o #d #x (also 0x/0b/0o for convenience)
if len(s) >= 2 and s[0] == '#':
pfx = s[1].lower()
if pfx == 'x': s = s[2:]; base = 16
elif pfx == 'b': s = s[2:]; base = 2
elif pfx == 'o': s = s[2:]; base = 8
elif pfx == 'd': s = s[2:]; base = 10
elif len(a) == 1 and len(s) >= 2 and s[0] == '0':
pfx = s[1].lower()
if pfx == 'x': s = s[2:]; base = 16
elif pfx == 'b': s = s[2:]; base = 2
elif pfx == 'o': s = s[2:]; base = 8
try: return int(s, base)
except ValueError: pass
try: return float(s)
except ValueError: return False
if base == 10:
# Rational n/d
if re.fullmatch(r'-?\d+/-?\d+', s):
try:
f = Fraction(s)
return f if f.denominator != 1 else f.numerator
except (ValueError, ZeroDivisionError): pass
try:
v = float(orig)
return v
except ValueError: pass
return False
d(S('string->number'), lambda a, _: _str_to_num(a))
@ -1198,39 +1510,65 @@ def make_global_env():
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)
def _port_out(a): return a[1] if len(a) > 1 else sys.stdout
def _port_in(a): return a[0] if a and isinstance(a[0], StringInputPort) else None
d(S('display'), lambda a, _: print(show(a[0], display=True), end='', file=_port_out(a), flush=True) or VOID)
d(S('write'), lambda a, _: print(show(a[0]), end='', file=_port_out(a), 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('write-string'), lambda a, _: ((_port_out(a) if len(a) > 1 else sys.stdout).write(_str_val(a[0])) or VOID))
d(S('read-char'), lambda a, _: _read_char_port(a[0] if a else None))
d(S('peek-char'), lambda a, _: _peek_char_port(a[0] if a else None))
d(S('char-ready?'), lambda a, _: (a[0].char_ready() if isinstance(a[0], StringInputPort) else True) if a else True)
d(S('write-char'),lambda a, _: print(a[0], end='', file=a[1] if len(a)>1 else sys.stdout, flush=True) or VOID)
d(S('read-line'), lambda a, _: _read_line_port(a[0] if a else None))
d(S('read'), lambda a, _: _read_datum_port(a[0] if a else None))
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('open-input-string'), lambda a, _: StringInputPort(_str_val(a[0])))
d(S('open-output-string'),lambda a, _: StringOutputPort())
d(S('get-output-string'), lambda a, _: a[0].getvalue() if isinstance(a[0], StringOutputPort) else '')
d(S('with-input-from-string'), lambda a, e: _with_input_from_string(_str_val(a[0]), a[1], e))
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('port?'), lambda a, _: isinstance(a[0], (StringInputPort, StringOutputPort)) or hasattr(a[0], 'read') or hasattr(a[0], 'write'))
d(S('input-port?'), lambda a, _: isinstance(a[0], StringInputPort) or hasattr(a[0], 'read'))
d(S('output-port?'), lambda a, _: isinstance(a[0], StringOutputPort) or hasattr(a[0], 'write'))
d(S('string-port?'), lambda a, _: isinstance(a[0], (StringInputPort, StringOutputPort)))
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))
d(S('call-with-port'), lambda a, e: (_call(a[1], [a[0]], e), a[0].close(), None)[-1] or VOID)
d(S('call-with-string-output-port'), lambda a, e:
(lambda p: (_call(a[0], [p], e), p.getvalue())[1])(StringOutputPort()))
def _read_line():
def _read_char_port(port):
if isinstance(port, StringInputPort): ch = port.read(1); return ch if ch else EOF
return sys.stdin.read(1) or EOF
def _peek_char_port(port):
if isinstance(port, StringInputPort): return port.peek_char()
return EOF # simplified for file ports
def _read_line_port(port):
if isinstance(port, StringInputPort):
line = port.readline(); return EOF if not line else line.rstrip('\n')
try:
line = sys.stdin.readline()
return EOF if not line else line.rstrip('\n')
except EOFError: return EOF
def _read_datum_port(port):
if isinstance(port, StringInputPort): return port.read_datum()
return _read_one()
def _read_one():
try:
line = input()
@ -1238,6 +1576,10 @@ def make_global_env():
return exprs[0] if exprs else EOF
except EOFError: return EOF
def _with_input_from_string(s, thunk, env):
port = StringInputPort(s)
return _call(thunk, [port], env)
def _output_to_string(thunk, env):
import io
buf = io.StringIO()
@ -1250,15 +1592,19 @@ def make_global_env():
# ── 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('error'), lambda a, _: (lambda obj: _raise(LispErr(str(obj), obj=obj)))(
ErrorObject(show(a[0], display=True), a[1:])))
d(S('raise'), lambda a, _: _raise(LispErr(str(a[0]) if isinstance(a[0], ErrorObject) else show(a[0]),
obj=a[0] if isinstance(a[0], ErrorObject) else None)))
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]))
d(S('error-object?'), lambda a, _: isinstance(a[0], ErrorObject))
d(S('error?'), lambda a, _: isinstance(a[0], ErrorObject))
d(S('error-object-message'), lambda a, _: a[0].msg if isinstance(a[0], ErrorObject) else str(a[0]))
d(S('error-object-irritants'), lambda a, _: _P(a[0].irritants) if isinstance(a[0], ErrorObject) else NIL)
d(S('error-message'), lambda a, _: a[0].msg if isinstance(a[0], ErrorObject) else str(a[0]))
d(S('condition?'), lambda a, _: isinstance(a[0], (ErrorObject, str)))
d(S('condition/report-string'),lambda a, _: str(a[0]))
d(S('with-exception-handler'), lambda a, e: None) # handled as special form
# ── Misc ──────────────────────────────────────────────────────────────────
d(S('not'), lambda a, _: not _truthy(a[0]))
@ -1284,6 +1630,8 @@ def make_global_env():
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))
d(S('pretty-print'), lambda a, e: print(_pprint(a[0]), file=a[1] if len(a)>1 else sys.stdout) or VOID)
d(S('pp'), lambda a, e: print(_pprint(a[0]), file=a[1] if len(a)>1 else sys.stdout) or VOID)
# Python interop
d(S('py-eval'), lambda a, _: eval(_str_val(a[0])))
@ -1342,37 +1690,13 @@ PRELUDE = r"""
(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-record-type is now a Python special form (supports (inherit parent))
(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))