russell@unturf.com
f72190d2dc
Single-file Scheme-like Lisp interpreter in Python with: - TCO via explicit while loop (no Python stack overflow at any depth) - syntax-rules with ellipsis for hygienic macros - define-macro for procedural macros - Full numeric tower, strings, chars, vectors, hash tables - SRFI-1 list library - call/cc (escape continuations), values, dynamic-wind, guard - Python interop (py-eval, py-import, py-call, py-attr) - 396 passing unit/integration/functional tests - stdlib.lsp with 60+ utility functions - Benchmark suite vs CPython baseline
1523 lines
66 KiB
Python
1523 lines
66 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
|
|
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)) + ')'
|
|
|
|
class Proc:
|
|
__slots__ = ('params', 'rest', 'body', 'env', 'name')
|
|
def __init__(self, params, rest, body, env, name=None):
|
|
self.params = params; self.rest = rest
|
|
self.body = body; self.env = env; self.name = name
|
|
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): pass
|
|
|
|
###############################################################################
|
|
# 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, 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'
|
|
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')
|
|
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
|
|
|
|
###############################################################################
|
|
# 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 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)
|
|
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
|
|
|
|
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
|
|
|
|
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))
|
|
env = c; expr = Pair(S('begin'), _P(a[1:])); 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)
|
|
expr = Pair(S('begin'), _P(proc.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 = [show(leval(x, env)) for x in a[1:]]
|
|
raise LispErr(msg + (': ' + ' '.join(irr) if irr else ''))
|
|
|
|
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'):
|
|
# simplified: just bind and restore
|
|
a = _L(tail); binds = _L(a[0]); body = a[1:]
|
|
saves = [(leval(bp[0], env), _L(bp)) for bp in binds]
|
|
for param, bp in saves:
|
|
if callable(param): param([leval(bp[1], env)], env)
|
|
try:
|
|
for e in body[:-1]: leval(e, env)
|
|
return leval(body[-1], env)
|
|
finally:
|
|
for param, bp in saves:
|
|
if callable(param): param([_call(param, [], env)], env)
|
|
|
|
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, [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, 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)
|
|
expr = Pair(S('begin'), _P(proc.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)
|
|
for e in proc.body[:-1]: leval(e, c)
|
|
return leval(proc.body[-1], c)
|
|
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()
|
|
|
|
def _num(x):
|
|
if isinstance(x, bool) or not isinstance(x, (int, float)):
|
|
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
|
|
if type(a) is not type(b) and not (isinstance(a, (int, float)) and isinstance(b, (int, float))): 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 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 _div(a, _):
|
|
if not a: raise LispErr('/: no args')
|
|
if len(a) == 1: return 1 / _num(a[0])
|
|
n = _num(a[0])
|
|
for x in a[1:]: n /= _num(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, _: int(_num(a[0])) 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('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]))
|
|
|
|
# ── 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)) 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('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
|
|
try: return int(s, base)
|
|
except ValueError: pass
|
|
try: return float(s)
|
|
except ValueError: 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]))
|
|
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 ───────────────────────────────────────────────────────────────────
|
|
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)
|
|
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('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('with-output-to-string'), lambda a, e: _output_to_string(a[0], e))
|
|
|
|
def _read_line():
|
|
try:
|
|
line = sys.stdin.readline()
|
|
return EOF if not line else line.rstrip('\n')
|
|
except EOFError: return EOF
|
|
|
|
def _read_one():
|
|
try:
|
|
line = input()
|
|
exprs = read_all(line)
|
|
return exprs[0] if exprs else EOF
|
|
except EOFError: return EOF
|
|
|
|
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))
|
|
|
|
# ── 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('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]))
|
|
|
|
# ── 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))
|
|
|
|
# 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)
|
|
c
|
|
`((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-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 (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))
|
|
(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))))
|
|
"""
|
|
|
|
###############################################################################
|
|
# 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)
|
|
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()
|