russell@unturf.com
52d14a2f59
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)
1929 lines
86 KiB
Python
1929 lines
86 KiB
Python
#!/usr/bin/env python3
|
|
"""
|
|
uncommonlisp — a Lisp in one Python file.
|
|
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, os as _os
|
|
from fractions import Fraction
|
|
try: import readline
|
|
except ImportError: pass
|
|
|
|
###############################################################################
|
|
# Types
|
|
###############################################################################
|
|
|
|
class Symbol(str):
|
|
"""Interned symbol — identity comparison works."""
|
|
_t: dict = {}
|
|
def __new__(cls, s):
|
|
if s not in cls._t: cls._t[s] = str.__new__(cls, s)
|
|
return cls._t[s]
|
|
def __repr__(self): return str(self)
|
|
|
|
S = Symbol # short alias
|
|
|
|
class _Nil:
|
|
_i = None
|
|
def __new__(cls):
|
|
if cls._i is None: cls._i = super().__new__(cls)
|
|
return cls._i
|
|
def __repr__(self): return '()'
|
|
def __bool__(self): return False
|
|
def __iter__(self): return iter(())
|
|
def __len__(self): return 0
|
|
|
|
NIL = _Nil()
|
|
|
|
class Pair:
|
|
__slots__ = ('car', 'cdr')
|
|
def __init__(self, a, d): self.car = a; self.cdr = d
|
|
def __iter__(self):
|
|
n = self
|
|
while isinstance(n, Pair): yield n.car; n = n.cdr
|
|
if n is not NIL: raise TypeError('improper list')
|
|
def __len__(self):
|
|
c = 0; n = self
|
|
while isinstance(n, Pair): c += 1; n = n.cdr
|
|
return c
|
|
def __repr__(self):
|
|
parts = []; n = self
|
|
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', '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:
|
|
__slots__ = ('xfm',)
|
|
def __init__(self, xfm): self.xfm = xfm
|
|
def __repr__(self):
|
|
name = getattr(self.xfm, 'name', None) or '?'
|
|
return f'#<macro {name}>'
|
|
|
|
class _EllBind(list):
|
|
"""Marks a binding as an ellipsis (list of matched items), not a vector."""
|
|
pass
|
|
|
|
class _SyntaxTransformer:
|
|
"""Implements (syntax-rules (lit ...) (pattern template) ...)."""
|
|
def __init__(self, literals, rules, def_env):
|
|
self.literals = frozenset(str(x) for x in _L(literals))
|
|
self.rules = []
|
|
for r in _L(rules):
|
|
rl = _L(r); self.rules.append((rl[0], rl[1]))
|
|
self.def_env = def_env
|
|
|
|
def __call__(self, args, use_env):
|
|
form = _P(args)
|
|
for pat, tmpl in self.rules:
|
|
# pat.cdr is the actual pattern (skip keyword)
|
|
b = {}
|
|
if self._match(pat.cdr if isinstance(pat, Pair) else NIL, form, b):
|
|
return self._expand(tmpl, b)
|
|
raise LispErr(f'syntax error: no matching syntax-rules pattern')
|
|
|
|
def _pat_vars(self, pat):
|
|
if isinstance(pat, Symbol):
|
|
return {pat} if str(pat) not in self.literals and pat is not S('_') and pat is not S('...') else set()
|
|
if isinstance(pat, Pair): return self._pat_vars(pat.car) | self._pat_vars(pat.cdr)
|
|
return set()
|
|
|
|
def _match(self, pat, form, b):
|
|
if pat is NIL: return form is NIL
|
|
if isinstance(pat, bool): return pat == form
|
|
if isinstance(pat, (int, float, str)) and not isinstance(pat, Symbol): return pat == form
|
|
if isinstance(pat, Symbol):
|
|
if str(pat) in self.literals: return isinstance(form, Symbol) and str(form) == str(pat)
|
|
if pat is S('_'): return True
|
|
b[str(pat)] = form; return True
|
|
if not isinstance(pat, Pair): return pat == form
|
|
# Ellipsis: (sub_pat ... . rest_pat)
|
|
if isinstance(pat.cdr, Pair) and pat.cdr.car is S('...'):
|
|
sub_pat = pat.car; rest_pat = pat.cdr.cdr
|
|
pvars = self._pat_vars(sub_pat)
|
|
eb = {str(v): _EllBind() for v in pvars}
|
|
# count required tail elements
|
|
n_rest = 0; rp = rest_pat
|
|
while isinstance(rp, Pair): n_rest += 1; rp = rp.cdr
|
|
items = list(form) if isinstance(form, Pair) else []
|
|
n_ell = len(items) - n_rest
|
|
if n_ell < 0: return False
|
|
for item in items[:n_ell]:
|
|
ib = {}
|
|
if not self._match(sub_pat, item, ib): return False
|
|
for v in pvars: eb[str(v)].append(ib.get(str(v), VOID))
|
|
b.update(eb)
|
|
rest_form = _P(items[n_ell:])
|
|
return self._match(rest_pat, rest_form, b)
|
|
# Normal pair
|
|
if not isinstance(form, Pair): return False
|
|
return self._match(pat.car, form.car, b) and self._match(pat.cdr, form.cdr, b)
|
|
|
|
def _ell_vars(self, tmpl, b):
|
|
"""Symbols in tmpl that have _EllBind bindings."""
|
|
result = set()
|
|
if isinstance(tmpl, Symbol):
|
|
if str(tmpl) in b and isinstance(b[str(tmpl)], _EllBind): result.add(str(tmpl))
|
|
elif isinstance(tmpl, Pair):
|
|
result |= self._ell_vars(tmpl.car, b); result |= self._ell_vars(tmpl.cdr, b)
|
|
return result
|
|
|
|
def _expand(self, tmpl, b):
|
|
if tmpl is NIL or isinstance(tmpl, bool) or isinstance(tmpl, (int, float)): return tmpl
|
|
if isinstance(tmpl, str) and not isinstance(tmpl, Symbol): return tmpl
|
|
if isinstance(tmpl, Symbol):
|
|
if str(tmpl) in b:
|
|
v = b[str(tmpl)]
|
|
if isinstance(v, _EllBind): raise LispErr(f'syntax-rules: {tmpl} used without ...')
|
|
return v
|
|
return tmpl
|
|
if not isinstance(tmpl, Pair): return tmpl
|
|
# Ellipsis in template: (sub_tmpl ...)
|
|
if isinstance(tmpl.cdr, Pair) and tmpl.cdr.car is S('...'):
|
|
sub_tmpl = tmpl.car; rest_tmpl = tmpl.cdr.cdr
|
|
evars = self._ell_vars(sub_tmpl, b)
|
|
if not evars: raise LispErr(f'syntax-rules: no ellipsis var in {show(sub_tmpl)}')
|
|
n = len(b[next(iter(evars))])
|
|
expanded = []
|
|
for i in range(n):
|
|
sb = dict(b)
|
|
for v in evars: sb[v] = b[v][i]
|
|
expanded.append(self._expand(sub_tmpl, sb))
|
|
rest = self._expand(rest_tmpl, b)
|
|
for x in reversed(expanded): rest = Pair(x, rest)
|
|
return rest
|
|
return Pair(self._expand(tmpl.car, b), self._expand(tmpl.cdr, b))
|
|
|
|
class _Void:
|
|
_i = None
|
|
def __new__(cls):
|
|
if cls._i is None: cls._i = super().__new__(cls)
|
|
return cls._i
|
|
def __repr__(self): return ''
|
|
|
|
VOID = _Void()
|
|
|
|
class _EOF:
|
|
_i = None
|
|
def __new__(cls):
|
|
if cls._i is None: cls._i = super().__new__(cls)
|
|
return cls._i
|
|
def __repr__(self): return '#<eof>'
|
|
|
|
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 ...)."""
|
|
__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
|
|
###############################################################################
|
|
|
|
def show(x, display=False):
|
|
if x is NIL: return '()'
|
|
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) + ')'
|
|
if isinstance(x, str):
|
|
if isinstance(x, Symbol): return str(x)
|
|
if display: return x
|
|
return ('"' + x.replace('\\', '\\\\').replace('"', '\\"')
|
|
.replace('\n', '\\n').replace('\t', '\\t') + '"')
|
|
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)
|
|
|
|
###############################################################################
|
|
# Tokenizer
|
|
###############################################################################
|
|
|
|
_TOK_RE = re.compile(r'''
|
|
;[^\n]* | # line comment
|
|
"(?:[^"\\]|\\.)*" | # string literal
|
|
,@ | # unquote-splicing
|
|
[()\'`,] | # single-char tokens
|
|
\#[tf] | # booleans
|
|
\#\( | # vector #(
|
|
\#\\(?:space|newline|tab|return|null|escape|[^\s]) | # character
|
|
[^\s()"\'`,;]+ # atom
|
|
''', re.VERBOSE | re.IGNORECASE)
|
|
|
|
def _tokenize(src):
|
|
return [t for t in _TOK_RE.findall(src) if not t.startswith(';')]
|
|
|
|
###############################################################################
|
|
# Parser
|
|
###############################################################################
|
|
|
|
_QQ = {"'": S('quote'), '`': S('quasiquote'),
|
|
',': S('unquote'), ',@': S('unquote-splicing')}
|
|
|
|
def _read(toks, i):
|
|
if i >= len(toks): raise LispErr('unexpected EOF')
|
|
t = toks[i]; i += 1
|
|
if t in _QQ:
|
|
v, i = _read(toks, i)
|
|
return Pair(_QQ[t], Pair(v, NIL)), i
|
|
if t == '(':
|
|
items = []; tail = None
|
|
while True:
|
|
if i >= len(toks): raise LispErr('unclosed (')
|
|
if toks[i] == ')': i += 1; break
|
|
if toks[i] == '.':
|
|
i += 1; tail, i = _read(toks, i)
|
|
if i >= len(toks) or toks[i] != ')': raise LispErr('. without )')
|
|
i += 1; break
|
|
v, i = _read(toks, i); items.append(v)
|
|
r = NIL if tail is None else tail
|
|
for x in reversed(items): r = Pair(x, r)
|
|
return r, i
|
|
if t == '#(': # vector literal
|
|
items = []
|
|
while True:
|
|
if i >= len(toks): raise LispErr('unclosed #(')
|
|
if toks[i] == ')': i += 1; break
|
|
v, i = _read(toks, i); items.append(v)
|
|
return items, i
|
|
if t == ')': raise LispErr('unexpected )')
|
|
return _atom(t), i
|
|
|
|
def _atom(t):
|
|
if t == '#t' or t == '#T': return True
|
|
if t == '#f' or t == '#F': return False
|
|
if t.startswith('#\\'):
|
|
n = t[2:]
|
|
return {'space': ' ', 'newline': '\n', 'tab': '\t',
|
|
'return': '\r', 'null': '\0', 'escape': '\x1b'}.get(n.lower(), n[0])
|
|
if t.startswith('"'):
|
|
return (t[1:-1].replace('\\"', '"').replace('\\n', '\n')
|
|
.replace('\\t', '\t').replace('\\\\', '\\').replace('\\r', '\r'))
|
|
for conv in (int, float):
|
|
try: return conv(t)
|
|
except (ValueError, OverflowError): pass
|
|
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):
|
|
toks = _tokenize(src); exprs = []; i = 0
|
|
while i < len(toks): e, i = _read(toks, i); exprs.append(e)
|
|
return exprs
|
|
|
|
###############################################################################
|
|
# Helpers
|
|
###############################################################################
|
|
|
|
def _L(x):
|
|
"""Lisp list → Python list (validates proper list)."""
|
|
if x is NIL: return []
|
|
if isinstance(x, Pair): return list(x)
|
|
raise LispErr(f'not a list: {show(x)}')
|
|
|
|
def _P(lst):
|
|
"""Python list → Lisp list."""
|
|
r = NIL
|
|
for x in reversed(lst): r = Pair(x, r)
|
|
return r
|
|
|
|
def _truthy(x): return x is not False
|
|
|
|
def _formals(f):
|
|
"""Parse lambda formals → (params: [Symbol], rest: Symbol|None)."""
|
|
if isinstance(f, Symbol): return [], f
|
|
if f is NIL: return [], None
|
|
ps = []; n = f
|
|
while isinstance(n, Pair):
|
|
if not isinstance(n.car, Symbol):
|
|
raise LispErr(f'param must be symbol: {show(n.car)}')
|
|
ps.append(n.car); n = n.cdr
|
|
if n is NIL: return ps, None
|
|
if not isinstance(n, Symbol): raise LispErr(f'rest param must be symbol: {show(n)}')
|
|
return ps, n
|
|
|
|
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
|
|
###############################################################################
|
|
|
|
class Env:
|
|
__slots__ = ('b', 'p')
|
|
def __init__(self, parent=None): self.b = {}; self.p = parent
|
|
|
|
def lookup(self, k):
|
|
e = self
|
|
while e:
|
|
if k in e.b: return e.b[k]
|
|
e = e.p
|
|
raise LispErr(f'undefined: {k}')
|
|
|
|
def define(self, k, v): self.b[k] = v
|
|
|
|
def set(self, k, v):
|
|
e = self
|
|
while e:
|
|
if k in e.b: e.b[k] = v; return
|
|
e = e.p
|
|
raise LispErr(f"set! undefined: {k}")
|
|
|
|
def child(self, params, rest, args):
|
|
n = len(params)
|
|
if len(args) < n:
|
|
raise LispErr(f'arity: need {n}, got {len(args)}')
|
|
if rest is None and len(args) > n:
|
|
raise LispErr(f'arity: need {n}, got {len(args)}')
|
|
c = Env(self)
|
|
for p, a in zip(params, args): c.b[p] = a
|
|
if rest is not None: c.b[rest] = _P(args[n:])
|
|
return c
|
|
|
|
###############################################################################
|
|
# Quasiquote expander
|
|
###############################################################################
|
|
|
|
def _qq(tmpl, env, depth=0):
|
|
if not isinstance(tmpl, Pair): return tmpl
|
|
if tmpl.car is S('quasiquote'):
|
|
return Pair(S('quasiquote'), Pair(_qq(tmpl.cdr.car, env, depth + 1), NIL))
|
|
if tmpl.car is S('unquote'):
|
|
if depth == 0: return leval(tmpl.cdr.car, env)
|
|
return Pair(S('unquote'), Pair(_qq(tmpl.cdr.car, env, depth - 1), NIL))
|
|
parts = []; n = tmpl
|
|
while isinstance(n, Pair):
|
|
item = n.car
|
|
if isinstance(item, Pair) and item.car is S('unquote-splicing'):
|
|
if depth == 0:
|
|
parts.extend(_L(leval(item.cdr.car, env)))
|
|
else:
|
|
parts.append(Pair(S('unquote-splicing'),
|
|
Pair(_qq(item.cdr.car, env, depth - 1), NIL)))
|
|
else:
|
|
parts.append(_qq(item, env, depth))
|
|
n = n.cdr
|
|
tail = _qq(n, env, depth) if n is not NIL else NIL
|
|
r = tail
|
|
for p in reversed(parts): r = Pair(p, r)
|
|
return r
|
|
|
|
###############################################################################
|
|
# 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:
|
|
# Self-evaluating atoms
|
|
if (expr is NIL or expr is VOID or expr is True or expr is False
|
|
or isinstance(expr, (int, float, _EOF, list))
|
|
or (isinstance(expr, str) and not isinstance(expr, Symbol))):
|
|
return expr
|
|
|
|
# Symbol lookup
|
|
if isinstance(expr, Symbol):
|
|
return env.lookup(expr)
|
|
|
|
if not isinstance(expr, Pair):
|
|
return expr
|
|
|
|
head = expr.car
|
|
tail = expr.cdr # unevaluated args as Lisp list
|
|
|
|
# ── Special forms ────────────────────────────────────────────────────
|
|
|
|
if head is S('quote'):
|
|
return tail.car
|
|
|
|
if head is S('if'):
|
|
a = _L(tail)
|
|
if not 2 <= len(a) <= 3: raise LispErr('if: need 2-3 subforms')
|
|
expr = a[1] if _truthy(leval(a[0], env)) else (a[2] if len(a) == 3 else VOID)
|
|
continue
|
|
|
|
if head is S('cond'):
|
|
result = VOID
|
|
for cl in _L(tail):
|
|
cl = _L(cl)
|
|
if not cl: raise LispErr('cond: empty clause')
|
|
if cl[0] is S('else') or _truthy(leval(cl[0], env)):
|
|
if len(cl) == 1:
|
|
result = leval(cl[0], env) if cl[0] is not S('else') else VOID
|
|
break
|
|
if len(cl) == 3 and cl[1] is S('=>'):
|
|
v = leval(cl[0], env); f = leval(cl[2], env)
|
|
if isinstance(f, Proc):
|
|
env = f.env.child(f.params, f.rest, [v])
|
|
expr = Pair(S('begin'), _P(f.body)); break
|
|
return f([v], env)
|
|
for e in cl[1:-1]: leval(e, env)
|
|
expr = cl[-1]; break
|
|
else:
|
|
return result
|
|
continue
|
|
|
|
if head is S('and'):
|
|
a = _L(tail)
|
|
if not a: return True
|
|
for e in a[:-1]:
|
|
v = leval(e, env)
|
|
if not _truthy(v): return False
|
|
expr = a[-1]; continue
|
|
|
|
if head is S('or'):
|
|
a = _L(tail)
|
|
if not a: return False
|
|
for e in a[:-1]:
|
|
v = leval(e, env)
|
|
if _truthy(v): return v
|
|
expr = a[-1]; continue
|
|
|
|
if head is S('when'):
|
|
a = _L(tail)
|
|
if _truthy(leval(a[0], env)):
|
|
for e in a[1:-1]: leval(e, env)
|
|
expr = a[-1]; continue
|
|
return VOID
|
|
|
|
if head is S('unless'):
|
|
a = _L(tail)
|
|
if not _truthy(leval(a[0], env)):
|
|
for e in a[1:-1]: leval(e, env)
|
|
expr = a[-1]; continue
|
|
return VOID
|
|
|
|
if head is S('begin'):
|
|
a = _L(tail)
|
|
if not a: return VOID
|
|
for e in a[:-1]: leval(e, env)
|
|
expr = a[-1]; continue
|
|
|
|
if head is S('define'):
|
|
a = _L(tail)
|
|
if not a: raise LispErr('define: empty')
|
|
if isinstance(a[0], Pair): # (define (f x) body...)
|
|
fname = a[0].car; ps, rest = _formals(a[0].cdr)
|
|
p = Proc(ps, rest, a[1:], env, name=str(fname))
|
|
env.define(fname, p)
|
|
else:
|
|
name = a[0]
|
|
if not isinstance(name, Symbol): raise LispErr(f'define: name must be symbol, got {show(name)}')
|
|
val = leval(a[1], env) if len(a) > 1 else VOID
|
|
if isinstance(val, Proc) and not val.name: val.name = str(name)
|
|
env.define(name, val)
|
|
return VOID
|
|
|
|
if head is S('define-values'):
|
|
a = _L(tail); names = _L(a[0])
|
|
vals = leval(a[1], env)
|
|
vs = list(vals) if isinstance(vals, tuple) else [vals]
|
|
for n, v in zip(names, vs): env.define(n, v)
|
|
return VOID
|
|
|
|
if head is S('set!'):
|
|
a = _L(tail); env.set(a[0], leval(a[1], env)); return VOID
|
|
|
|
if head is S('lambda') or head is S('λ'):
|
|
a = _L(tail)
|
|
if not a: raise LispErr('lambda: empty')
|
|
ps, rest = _formals(a[0])
|
|
return Proc(ps, rest, a[1:], env)
|
|
|
|
if head is S('let'):
|
|
a = _L(tail)
|
|
if not a: raise LispErr('let: empty')
|
|
if isinstance(a[0], Symbol): # named let
|
|
name = a[0]; binds = _L(a[1]); body = a[2:]
|
|
bps = [_L(b)[0] for b in binds]
|
|
bvs = [leval(_L(b)[1], env) for b in binds]
|
|
c = Env(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
|
|
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))
|
|
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])
|
|
c = Env(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))
|
|
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('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:]
|
|
c = Env(env)
|
|
specs = [_L(vc) for vc in vcs]
|
|
for sp in specs: c.define(sp[0], leval(sp[1], env))
|
|
steps = [sp[2] if len(sp) > 2 else sp[0] for sp in specs]
|
|
while True:
|
|
if _truthy(leval(term[0], c)):
|
|
if len(term) == 1: return VOID
|
|
for e in term[1:-1]: leval(e, c)
|
|
expr = term[-1]; env = c; break
|
|
for b in body: leval(b, c)
|
|
nvs = [leval(s, c) for s in steps]
|
|
for sp, nv in zip(specs, nvs): c.set(sp[0], nv)
|
|
continue
|
|
|
|
if head is S('quasiquote'):
|
|
return _qq(tail.car, env)
|
|
|
|
if head is S('define-macro') or head is S('defmacro'):
|
|
a = _L(tail)
|
|
if isinstance(a[0], Pair): # (define-macro (name params...) body...)
|
|
name = a[0].car; ps, rest = _formals(a[0].cdr)
|
|
body = a[1:]
|
|
else: # (define-macro name (params...) body...)
|
|
name = a[0]; ps, rest = _formals(a[1])
|
|
body = a[2:]
|
|
xfm = Proc(ps, rest, body, env, name=str(name))
|
|
env.define(name, Macro(xfm)); return VOID
|
|
|
|
if head is S('define-syntax'):
|
|
a = _L(tail)
|
|
val = leval(a[1], env)
|
|
if isinstance(val, _SyntaxTransformer):
|
|
env.define(a[0], Macro(val))
|
|
else:
|
|
env.define(a[0], val)
|
|
return VOID
|
|
|
|
if head is S('let-syntax'):
|
|
a = _L(tail); body = a[1:]
|
|
c = Env(env)
|
|
for b in _L(a[0]):
|
|
bp = _L(b); c.define(bp[0], Macro(leval(bp[1], env)))
|
|
env = c; expr = Pair(S('begin'), _P(body)); continue
|
|
|
|
if head is S('letrec-syntax'):
|
|
a = _L(tail); body = a[1:]
|
|
c = Env(env)
|
|
for b in _L(a[0]):
|
|
bp = _L(b); c.define(bp[0], Macro(leval(bp[1], c)))
|
|
env = c; expr = Pair(S('begin'), _P(body)); continue
|
|
|
|
if head is S('syntax-rules'):
|
|
a = _L(tail)
|
|
return _SyntaxTransformer(a[0], _P(a[1:]), env)
|
|
|
|
if head is S('values'):
|
|
vals = [leval(e, env) for e in _L(tail)]
|
|
return vals[0] if len(vals) == 1 else tuple(vals)
|
|
|
|
if head is S('call-with-values'):
|
|
a = _L(tail)
|
|
prod = leval(a[0], env); cons_ = leval(a[1], env)
|
|
r = _call(prod, [], env)
|
|
args = list(r) if isinstance(r, tuple) else [r]
|
|
return _call(cons_, args, env)
|
|
|
|
if head is S('call/cc') or head is S('call-with-current-continuation'):
|
|
a = _L(tail); proc = leval(a[0], env)
|
|
class Escape(Exception):
|
|
def __init__(self, v): self.v = v
|
|
def kont(args, _env): raise Escape(args[0] if args else VOID)
|
|
try: return _call(proc, [kont], env)
|
|
except Escape as e: return e.v
|
|
|
|
if head is S('apply'):
|
|
a = _L(tail)
|
|
proc = leval(a[0], env)
|
|
pre = [leval(x, env) for x in a[1:-1]]
|
|
last = leval(a[-1], env)
|
|
args = pre + _L(last)
|
|
if isinstance(proc, Proc):
|
|
env = proc.env.child(proc.params, proc.rest, args)
|
|
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)}')
|
|
|
|
if head is S('eval'):
|
|
a = _L(tail); expr = leval(a[0], env); continue
|
|
|
|
if head is S('error'):
|
|
a = _L(tail)
|
|
msg = show(leval(a[0], env), display=True)
|
|
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
|
|
|
|
if head is S('include'):
|
|
for path_expr in _L(tail):
|
|
_load(show(leval(path_expr, env), display=True), env)
|
|
return VOID
|
|
|
|
if head is S('parameterize'):
|
|
a = _L(tail); binds = _L(a[0]); body = a[1:]
|
|
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 p, ov in saved: _call(p, [ov], env)
|
|
|
|
if head is S('dynamic-wind'):
|
|
a = _L(tail)
|
|
before = leval(a[0], env); thunk = leval(a[1], env); after = leval(a[2], env)
|
|
_call(before, [], env)
|
|
try: r = _call(thunk, [], env)
|
|
finally: _call(after, [], env)
|
|
return r
|
|
|
|
if head is S('with-exception-handler'):
|
|
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, [e.obj if e.obj else str(e)], env)
|
|
except Exception as e: return _call(handler, [str(e)], env)
|
|
|
|
if head is S('guard'):
|
|
a = _L(tail); var_clauses = _L(a[0]); body = a[1:]
|
|
var = var_clauses[0]; clauses = var_clauses[1:]
|
|
try:
|
|
for e in body[:-1]: leval(e, env)
|
|
return leval(body[-1], env)
|
|
except LispErr as 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)):
|
|
for e in cl[1:-1]: leval(e, c)
|
|
return leval(cl[-1], c)
|
|
raise
|
|
|
|
# ── Macro expansion ──────────────────────────────────────────────────
|
|
hval = leval(head, env)
|
|
if isinstance(hval, Macro):
|
|
expr = _call(hval.xfm, _L(tail), env); continue
|
|
|
|
# ── Procedure application ────────────────────────────────────────────
|
|
proc = hval
|
|
args = [leval(a, env) for a in _L(tail)]
|
|
|
|
if isinstance(proc, Proc):
|
|
env = proc.env.child(proc.params, proc.rest, args)
|
|
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'not callable: {show(proc)}')
|
|
|
|
|
|
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)
|
|
body = _body_env(proc.body, c) if proc.has_defs else proc.body
|
|
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)}')
|
|
|
|
|
|
def _load(path, env):
|
|
with open(path) as f:
|
|
src = f.read()
|
|
for expr in read_all(src): leval(expr, env)
|
|
|
|
###############################################################################
|
|
# Built-ins
|
|
###############################################################################
|
|
|
|
_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)):
|
|
raise LispErr(f'not a number: {show(x)}')
|
|
return x
|
|
|
|
def _str_val(x):
|
|
if not isinstance(x, str) or isinstance(x, Symbol):
|
|
raise LispErr(f'not a string: {show(x)}')
|
|
return x
|
|
|
|
def _sym_val(x):
|
|
if not isinstance(x, Symbol): raise LispErr(f'not a symbol: {show(x)}')
|
|
return x
|
|
|
|
def _pair_val(x):
|
|
if not isinstance(x, Pair): raise LispErr(f'not a pair: {show(x)}')
|
|
return x
|
|
|
|
def _equal(a, b):
|
|
if a is b: return True
|
|
_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
|
|
|
|
def _is_proper_list(x):
|
|
slow = x; fast = x
|
|
while True:
|
|
if fast is NIL: return True
|
|
if not isinstance(fast, Pair): return False
|
|
fast = fast.cdr
|
|
if fast is NIL: return True
|
|
if not isinstance(fast, Pair): return False
|
|
fast = fast.cdr; slow = slow.cdr
|
|
if fast is slow: return False
|
|
|
|
def _append(parts):
|
|
if not parts: return NIL
|
|
result = parts[-1]
|
|
for p in reversed(parts[:-1]):
|
|
for x in reversed(list(_L(p))): result = Pair(x, result)
|
|
return result
|
|
|
|
def _list_star(a):
|
|
if len(a) == 1: return a[0]
|
|
return Pair(a[0], _list_star(a[1:]))
|
|
|
|
def _list_tail(lst, n):
|
|
for _ in range(n): lst = _pair_val(lst).cdr
|
|
return lst
|
|
|
|
def _member(obj, lst, eq):
|
|
n = lst
|
|
while isinstance(n, Pair):
|
|
if eq(n.car, obj): return n
|
|
n = n.cdr
|
|
return False
|
|
|
|
def _assoc(key, lst, eq):
|
|
n = lst
|
|
while isinstance(n, Pair):
|
|
if isinstance(n.car, Pair) and eq(n.car.car, key): return n.car
|
|
n = n.cdr
|
|
return False
|
|
|
|
def _format(a):
|
|
fmt = _str_val(a[0]); it = iter(a[1:])
|
|
out = []; i = 0
|
|
while i < len(fmt):
|
|
if fmt[i] == '~' and i + 1 < len(fmt):
|
|
c = fmt[i + 1]; i += 2
|
|
if c == 'a': out.append(show(next(it), display=True))
|
|
elif c == 's': out.append(show(next(it)))
|
|
elif c == '%': out.append('\n')
|
|
elif c == '~': out.append('~')
|
|
elif c == 'b': out.append(format(int(_num(next(it))), 'b'))
|
|
elif c == 'o': out.append(format(int(_num(next(it))), 'o'))
|
|
elif c == 'x': out.append(format(int(_num(next(it))), 'x'))
|
|
elif c == 'd': out.append(str(int(_num(next(it)))))
|
|
else: out.append('~'); out.append(c)
|
|
else:
|
|
out.append(fmt[i]); i += 1
|
|
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 ───────────────────────────────────────────────────────────
|
|
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:
|
|
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:]:
|
|
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])))
|
|
d(S('remainder'), lambda a, _: int(_num(a[0])) % int(_num(a[1])) * (1 if _num(a[0]) >= 0 else -1))
|
|
d(S('modulo'), lambda a, _: int(_num(a[0])) % int(_num(a[1])))
|
|
d(S('expt'), lambda a, _: _num(a[0]) ** _num(a[1]))
|
|
d(S('abs'), lambda a, _: abs(_num(a[0])))
|
|
d(S('floor'), lambda a, _: int(math.floor(_num(a[0]))))
|
|
d(S('ceiling'), lambda a, _: int(math.ceil(_num(a[0]))))
|
|
d(S('round'), lambda a, _: int(round(_num(a[0]))))
|
|
d(S('truncate'), lambda a, _: int(math.trunc(_num(a[0]))))
|
|
d(S('floor/'), lambda a, _: (math.floor(_num(a[0]) / _num(a[1])),
|
|
_num(a[0]) - _num(a[1]) * math.floor(_num(a[0]) / _num(a[1]))))
|
|
d(S('sqrt'), lambda a, _: math.sqrt(_num(a[0])))
|
|
d(S('log'), lambda a, _: math.log(_num(a[0])) if len(a) == 1 else math.log(_num(a[0]), _num(a[1])))
|
|
d(S('exp'), lambda a, _: math.exp(_num(a[0])))
|
|
d(S('sin'), lambda a, _: math.sin(_num(a[0])))
|
|
d(S('cos'), lambda a, _: math.cos(_num(a[0])))
|
|
d(S('tan'), lambda a, _: math.tan(_num(a[0])))
|
|
d(S('asin'), lambda a, _: math.asin(_num(a[0])))
|
|
d(S('acos'), lambda a, _: math.acos(_num(a[0])))
|
|
d(S('atan'), lambda a, _: math.atan(_num(a[0])) if len(a) == 1 else math.atan2(_num(a[0]), _num(a[1])))
|
|
d(S('floor'), lambda a, _: int(math.floor(_num(a[0]))))
|
|
d(S('min'), lambda a, _: min(_num(x) for x in a))
|
|
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, _: (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, _: (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)
|
|
d(S('odd?'), lambda a, _: int(_num(a[0])) % 2 != 0)
|
|
d(S('even?'), lambda a, _: int(_num(a[0])) % 2 == 0)
|
|
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),
|
|
('>', lambda a,b: a>b), ('<=', lambda a,b: a<=b),
|
|
('>=', lambda a,b: a>=b)]:
|
|
def _cmp(a, _, op=_op):
|
|
for x, y in zip(a, a[1:]):
|
|
if not op(_num(x), _num(y)): return False
|
|
return True
|
|
d(S(_nm), _cmp)
|
|
|
|
# ── Booleans ─────────────────────────────────────────────────────────────
|
|
d(S('not'), lambda a, _: not _truthy(a[0]))
|
|
d(S('boolean?'), lambda a, _: isinstance(a[0], bool))
|
|
d(S('boolean=?'), lambda a, _: all(x == a[0] for x in a[1:]))
|
|
|
|
# ── Equality ─────────────────────────────────────────────────────────────
|
|
d(S('eq?'), lambda a, _: a[0] is a[1] or (a[0] == a[1] and isinstance(a[0], (int, bool, Symbol))))
|
|
d(S('eqv?'), lambda a, _: a[0] is a[1] or (a[0] == a[1] and isinstance(a[0], (int, float, bool, Symbol, str))))
|
|
d(S('equal?'), lambda a, _: _equal(a[0], a[1]))
|
|
|
|
# ── Type predicates ──────────────────────────────────────────────────────
|
|
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)
|
|
d(S('list?'), lambda a, _: _is_proper_list(a[0]))
|
|
d(S('symbol?'), lambda a, _: isinstance(a[0], Symbol))
|
|
d(S('string?'), lambda a, _: isinstance(a[0], str) and not isinstance(a[0], Symbol))
|
|
d(S('char?'), lambda a, _: isinstance(a[0], str) and not isinstance(a[0], Symbol) and len(a[0]) == 1)
|
|
d(S('vector?'), lambda a, _: isinstance(a[0], list))
|
|
d(S('boolean?'), lambda a, _: isinstance(a[0], bool))
|
|
d(S('procedure?'), lambda a, _: isinstance(a[0], Proc) or (callable(a[0]) and not isinstance(a[0], (Macro, type))))
|
|
d(S('void?'), lambda a, _: a[0] is VOID)
|
|
d(S('eof-object?'),lambda a, _: isinstance(a[0], _EOF))
|
|
|
|
# ── Pairs & Lists ─────────────────────────────────────────────────────────
|
|
d(S('cons'), lambda a, _: Pair(a[0], a[1]))
|
|
d(S('car'), lambda a, _: _pair_val(a[0]).car)
|
|
d(S('cdr'), lambda a, _: _pair_val(a[0]).cdr)
|
|
d(S('set-car!'), lambda a, _: setattr(_pair_val(a[0]), 'car', a[1]) or VOID)
|
|
d(S('set-cdr!'), lambda a, _: setattr(_pair_val(a[0]), 'cdr', a[1]) or VOID)
|
|
d(S('list'), lambda a, _: _P(a))
|
|
d(S('list*'), lambda a, _: _list_star(a))
|
|
d(S('cons*'), lambda a, _: _list_star(a))
|
|
d(S('length'), lambda a, _: len(_L(a[0])))
|
|
d(S('append'), lambda a, _: _append(a))
|
|
d(S('reverse'), lambda a, _: _P(list(_L(a[0]))[::-1]))
|
|
d(S('list-tail'), lambda a, _: _list_tail(a[0], int(_num(a[1]))))
|
|
d(S('list-ref'), lambda a, _: _list_tail(a[0], int(_num(a[1]))).car)
|
|
d(S('list-set!'), lambda a, _: setattr(_list_tail(a[0], int(_num(a[1]))), 'car', a[2]) or VOID)
|
|
d(S('list-copy'), lambda a, _: _P(list(_L(a[0]))))
|
|
d(S('make-list'), lambda a, _: _P([a[1] if len(a) > 1 else False] * int(_num(a[0]))))
|
|
d(S('iota'), lambda a, _: _P(list(range(int(_num(a[0]))) if len(a) == 1 else
|
|
range(int(_num(a[1])), int(_num(a[1])) + int(_num(a[0]))) if len(a) == 2 else
|
|
range(int(_num(a[1])), int(_num(a[1])) + int(_num(a[0])) * int(_num(a[2])), int(_num(a[2]))))))
|
|
d(S('last-pair'), lambda a, _: (lambda n: [n := n.cdr or n for _ in iter(lambda: isinstance(n.cdr, Pair) and True, False)] and n)(a[0]))
|
|
d(S('memq'), lambda a, _: _member(a[0], a[1], lambda x, y: x is y or (x == y and isinstance(x, (int, bool, Symbol)))))
|
|
d(S('memv'), lambda a, _: _member(a[0], a[1], lambda x, y: x == y))
|
|
d(S('member'), lambda a, _: _member(a[0], a[1], _equal))
|
|
d(S('assq'), lambda a, _: _assoc(a[0], a[1], lambda x, y: x is y or (x == y and isinstance(x, (int, bool, Symbol)))))
|
|
d(S('assv'), lambda a, _: _assoc(a[0], a[1], lambda x, y: x == y))
|
|
d(S('assoc'), lambda a, _: _assoc(a[0], a[1], _equal))
|
|
d(S('flatten'), lambda a, _: _P(_flatten(_L(a[0]))))
|
|
d(S('zip'), lambda a, _: _P([_P(list(row)) for row in zip(*[_L(lst) for lst in a])]))
|
|
d(S('take'), lambda a, _: _P(list(_L(a[0]))[:int(_num(a[1]))]))
|
|
d(S('drop'), lambda a, _: _P(list(_L(a[0]))[int(_num(a[1])):]))
|
|
d(S('take-while'), lambda a, e: _P(list(_takewhile(a[0], _L(a[1]), e))))
|
|
d(S('drop-while'), lambda a, e: _P(list(_dropwhile(a[0], _L(a[1]), e))))
|
|
d(S('list-index'), lambda a, e: next((i for i, x in enumerate(_L(a[1])) if _truthy(_call(a[0], [x], e))), False))
|
|
d(S('delete'), lambda a, e: _P([x for x in _L(a[1]) if not _equal(x, a[0])]))
|
|
d(S('delete-duplicates'), lambda a, _: _P(list({id(x) if isinstance(x, Pair) else x: x for x in _L(a[0])}.values())))
|
|
|
|
def _flatten(lst):
|
|
for x in lst:
|
|
if isinstance(x, Pair): yield from _flatten(list(x))
|
|
elif x is NIL: pass
|
|
else: yield x
|
|
|
|
def _takewhile(f, lst, env):
|
|
for x in lst:
|
|
if not _truthy(_call(f, [x], env)): break
|
|
yield x
|
|
|
|
def _dropwhile(f, lst, env):
|
|
dropping = True
|
|
for x in lst:
|
|
if dropping and _truthy(_call(f, [x], env)): continue
|
|
dropping = False; yield x
|
|
|
|
d(S('flatten'), lambda a, _: _P(list(_flatten(_L(a[0])))))
|
|
d(S('take-while'), lambda a, e: _P(list(_takewhile(a[0], _L(a[1]), e))))
|
|
d(S('drop-while'), lambda a, e: _P(list(_dropwhile(a[0], _L(a[1]), e))))
|
|
|
|
# ── SRFI-1 list library ───────────────────────────────────────────────────
|
|
def _take_right(lst, n):
|
|
items = _L(lst); return _P(items[max(0, len(items)-n):])
|
|
def _drop_right(lst, n):
|
|
items = _L(lst); return _P(items[:max(0, len(items)-n)])
|
|
def _lset_union(eq, lists):
|
|
result = []
|
|
for lst in lists:
|
|
for x in _L(lst):
|
|
if not any(_call(eq, [x, y], None) if callable(eq) else eq(x, y) for y in result):
|
|
result.append(x)
|
|
return _P(result)
|
|
def _lset_intersect(eq, a, b):
|
|
bl = _L(b)
|
|
return _P([x for x in _L(a) if any(_equal(x, y) for y in bl)])
|
|
def _lset_diff(eq, a, b):
|
|
bl = _L(b)
|
|
return _P([x for x in _L(a) if not any(_equal(x, y) for y in bl)])
|
|
def _unfold(pred, f, g, seed, env):
|
|
result = []
|
|
while not _truthy(_call(pred, [seed], env)):
|
|
result.append(_call(f, [seed], env))
|
|
seed = _call(g, [seed], env)
|
|
return _P(result)
|
|
|
|
d(S('take-right'), lambda a, _: _take_right(a[0], int(_num(a[1]))))
|
|
d(S('drop-right'), lambda a, _: _drop_right(a[0], int(_num(a[1]))))
|
|
d(S('last'), lambda a, _: _L(a[0])[-1])
|
|
d(S('first'), lambda a, _: _pair_val(a[0]).car)
|
|
d(S('second'), lambda a, _: list(a[0])[1])
|
|
d(S('third'), lambda a, _: list(a[0])[2])
|
|
d(S('fourth'), lambda a, _: list(a[0])[3])
|
|
d(S('fifth'), lambda a, _: list(a[0])[4])
|
|
d(S('concatenate'), lambda a, _: _append(_L(a[0])))
|
|
d(S('list-tabulate'), lambda a, e: _P([_call(a[1],[i],e) for i in range(int(_num(a[0])))]))
|
|
d(S('reduce-right'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=False))
|
|
d(S('unfold'), lambda a, e: _unfold(a[0], a[1], a[2], a[3], e))
|
|
d(S('lset-union'), lambda a, e: _lset_union(a[0], a[1:]))
|
|
d(S('lset-intersection'), lambda a, e: _lset_intersect(a[0], a[1], a[2]))
|
|
d(S('lset-difference'), lambda a, e: _lset_diff(a[0], a[1], a[2]))
|
|
d(S('proper-list?'), lambda a, _: _is_proper_list(a[0]))
|
|
d(S('dotted-list?'), lambda a, _: (lambda n=a[0]: not _is_proper_list(n) and (isinstance(n, Pair) or not isinstance(n, _Nil)))())
|
|
d(S('null-list?'), lambda a, _: a[0] is NIL)
|
|
d(S('alist-cons'), lambda a, _: Pair(Pair(a[0], a[1]), a[2]))
|
|
d(S('alist-copy'), lambda a, _: _P([Pair(p.car, p.cdr) for p in _L(a[0])]))
|
|
d(S('pair-for-each'), lambda a, e: [(lambda p: _call(a[0],[p],e))(p) for p in _L(a[1])] and VOID)
|
|
d(S('append!'), lambda a, _: _append(a)) # non-destructive fallback
|
|
d(S('delete'), lambda a, e: _P([x for x in _L(a[1]) if not _equal(x, a[0])]))
|
|
d(S('delete!'), lambda a, e: _P([x for x in _L(a[1]) if not _equal(x, a[0])]))
|
|
def _dedup(lst):
|
|
seen = []; r = []
|
|
for x in _L(lst):
|
|
if not any(_equal(x, y) for y in seen): seen.append(x); r.append(x)
|
|
return _P(r)
|
|
d(S('delete-duplicates'), lambda a, _: _dedup(a[0]))
|
|
|
|
# caaar..cddddr — auto-generate
|
|
for combo in ['aa','ad','da','dd',
|
|
'aaa','aad','ada','add','daa','dad','dda','ddd',
|
|
'aaaa','aaad','aada','aadd','adaa','adad','adda','addd',
|
|
'daaa','daad','dada','dadd','ddaa','ddad','ddda','dddd']:
|
|
def _cxr(a, _, c=combo):
|
|
x = a[0]
|
|
for ch in reversed(c):
|
|
x = _pair_val(x).car if ch == 'a' else _pair_val(x).cdr
|
|
return x
|
|
d(S('c' + combo + 'r'), _cxr)
|
|
|
|
# ── Higher-order ──────────────────────────────────────────────────────────
|
|
def _map(f, lists, env):
|
|
rows = [_L(lst) for lst in lists]
|
|
return _P([_call(f, list(col), env) for col in zip(*rows)])
|
|
|
|
def _for_each(f, lists, env):
|
|
rows = [_L(lst) for lst in lists]
|
|
for col in zip(*rows): _call(f, list(col), env)
|
|
|
|
def _fold(f, init, lst, env, left=True):
|
|
acc = init
|
|
items = lst if left else reversed(lst)
|
|
for x in items: acc = _call(f, [x, acc], env)
|
|
return acc
|
|
|
|
d(S('map'), lambda a, e: _map(a[0], a[1:], e))
|
|
d(S('for-each'), lambda a, e: _for_each(a[0], a[1:], e) or VOID)
|
|
d(S('filter'), lambda a, e: _P([x for x in _L(a[1]) if _truthy(_call(a[0], [x], e))]))
|
|
d(S('filter-map'), lambda a, e: _P([v for x in _L(a[1]) for v in [_call(a[0],[x],e)] if _truthy(v)]))
|
|
d(S('fold-left'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=True))
|
|
d(S('fold-right'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=False))
|
|
d(S('foldl'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=True))
|
|
d(S('foldr'), lambda a, e: _fold(a[0], a[1], _L(a[2]), e, left=False))
|
|
d(S('reduce'), lambda a, e: (lambda lst: _fold(a[0], lst[0], lst[1:], e))(_L(a[2])) if _L(a[2]) else a[1])
|
|
d(S('any'), lambda a, e: next((x for x in _L(a[1]) if _truthy(_call(a[0],[x],e))), False))
|
|
d(S('every'), lambda a, e: next((False for x in _L(a[1]) if not _truthy(_call(a[0],[x],e))), True))
|
|
d(S('count'), lambda a, e: sum(1 for x in _L(a[1]) if _truthy(_call(a[0],[x],e))))
|
|
d(S('flat-map'), lambda a, e: _append([_call(a[0],[x],e) for x in _L(a[1])]))
|
|
d(S('append-map'), lambda a, e: _append([_call(a[0],[x],e) for x in _L(a[1])]))
|
|
d(S('sort'), lambda a, e: _P(sorted(_L(a[0]))))
|
|
d(S('sort-by'), lambda a, e: _P(sorted(_L(a[1]), key=lambda x: _call(a[0],[x],e))))
|
|
d(S('group-by'), lambda a, e: _group_by(a[0], _L(a[1]), e))
|
|
d(S('partition'), lambda a, e: (lambda yes,no: (yes, no))(*_partition(a[0], _L(a[1]), e)))
|
|
d(S('find'), lambda a, e: next((x for x in _L(a[1]) if _truthy(_call(a[0],[x],e))), False))
|
|
|
|
def _group_by(f, lst, env):
|
|
groups = {}; order = []
|
|
for x in lst:
|
|
k = _call(f, [x], env)
|
|
if k not in groups: groups[k] = []; order.append(k)
|
|
groups[k].append(x)
|
|
return _P([Pair(k, _P(groups[k])) for k in order])
|
|
|
|
def _partition(f, lst, env):
|
|
yes, no = [], []
|
|
for x in lst:
|
|
(yes if _truthy(_call(f,[x],env)) else no).append(x)
|
|
return _P(yes), _P(no)
|
|
|
|
d(S('group-by'), lambda a, e: _group_by(a[0], _L(a[1]), e))
|
|
d(S('partition'), lambda a, e: (lambda r: _P([r[0], r[1]]))(_partition(a[0], _L(a[1]), e)))
|
|
|
|
# Functional utilities
|
|
def _compose(fns):
|
|
if not fns: return lambda a, e: a[0]
|
|
def composed(args, env):
|
|
result = _call(fns[-1], args, env)
|
|
for f in reversed(fns[:-1]): result = _call(f, [result], env)
|
|
return result
|
|
return composed
|
|
|
|
d(S('compose'), lambda a, e: _compose(a))
|
|
d(S('identity'), lambda a, _: a[0])
|
|
d(S('const'), lambda a, e: (lambda v: (lambda b, _: v))(a[0]))
|
|
d(S('negate'), lambda a, e: (lambda f: lambda b, _: not _truthy(_call(f, b, e)))(a[0]))
|
|
d(S('complement'), lambda a, e: (lambda f: lambda b, _: not _truthy(_call(f, b, e)))(a[0]))
|
|
d(S('flip'), lambda a, e: (lambda f: lambda b, _: _call(f, [b[1],b[0]], e))(a[0]))
|
|
d(S('curry'), lambda a, e: (lambda f, x: lambda b, _: _call(f, [x]+b, e))(a[0], a[1]))
|
|
d(S('constantly'), lambda a, _: (lambda v: (lambda b, _: v))(a[0]))
|
|
d(S('apply'), lambda a, e: _call(a[0], (_L(a[-1]) if len(a)==2 else [leval(x,e) for x in a[1:-1]] + _L(a[-1])), e))
|
|
|
|
# ── Strings ───────────────────────────────────────────────────────────────
|
|
d(S('make-string'), lambda a, _: (a[1] if len(a) > 1 else ' ') * int(_num(a[0])))
|
|
d(S('string'), lambda a, _: ''.join(a))
|
|
d(S('string-length'), lambda a, _: len(_str_val(a[0])))
|
|
d(S('string-ref'), lambda a, _: _str_val(a[0])[int(_num(a[1]))])
|
|
d(S('substring'), lambda a, _: _str_val(a[0])[int(_num(a[1])): int(_num(a[2])) if len(a) > 2 else None])
|
|
d(S('string-append'), lambda a, _: ''.join(_str_val(x) for x in a))
|
|
d(S('string-copy'), lambda a, _: _str_val(a[0]))
|
|
d(S('string->list'), lambda a, _: _P(list(_str_val(a[0]))))
|
|
d(S('list->string'), lambda a, _: ''.join(_L(a[0])))
|
|
d(S('string->symbol'), lambda a, _: S(_str_val(a[0])))
|
|
d(S('symbol->string'), lambda a, _: str(_sym_val(a[0])))
|
|
d(S('string->number'), lambda a, _: _str_to_num(a))
|
|
d(S('string-upcase'), lambda a, _: _str_val(a[0]).upper())
|
|
d(S('string-downcase'), lambda a, _: _str_val(a[0]).lower())
|
|
d(S('string-contains'),lambda a, _: _str_val(a[1]) in _str_val(a[0]))
|
|
d(S('string-prefix?'), lambda a, _: _str_val(a[1]).startswith(_str_val(a[0])))
|
|
d(S('string-suffix?'), lambda a, _: _str_val(a[1]).endswith(_str_val(a[0])))
|
|
d(S('string-split'), lambda a, _: _P(_str_val(a[0]).split(_str_val(a[1]) if len(a)>1 else None)))
|
|
d(S('string-join'), lambda a, _: (_str_val(a[1]) if len(a)>1 else ' ').join(_L(a[0])))
|
|
d(S('string-trim'), lambda a, _: _str_val(a[0]).strip())
|
|
d(S('string-trim-right'),lambda a, _: _str_val(a[0]).rstrip())
|
|
d(S('string-replace'), lambda a, _: _str_val(a[0]).replace(_str_val(a[1]), _str_val(a[2])))
|
|
d(S('string-index'), lambda a, _: _str_val(a[0]).find(_str_val(a[1])))
|
|
d(S('string=?'), lambda a, _: _str_val(a[0]) == _str_val(a[1]))
|
|
d(S('string<?'), lambda a, _: _str_val(a[0]) < _str_val(a[1]))
|
|
d(S('string>?'), lambda a, _: _str_val(a[0]) > _str_val(a[1]))
|
|
d(S('string<=?'), lambda a, _: _str_val(a[0]) <= _str_val(a[1]))
|
|
d(S('string>=?'), lambda a, _: _str_val(a[0]) >= _str_val(a[1]))
|
|
d(S('string-ci=?'), lambda a, _: _str_val(a[0]).lower() == _str_val(a[1]).lower())
|
|
d(S('format'), lambda a, _: _format(a))
|
|
d(S('string-format'), lambda a, _: _format(a))
|
|
|
|
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
|
|
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))
|
|
|
|
# ── Symbols ───────────────────────────────────────────────────────────────
|
|
d(S('gensym'), lambda a, _: S(f'g{next(_gensym_ctr)}'))
|
|
|
|
# ── Characters ───────────────────────────────────────────────────────────
|
|
d(S('char->integer'), lambda a, _: ord(a[0]))
|
|
d(S('integer->char'), lambda a, _: chr(int(_num(a[0]))))
|
|
d(S('char-alphabetic?'), lambda a, _: a[0].isalpha())
|
|
d(S('char-numeric?'), lambda a, _: a[0].isdigit())
|
|
d(S('char-whitespace?'), lambda a, _: a[0].isspace())
|
|
d(S('char-upper-case?'), lambda a, _: a[0].isupper())
|
|
d(S('char-lower-case?'), lambda a, _: a[0].islower())
|
|
d(S('char-upcase'), lambda a, _: a[0].upper())
|
|
d(S('char-downcase'), lambda a, _: a[0].lower())
|
|
d(S('char=?'), lambda a, _: a[0] == a[1])
|
|
d(S('char<?'), lambda a, _: a[0] < a[1])
|
|
d(S('char>?'), lambda a, _: a[0] > a[1])
|
|
d(S('char<=?'), lambda a, _: a[0] <= a[1])
|
|
d(S('char>=?'), lambda a, _: a[0] >= a[1])
|
|
d(S('char-ci=?'),lambda a, _: a[0].lower() == a[1].lower())
|
|
|
|
# ── Vectors ───────────────────────────────────────────────────────────────
|
|
d(S('make-vector'), lambda a, _: [a[1] if len(a) > 1 else 0] * int(_num(a[0])))
|
|
d(S('vector'), lambda a, _: list(a))
|
|
d(S('vector-length'),lambda a, _: len(a[0]))
|
|
d(S('vector-ref'), lambda a, _: a[0][int(_num(a[1]))])
|
|
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][ 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)
|
|
d(S('vector-append'),lambda a, _: sum((v for v in a), []))
|
|
d(S('vector->string'),lambda a, _: ''.join(a[0]))
|
|
d(S('string->vector'),lambda a, _: list(_str_val(a[0])))
|
|
|
|
# ── Hash tables ───────────────────────────────────────────────────────────
|
|
d(S('make-hash-table'), lambda a, _: {})
|
|
d(S('make-equal-hash-table'), lambda a, _: {})
|
|
d(S('hash-table?'), lambda a, _: isinstance(a[0], dict))
|
|
d(S('hash-table-set!'), lambda a, _: a[0].__setitem__(a[1], a[2]) or VOID)
|
|
d(S('hash-table/put!'), lambda a, _: a[0].__setitem__(a[1], a[2]) or VOID)
|
|
d(S('hash-table-ref'), lambda a, e: a[0][a[1]] if a[1] in a[0] else (_call(a[2],[],e) if len(a)>2 else _raise(LispErr(f'hash-table-ref: missing key: {show(a[1])}'))))
|
|
d(S('hash-table-ref/default'), lambda a, _: a[0].get(a[1], a[2]))
|
|
d(S('hash-table/get'), lambda a, _: a[0].get(a[1], a[2]))
|
|
d(S('hash-table-delete!'),lambda a,_: a[0].pop(a[1], None) or VOID)
|
|
d(S('hash-table-exists?'),lambda a,_: a[1] in a[0])
|
|
d(S('hash-table/count'), lambda a, _: len(a[0]))
|
|
d(S('hash-table-size'), lambda a, _: len(a[0]))
|
|
d(S('hash-table-keys'), lambda a, _: _P(list(a[0].keys())))
|
|
d(S('hash-table-values'),lambda a, _: _P(list(a[0].values())))
|
|
d(S('hash-table->alist'),lambda a, _: _P([Pair(k, v) for k, v in a[0].items()]))
|
|
d(S('alist->hash-table'),lambda a, _: dict((p.car, p.cdr) for p in _L(a[0])))
|
|
d(S('hash-table-walk'), lambda a, e: [_call(a[1],[k,v],e) for k,v in a[0].items()] and VOID)
|
|
d(S('hash-table-merge!'),lambda a, _: a[0].update(a[1]) or a[0])
|
|
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 ───────────────────────────────────────────────────────────────────
|
|
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, _: ((_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, _: 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_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()
|
|
exprs = read_all(line)
|
|
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()
|
|
old = sys.stdout; sys.stdout = buf
|
|
try: _call(thunk, [], env)
|
|
finally: sys.stdout = old
|
|
return buf.getvalue()
|
|
|
|
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)))(
|
|
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-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]))
|
|
d(S('values'), lambda a, _: a[0] if len(a) == 1 else tuple(a))
|
|
d(S('call-with-values'), lambda a, e: (lambda r: _call(a[1], list(r) if isinstance(r, tuple) else [r], e))(_call(a[0],[],e)))
|
|
d(S('dynamic-wind'), lambda a, e: (_call(a[0],[],e), r := _call(a[1],[],e), _call(a[2],[],e), r)[-1])
|
|
d(S('make-parameter'),lambda a, e: _make_parameter(a[0], a[1] if len(a)>1 else None, e))
|
|
d(S('procedure?'), lambda a, _: isinstance(a[0], Proc) or (callable(a[0]) and not isinstance(a[0], (bool, type))))
|
|
d(S('procedure-arity'), lambda a, _: len(a[0].params) if isinstance(a[0], Proc) else -1)
|
|
d(S('procedure-name'), lambda a, _: a[0].name or False if isinstance(a[0], Proc) else False)
|
|
|
|
def _make_parameter(init, converter, env):
|
|
box = [_call(converter, [init], env) if converter else init]
|
|
def param(args, env_):
|
|
if not args: return box[0]
|
|
box[0] = _call(converter, [args[0]], env_) if converter else args[0]
|
|
return VOID
|
|
return param
|
|
|
|
d(S('make-parameter'), lambda a, e: _make_parameter(a[0], a[1] if len(a)>1 else None, e))
|
|
|
|
# String representation
|
|
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])))
|
|
d(S('py-exec'), lambda a, _: exec(_str_val(a[0])) or VOID)
|
|
d(S('py-import'), lambda a, _: __import__(_str_val(a[0])))
|
|
d(S('py-call'), lambda a, _: a[0](*a[1:]))
|
|
d(S('py-attr'), lambda a, _: getattr(a[0], _str_val(a[1])))
|
|
|
|
# Constants
|
|
d(S('pi'), math.pi)
|
|
d(S('e'), math.e)
|
|
d(S('else'), True)
|
|
d(S('...'), S('...'))
|
|
d(S('*version*'), '1.0.0')
|
|
d(S('*name*'), 'uncommonlisp')
|
|
|
|
return g
|
|
|
|
###############################################################################
|
|
# Prelude (standard macros defined in Lisp)
|
|
###############################################################################
|
|
|
|
PRELUDE = r"""
|
|
(define-macro (when test . body)
|
|
`(if ,test (begin ,@body) (void)))
|
|
|
|
(define-macro (unless test . body)
|
|
`(if ,test (void) (begin ,@body)))
|
|
|
|
(define-macro (and . args)
|
|
(cond ((null? args) #t)
|
|
((null? (cdr args)) (car args))
|
|
(else `(if ,(car args) (and ,@(cdr args)) #f))))
|
|
|
|
(define-macro (or . args)
|
|
(cond ((null? args) #f)
|
|
((null? (cdr args)) (car args))
|
|
(else (let ((v (gensym)))
|
|
`(let ((,v ,(car args)))
|
|
(if ,v ,v (or ,@(cdr args))))))))
|
|
|
|
(define-macro (case key . clauses)
|
|
(let ((k (gensym)))
|
|
`(let ((,k ,key))
|
|
(cond ,@(map (lambda (c)
|
|
(if (eq? (car c) 'else)
|
|
(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)
|
|
(let ((loop (gensym)))
|
|
`(let ,loop ()
|
|
(when ,test ,@body (,loop)))))
|
|
|
|
(define-macro (for var lst . body)
|
|
`(for-each (lambda (,var) ,@body) ,lst))
|
|
|
|
; 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 (1+ n) (+ n 1))
|
|
(define (1- n) (- n 1))
|
|
(define (-1+ n) (- n 1))
|
|
(define (add1 n) (+ n 1))
|
|
(define (sub1 n) (- n 1))
|
|
|
|
(define (square x) (* x x))
|
|
(define (cube x) (* x x x))
|
|
|
|
(define (compose . fns)
|
|
(if (null? fns)
|
|
identity
|
|
(let ((fn (car fns))
|
|
(rest (apply compose (cdr fns))))
|
|
(lambda args (fn (apply rest args))))))
|
|
|
|
(define (atom? x) (not (pair? x)))
|
|
|
|
(define (flatten lst)
|
|
(cond ((null? lst) '())
|
|
((pair? (car lst)) (append (flatten (car lst)) (flatten (cdr lst))))
|
|
(else (cons (car lst) (flatten (cdr lst))))))
|
|
|
|
(define (range . args)
|
|
(cond ((= (length args) 1) (iota (car args)))
|
|
((= (length args) 2) (iota (- (cadr args) (car args)) (car args)))
|
|
((= (length args) 3) (iota (ceiling (/ (- (cadr args) (car args)) (caddr args)))
|
|
(car args) (caddr args)))
|
|
(else (error "range: wrong number of args"))))
|
|
|
|
(define (list-flatten lst)
|
|
(cond ((null? lst) '())
|
|
((pair? (car lst))
|
|
(append (list-flatten (car lst)) (list-flatten (cdr lst))))
|
|
(else (cons (car lst) (list-flatten (cdr lst))))))
|
|
|
|
(define (char-list->string chars)
|
|
(apply string chars))
|
|
|
|
(define (string-for-each f s)
|
|
(for-each f (string->list s)))
|
|
|
|
(define (string-map f s)
|
|
(list->string (map f (string->list s))))
|
|
|
|
(define (with-values thunk receiver)
|
|
(call-with-values thunk receiver))
|
|
|
|
(define (char->string c) (string c))
|
|
|
|
(define (boolean->string b) (if b "#t" "#f"))
|
|
|
|
(define (exact-integer? x) (and (integer? x) (exact? x)))
|
|
|
|
(define (assoc* key alist)
|
|
(cond ((null? alist) #f)
|
|
((equal? (caar alist) key) (car alist))
|
|
(else (assoc* key (cdr alist)))))
|
|
|
|
(define (alist-set! key val alist)
|
|
(let ((pair (assoc key alist)))
|
|
(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)))
|
|
"""
|
|
|
|
###############################################################################
|
|
# REPL
|
|
###############################################################################
|
|
|
|
def repl(env, prompt='λ> ', quiet=False):
|
|
if not quiet:
|
|
print(f'uncommonlisp {env.lookup(S("*version*"))} '
|
|
f'— (exit) to quit, (load "file.lsp") to load')
|
|
buf = ''
|
|
while True:
|
|
try:
|
|
line = input(prompt if not buf else ' ')
|
|
except (EOFError, KeyboardInterrupt):
|
|
if buf:
|
|
buf = ''; print(); continue
|
|
print(); break
|
|
buf += line + '\n'
|
|
# Try parsing; if incomplete, keep reading
|
|
try:
|
|
exprs = read_all(buf)
|
|
except LispErr:
|
|
continue # keep accumulating
|
|
if not exprs:
|
|
buf = ''; continue
|
|
# Check for unbalanced parens by counting
|
|
depth = 0
|
|
for ch in buf:
|
|
if ch == '(': depth += 1
|
|
elif ch == ')': depth -= 1
|
|
if depth > 0:
|
|
continue # incomplete expression
|
|
for expr in exprs:
|
|
try:
|
|
result = leval(expr, env)
|
|
if result is not VOID:
|
|
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 = ''
|
|
|
|
###############################################################################
|
|
# Main
|
|
###############################################################################
|
|
|
|
def main():
|
|
g = make_global_env()
|
|
# Load prelude
|
|
for expr in read_all(PRELUDE):
|
|
leval(expr, g)
|
|
|
|
args = sys.argv[1:]
|
|
|
|
# -e 'expr' mode
|
|
if args and args[0] == '-e':
|
|
if len(args) < 2:
|
|
print('usage: uncommonlisp -e <expression>', file=sys.stderr)
|
|
sys.exit(1)
|
|
for expr in read_all(args[1]):
|
|
result = leval(expr, g)
|
|
if result is not VOID:
|
|
print(show(result))
|
|
return
|
|
|
|
# Script mode
|
|
if args:
|
|
path = args[0]
|
|
g.define(S('*argv*'), _P(args[1:]))
|
|
try:
|
|
_load(path, g)
|
|
except LispErr as e:
|
|
print(f'error: {e}', file=sys.stderr); sys.exit(1)
|
|
except FileNotFoundError:
|
|
print(f'file not found: {path}', file=sys.stderr); sys.exit(1)
|
|
return
|
|
|
|
# REPL mode
|
|
repl(g)
|
|
|
|
if __name__ == '__main__':
|
|
main()
|