diff --git a/hosts/javascript/platform.py b/hosts/javascript/platform.py index 5abc372f..3cef3514 100644 --- a/hosts/javascript/platform.py +++ b/hosts/javascript/platform.py @@ -842,6 +842,23 @@ PREAMBLE = '''\ if (a === b) return true; if (a && b && a._sym && b._sym) return a.name === b.name; if (a && b && a._kw && b._kw) return a.name === b.name; + if (a && b && a._vector && b._vector) { + if (a.arr.length !== b.arr.length) return false; + for (var _i = 0; _i < a.arr.length; _i++) { + if (!sxEq(a.arr[_i], b.arr[_i])) return false; + } + return true; + } + if (Array.isArray(a) && Array.isArray(b)) { + if (a.length !== b.length) return false; + for (var _j = 0; _j < a.length; _j++) { + if (!sxEq(a[_j], b[_j])) return false; + } + return true; + } + if (a && b && a._rational && b._rational) return a._n === b._n && a._d === b._d; + if (a && a._rational && typeof b === "number") return b === a._n / a._d; + if (b && b._rational && typeof a === "number") return a === b._n / b._d; return false; } @@ -908,6 +925,45 @@ PREAMBLE = '''\ function SxSpread(attrs) { this.attrs = attrs || {}; } SxSpread.prototype._spread = true; + function SxVector(arr) { this.arr = arr || []; } + SxVector.prototype._vector = true; + + var _paramUidCounter = 0; + function SxParameter(defaultVal, converter) { + this._uid = ++_paramUidCounter; + this._default = defaultVal; + this._converter = converter || null; + } + SxParameter.prototype._parameter = true; + function parameter_p(x) { return x != null && x._parameter === true; } + function parameterUid(p) { return p._uid; } + function parameterDefault(p) { return p._default; } + + function SxCallccContinuation(capturedKont, windersLen) { this._captured = capturedKont; this._winders_len = windersLen !== undefined ? windersLen : 0; } + SxCallccContinuation.prototype._callcc = true; + function makeCallccContinuation(kont, windersLen) { return new SxCallccContinuation(kont, windersLen !== undefined ? windersLen : 0); } + function callccContinuation_p(x) { return x != null && x._callcc === true; } + function callccContinuationData(x) { return x._captured; } + function callccContinuationWindersLen(x) { return x._winders_len !== undefined ? x._winders_len : 0; } + + function evalError_p(v) { + return v != null && typeof v === "object" && v["__eval_error__"] === true; + } + + function sxApplyCek(f, args) { + try { + return typeof f === "function" ? f.apply(null, args) : f; + } catch (e) { + if (e && e._perform_request) throw e; + if (e && e._cek_suspend) throw e; + return {"__eval_error__": true, "message": e && e.message ? e.message : String(e)}; + } + } + + var _JIT_SKIP_SENTINEL = {"__jit_skip": true}; + function jitTryCall(f, args) { return _JIT_SKIP_SENTINEL; } + function jitSkip_p(v) { return v === _JIT_SKIP_SENTINEL || (v != null && v["__jit_skip"] === true); } + var _scopeStacks = {}; function isSym(x) { return x != null && x._sym === true; } @@ -931,10 +987,68 @@ PREAMBLE = '''\ PRIMITIVES_JS_MODULES: dict[str, str] = { "core.arithmetic": ''' // core.arithmetic - PRIMITIVES["+"] = function() { var s = 0; for (var i = 0; i < arguments.length; i++) s += arguments[i]; return s; }; - PRIMITIVES["-"] = function(a, b) { return arguments.length === 1 ? -a : a - b; }; - PRIMITIVES["*"] = function() { var s = 1; for (var i = 0; i < arguments.length; i++) s *= arguments[i]; return s; }; - PRIMITIVES["/"] = function(a, b) { return a / b; }; + function _ratMake(n, d) { + if (d === 0) throw new Error("division by zero"); + var r = new SxRational(n, d); + return r._d === 1 ? r._n : r; + } + function _ratN(x) { return x && x._rational ? x._n : x; } + function _ratD(x) { return x && x._rational ? x._d : 1; } + function _hasFloat(args) { + for (var i = 0; i < args.length; i++) { + var x = args[i]; + if (typeof x === "number" && !Number.isInteger(x)) return true; + } + return false; + } + function _ratToFloat(x) { return x && x._rational ? x._n / x._d : x; } + PRIMITIVES["+"] = function() { + var hasRat = false; + for (var i = 0; i < arguments.length; i++) if (arguments[i] && arguments[i]._rational) { hasRat = true; break; } + if (!hasRat) { var s = 0; for (var i = 0; i < arguments.length; i++) s += arguments[i]; return s; } + if (_hasFloat(arguments)) { var s = 0; for (var i = 0; i < arguments.length; i++) s += _ratToFloat(arguments[i]); return s; } + var an = 0, ad = 1; + for (var i = 0; i < arguments.length; i++) { + var bn = _ratN(arguments[i]), bd = _ratD(arguments[i]); + an = an * bd + bn * ad; ad = ad * bd; + } + return _ratMake(an, ad); + }; + PRIMITIVES["-"] = function() { + if (arguments.length === 0) return 0; + var hasRat = false; + for (var i = 0; i < arguments.length; i++) if (arguments[i] && arguments[i]._rational) { hasRat = true; break; } + if (!hasRat) return arguments.length === 1 ? -arguments[0] : arguments[0] - arguments[1]; + if (_hasFloat(arguments)) { + if (arguments.length === 1) return -_ratToFloat(arguments[0]); + var s = _ratToFloat(arguments[0]); + for (var i = 1; i < arguments.length; i++) s -= _ratToFloat(arguments[i]); + return s; + } + if (arguments.length === 1) { var x = arguments[0]; return x._rational ? _ratMake(-x._n, x._d) : -x; } + var an = _ratN(arguments[0]), ad = _ratD(arguments[0]); + for (var i = 1; i < arguments.length; i++) { + var bn = _ratN(arguments[i]), bd = _ratD(arguments[i]); + an = an * bd - bn * ad; ad = ad * bd; + } + return _ratMake(an, ad); + }; + PRIMITIVES["*"] = function() { + var hasRat = false; + for (var i = 0; i < arguments.length; i++) if (arguments[i] && arguments[i]._rational) { hasRat = true; break; } + if (!hasRat) { var s = 1; for (var i = 0; i < arguments.length; i++) s *= arguments[i]; return s; } + if (_hasFloat(arguments)) { var s = 1; for (var i = 0; i < arguments.length; i++) s *= _ratToFloat(arguments[i]); return s; } + var an = 1, ad = 1; + for (var i = 0; i < arguments.length; i++) { an *= _ratN(arguments[i]); ad *= _ratD(arguments[i]); } + return _ratMake(an, ad); + }; + PRIMITIVES["/"] = function(a, b) { + var aRat = a && a._rational, bRat = b && b._rational; + if (!aRat && !bRat) return a / b; + if (typeof a === "number" && !Number.isInteger(a) || typeof b === "number" && !Number.isInteger(b)) + return _ratToFloat(a) / _ratToFloat(b); + return _ratMake(_ratN(a) * _ratD(b), _ratD(a) * _ratN(b)); + }; PRIMITIVES["mod"] = function(a, b) { return a % b; }; PRIMITIVES["inc"] = function(n) { return n + 1; }; PRIMITIVES["dec"] = function(n) { return n - 1; }; @@ -945,21 +1059,46 @@ PRIMITIVES_JS_MODULES: dict[str, str] = { if (n === undefined || n === 0) return Math.round(x); var f = Math.pow(10, n); return Math.round(x * f) / f; }; + PRIMITIVES["truncate"] = Math.trunc; + PRIMITIVES["remainder"] = function(a, b) { return a % b; }; + PRIMITIVES["modulo"] = function(a, b) { var r = a % b; return (r !== 0 && (r < 0) !== (b < 0)) ? r + b : r; }; PRIMITIVES["min"] = Math.min; PRIMITIVES["max"] = Math.max; PRIMITIVES["sqrt"] = Math.sqrt; PRIMITIVES["pow"] = Math.pow; PRIMITIVES["clamp"] = function(x, lo, hi) { return Math.max(lo, Math.min(hi, x)); }; + PRIMITIVES["random-int"] = function(lo, hi) { return Math.floor(Math.random() * (hi - lo + 1)) + lo; }; + PRIMITIVES["exact->inexact"] = function(x) { + if (x && x._rational) return x._n / x._d; + return x; + }; + PRIMITIVES["inexact->exact"] = Math.round; + PRIMITIVES["parse-number"] = function(s) { var n = Number(s); return isNaN(n) ? null : n; }; ''', "core.comparison": ''' // core.comparison + function _ratCmp(a, b) { + return _ratN(a) * _ratD(b) - _ratN(b) * _ratD(a); + } PRIMITIVES["="] = sxEq; PRIMITIVES["!="] = function(a, b) { return !sxEq(a, b); }; - PRIMITIVES["<"] = function(a, b) { return a < b; }; - PRIMITIVES[">"] = function(a, b) { return a > b; }; - PRIMITIVES["<="] = function(a, b) { return a <= b; }; - PRIMITIVES[">="] = function(a, b) { return a >= b; }; + PRIMITIVES["<"] = function(a, b) { + if ((a && a._rational) || (b && b._rational)) return _ratCmp(a, b) < 0; + return a < b; + }; + PRIMITIVES[">"] = function(a, b) { + if ((a && a._rational) || (b && b._rational)) return _ratCmp(a, b) > 0; + return a > b; + }; + PRIMITIVES["<="] = function(a, b) { + if ((a && a._rational) || (b && b._rational)) return _ratCmp(a, b) <= 0; + return a <= b; + }; + PRIMITIVES[">="] = function(a, b) { + if ((a && a._rational) || (b && b._rational)) return _ratCmp(a, b) >= 0; + return a >= b; + }; ''', "core.logic": ''' @@ -970,10 +1109,14 @@ PRIMITIVES_JS_MODULES: dict[str, str] = { "core.predicates": ''' // core.predicates PRIMITIVES["nil?"] = isNil; - PRIMITIVES["number?"] = function(x) { return typeof x === "number"; }; + PRIMITIVES["number?"] = function(x) { return typeof x === "number" || (x != null && x._rational === true); }; + PRIMITIVES["integer?"] = function(x) { return typeof x === "number" && Number.isInteger(x); }; + PRIMITIVES["float?"] = function(x) { return typeof x === "number" && !Number.isInteger(x); }; + PRIMITIVES["exact?"] = function(x) { return (typeof x === "number" && Number.isInteger(x)) || (x != null && x._rational === true); }; + PRIMITIVES["inexact?"] = function(x) { return typeof x === "number" && !Number.isInteger(x); }; PRIMITIVES["string?"] = function(x) { return typeof x === "string"; }; PRIMITIVES["list?"] = Array.isArray; - PRIMITIVES["dict?"] = function(x) { return x !== null && typeof x === "object" && !Array.isArray(x) && !x._sym && !x._kw; }; + PRIMITIVES["dict?"] = function(x) { return x !== null && typeof x === "object" && !Array.isArray(x) && !x._sym && !x._kw && !x._string_buffer && !x._vector && !x._hash_table && !x._rational; }; PRIMITIVES["empty?"] = function(c) { return isNil(c) || (Array.isArray(c) ? c.length === 0 : typeof c === "string" ? c.length === 0 : Object.keys(c).length === 0); }; PRIMITIVES["contains?"] = function(c, k) { if (typeof c === "string") return c.indexOf(String(k)) !== -1; @@ -1004,12 +1147,217 @@ PRIMITIVES_JS_MODULES: dict[str, str] = { PRIMITIVES["split"] = function(s, sep) { return String(s).split(sep || " "); }; PRIMITIVES["join"] = function(sep, coll) { return coll.join(sep); }; PRIMITIVES["replace"] = function(s, old, nw) { return s.split(old).join(nw); }; - PRIMITIVES["index-of"] = function(s, needle, from) { return String(s).indexOf(needle, from || 0); }; + PRIMITIVES["index-of"] = function(s, needle, from) { + if (Array.isArray(s)) { + var _start = from || 0; + for (var _i = _start; _i < s.length; _i++) { + var _a = s[_i]; + if (_a === needle) return _i; + if (_a != null && needle != null && typeof _a === "object" && typeof needle === "object") { + if ((_a._sym && needle._sym || _a._kw && needle._kw) && _a.name === needle.name) return _i; + } + } + return NIL; + } + return String(s).indexOf(needle, from || 0); + }; PRIMITIVES["starts-with?"] = function(s, p) { return String(s).indexOf(p) === 0; }; PRIMITIVES["ends-with?"] = function(s, p) { var str = String(s); return str.indexOf(p, str.length - p.length) !== -1; }; PRIMITIVES["slice"] = function(c, a, b) { if (!c || typeof c.slice !== "function") { console.error("[sx-debug] slice called on non-sliceable:", typeof c, c, "a=", a, "b=", b, new Error().stack); return []; } return b !== undefined ? c.slice(a, b) : c.slice(a); }; PRIMITIVES["substring"] = function(s, a, b) { return String(s).substring(a, b); }; PRIMITIVES["char-from-code"] = function(n) { return String.fromCharCode(n); }; + PRIMITIVES["char-code"] = function(s) { return String(s).charCodeAt(0); }; + var charCode = PRIMITIVES["char-code"]; + function makeChar(n) { return {_char: true, codepoint: n}; } + PRIMITIVES["make-char"] = makeChar; + var isChar = function(v) { return v != null && typeof v === "object" && v._char === true; }; + PRIMITIVES["char?"] = isChar; + var charToInteger = function(c) { return c.codepoint; }; + PRIMITIVES["char->integer"] = charToInteger; + var charUpcase = function(c) { return makeChar(String.fromCharCode(c.codepoint).toUpperCase().charCodeAt(0)); }; + PRIMITIVES["char-upcase"] = charUpcase; + var charDowncase = function(c) { return makeChar(String.fromCharCode(c.codepoint).toLowerCase().charCodeAt(0)); }; + PRIMITIVES["char-downcase"] = charDowncase; + PRIMITIVES["char=?"] = function(a, b) { return a.codepoint === b.codepoint; }; + PRIMITIVES["char?"] = function(a, b) { return a.codepoint > b.codepoint; }; + PRIMITIVES["char<=?"] = function(a, b) { return a.codepoint <= b.codepoint; }; + PRIMITIVES["char>=?"] = function(a, b) { return a.codepoint >= b.codepoint; }; + PRIMITIVES["char-ci=?"] = function(a, b) { return charDowncase(a).codepoint === charDowncase(b).codepoint; }; + PRIMITIVES["char-ci?"] = function(a, b) { return charDowncase(a).codepoint > charDowncase(b).codepoint; }; + PRIMITIVES["char-ci<=?"] = function(a, b) { return charDowncase(a).codepoint <= charDowncase(b).codepoint; }; + PRIMITIVES["char-ci>=?"] = function(a, b) { return charDowncase(a).codepoint >= charDowncase(b).codepoint; }; + PRIMITIVES["char-alphabetic?"] = function(c) { var n = c.codepoint; return (n >= 65 && n <= 90) || (n >= 97 && n <= 122); }; + PRIMITIVES["char-numeric?"] = function(c) { var n = c.codepoint; return n >= 48 && n <= 57; }; + PRIMITIVES["char-whitespace?"] = function(c) { var n = c.codepoint; return n === 32 || n === 9 || n === 10 || n === 13; }; + PRIMITIVES["char-upper-case?"] = function(c) { var n = c.codepoint; return n >= 65 && n <= 90; }; + PRIMITIVES["char-lower-case?"] = function(c) { var n = c.codepoint; return n >= 97 && n <= 122; }; + PRIMITIVES["string->list"] = function(s) { + var chars = []; var str = String(s); + for (var i = 0; i < str.length; i++) chars.push(makeChar(str.charCodeAt(i))); + return chars; + }; + PRIMITIVES["list->string"] = function(chars) { + return chars.map(function(c) { return String.fromCharCode(c.codepoint); }).join(''); + }; + // Phase 14: string ports + eof-object + var _eof = {_eof: true}; + PRIMITIVES["eof-object"] = function() { return _eof; }; + PRIMITIVES["eof-object?"] = function(v) { return v != null && v._eof === true; }; + var isEofObject = PRIMITIVES["eof-object?"]; + PRIMITIVES["open-input-string"] = function(s) { + return {_port: true, _kind: "input", _source: String(s), _pos: 0, _closed: false}; + }; + PRIMITIVES["open-output-string"] = function() { + return {_port: true, _kind: "output", _buffer: "", _closed: false}; + }; + PRIMITIVES["get-output-string"] = function(p) { + if (!p || p._kind !== "output") throw new Error("get-output-string: expected output port"); + return p._buffer; + }; + PRIMITIVES["port?"] = function(v) { return v != null && v._port === true; }; + PRIMITIVES["input-port?"] = function(v) { return v != null && v._port === true && v._kind === "input"; }; + PRIMITIVES["output-port?"] = function(v) { return v != null && v._port === true && v._kind === "output"; }; + PRIMITIVES["close-port"] = function(p) { + if (p && p._port) p._closed = true; + return NIL; + }; + PRIMITIVES["read-char"] = function(p) { + if (p === undefined || p === NIL || p == null) { + return _eof; // no stdin in this env + } + if (!p._port || p._kind !== "input") throw new Error("read-char: expected input port"); + if (p._closed || p._pos >= p._source.length) return _eof; + var cp = p._source.charCodeAt(p._pos); + p._pos++; + return makeChar(cp); + }; + PRIMITIVES["peek-char"] = function(p) { + if (p === undefined || p === NIL || p == null) return _eof; + if (!p._port || p._kind !== "input") throw new Error("peek-char: expected input port"); + if (p._closed || p._pos >= p._source.length) return _eof; + return makeChar(p._source.charCodeAt(p._pos)); + }; + PRIMITIVES["read-line"] = function(p) { + if (p === undefined || p === NIL || p == null) return _eof; + if (!p._port || p._kind !== "input") throw new Error("read-line: expected input port"); + if (p._closed || p._pos >= p._source.length) return _eof; + var start = p._pos; + while (p._pos < p._source.length && p._source[p._pos] !== '\\n') p._pos++; + var line = p._source.slice(start, p._pos); + if (p._pos < p._source.length) p._pos++; // skip \n + return line; + }; + PRIMITIVES["write-char"] = function(c, p) { + if (!p || !p._port || p._kind !== "output") throw new Error("write-char: expected char and output port"); + if (!p._closed) p._buffer += String.fromCharCode(c.codepoint); + return NIL; + }; + PRIMITIVES["write-string"] = function(s, p) { + if (!p || !p._port || p._kind !== "output") throw new Error("write-string: expected string and output port"); + if (!p._closed) p._buffer += String(s); + return NIL; + }; + PRIMITIVES["char-ready?"] = function(p) { + if (p === undefined || p === NIL || p == null) return false; + if (!p._port || p._kind !== "input") return false; + return !p._closed && p._pos < p._source.length; + }; + // read/write/display + var _sxBs92 = String.fromCharCode(92); + function sxReadNormalize(src) { + var out = "", i = 0, n = src.length; + while (i < n) { + if (src[i] === '"') { + out += '"'; i++; + while (i < n) { + if (src[i] === _sxBs92 && i+1 < n) { out += src[i]; out += src[i+1]; i += 2; continue; } + if (src[i] === '"') { out += src[i++]; break; } + out += src[i++]; + } + } else if (src[i] === '#' && i+1 < n && (src[i+1] === 't' || src[i+1] === 'f')) { + var nc2 = i+2 < n ? src[i+2] : ''; + if (!nc2 || !/[a-zA-Z0-9_]/.test(nc2)) { + out += (src[i+1] === 't') ? 'true' : 'false'; + i += 2; + } else { out += src[i++]; } + } else { out += src[i++]; } + } + return out; + } + function sxReadConvert(v) { + if (Array.isArray(v) && v.length === 0) return NIL; + if (Array.isArray(v)) return v.map(sxReadConvert); + return v; + } + PRIMITIVES["read"] = function() { + var p = arguments.length > 0 && arguments[0] && arguments[0]._port ? arguments[0] : null; + if (!p || p._kind !== "input" || p._closed) return _eof; + if (!p._forms) { + var sxP = PRIMITIVES["sx-parse"]; + var src = sxReadNormalize(p._source.slice(p._pos || 0)); + p._forms = sxP ? (sxP(src) || []) : []; + p._form_idx = 0; + } + if (p._form_idx >= p._forms.length) return _eof; + return sxReadConvert(p._forms[p._form_idx++]); + }; + var _sxBs = String.fromCharCode(92); + var _sxDq = String.fromCharCode(34); + function sxWriteVal(v, mode) { + if (v === null || v === undefined || v === NIL) return "()"; + if (v && v._eof) return "#!eof"; + if (typeof v === "boolean") return v ? "#t" : "#f"; + if (typeof v === "number") return String(v); + if (v && v._rational) return v._n + "/" + v._d; + if (typeof v === "string") { + if (mode === "display") return v; + return _sxDq + v.split("").map(function(c) { + var n = c.charCodeAt(0); + if (n === 34) return _sxBs + _sxDq; + if (n === 92) return _sxBs + _sxBs; + if (n === 10) return _sxBs + "n"; + if (n === 13) return _sxBs + "r"; + if (n === 9) return _sxBs + "t"; + return c; + }).join("") + _sxDq; + } + if (v && v._char) { + if (mode === "display") return String.fromCodePoint(v.codepoint); + var cp = v.codepoint; + if (cp === 32) return "#" + _sxBs + "space"; + if (cp === 10) return "#" + _sxBs + "newline"; + if (cp === 9) return "#" + _sxBs + "tab"; + return "#" + _sxBs + String.fromCodePoint(cp); + } + if (v && v._sym) return v.name; + if (v && v._kw) return ":" + v.name; + if (Array.isArray(v)) return "(" + v.map(function(x){ return sxWriteVal(x, mode); }).join(" ") + ")"; + return String(v); + } + PRIMITIVES["write"] = function() { + var val = arguments[0], port = arguments[1]; + var s = sxWriteVal(val, "write"); + if (port && port._port && port._kind === "output" && !port._closed) port._buffer += s; + return NIL; + }; + PRIMITIVES["display"] = function() { + var val = arguments[0], port = arguments[1]; + var s = sxWriteVal(val, "display"); + if (port && port._port && port._kind === "output" && !port._closed) port._buffer += s; + return NIL; + }; + PRIMITIVES["newline"] = function() { + var port = arguments[0]; + if (port && port._port && port._kind === "output" && !port._closed) port._buffer += String.fromCharCode(10); + return NIL; + }; + PRIMITIVES["write-to-string"] = function(val) { return sxWriteVal(val, "write"); }; + PRIMITIVES["display-to-string"] = function(val) { return sxWriteVal(val, "display"); }; + PRIMITIVES["current-input-port"] = function() { return NIL; }; + PRIMITIVES["current-output-port"] = function() { return NIL; }; + PRIMITIVES["current-error-port"] = function() { return NIL; }; PRIMITIVES["string-length"] = function(s) { return String(s).length; }; var stringLength = PRIMITIVES["string-length"]; PRIMITIVES["string-contains?"] = function(s, sub) { return String(s).indexOf(String(sub)) !== -1; }; @@ -1086,6 +1434,49 @@ PRIMITIVES_JS_MODULES: dict[str, str] = { }; ''', + "core.vectors": ''' + // core.vectors — R7RS mutable fixed-size arrays + PRIMITIVES["make-vector"] = function(n, fill) { + var arr = new Array(n); + var f = (fill !== undefined) ? fill : NIL; + for (var i = 0; i < n; i++) arr[i] = f; + return new SxVector(arr); + }; + PRIMITIVES["vector"] = function() { + return new SxVector(Array.prototype.slice.call(arguments)); + }; + PRIMITIVES["vector?"] = function(x) { return x != null && x._vector === true; }; + PRIMITIVES["vector-length"] = function(v) { return v.arr.length; }; + PRIMITIVES["vector-ref"] = function(v, i) { + if (i < 0 || i >= v.arr.length) throw new Error("vector-ref: index " + i + " out of bounds (length " + v.arr.length + ")"); + return v.arr[i]; + }; + PRIMITIVES["vector-set!"] = function(v, i, val) { + if (i < 0 || i >= v.arr.length) throw new Error("vector-set!: index " + i + " out of bounds (length " + v.arr.length + ")"); + v.arr[i] = val; return NIL; + }; + PRIMITIVES["vector->list"] = function(v) { return v.arr.slice(); }; + PRIMITIVES["list->vector"] = function(l) { return new SxVector(l.slice()); }; + PRIMITIVES["vector-fill!"] = function(v, val) { + for (var i = 0; i < v.arr.length; i++) v.arr[i] = val; return NIL; + }; + PRIMITIVES["vector-copy"] = function(v, start, end) { + var s = (start !== undefined) ? start : 0; + var e = (end !== undefined) ? Math.min(end, v.arr.length) : v.arr.length; + return new SxVector(v.arr.slice(s, e)); + }; + + // String buffers — O(1) amortised append via array+join + function SxStringBuffer() { this.parts = []; this.len = 0; this._string_buffer = true; } + PRIMITIVES["make-string-buffer"] = function() { return new SxStringBuffer(); }; + PRIMITIVES["string-buffer?"] = function(x) { return x instanceof SxStringBuffer; }; + PRIMITIVES["string-buffer-append!"] = function(buf, s) { + buf.parts.push(String(s)); buf.len += String(s).length; return NIL; + }; + PRIMITIVES["string-buffer->string"] = function(buf) { return buf.parts.join(""); }; + PRIMITIVES["string-buffer-length"] = function(buf) { return buf.len; }; +''', + "stdlib.format": ''' // stdlib.format PRIMITIVES["format-decimal"] = function(v, p) { return Number(v).toFixed(p || 2); }; @@ -1196,6 +1587,304 @@ PRIMITIVES_JS_MODULES: dict[str, str] = { return NIL; }; ''', + + "stdlib.bitwise": ''' + // stdlib.bitwise + PRIMITIVES["bitwise-and"] = function(a, b) { return (a & b) | 0; }; + PRIMITIVES["bitwise-or"] = function(a, b) { return (a | b) | 0; }; + PRIMITIVES["bitwise-xor"] = function(a, b) { return (a ^ b) | 0; }; + PRIMITIVES["bitwise-not"] = function(a) { return ~a; }; + PRIMITIVES["arithmetic-shift"] = function(a, count) { + return count >= 0 ? (a << count) | 0 : a >> (-count); + }; + PRIMITIVES["bit-count"] = function(a) { + var n = Math.abs(a) >>> 0; + n = n - ((n >> 1) & 0x55555555); + n = (n & 0x33333333) + ((n >> 2) & 0x33333333); + return (((n + (n >> 4)) & 0x0f0f0f0f) * 0x01010101) >>> 24; + }; + PRIMITIVES["integer-length"] = function(a) { + if (a === 0) return 0; + return 32 - Math.clz32(Math.abs(a)); + }; +''', + "stdlib.math": ''' + // stdlib.math + PRIMITIVES["sin"] = Math.sin; + PRIMITIVES["cos"] = Math.cos; + PRIMITIVES["tan"] = Math.tan; + PRIMITIVES["asin"] = Math.asin; + PRIMITIVES["acos"] = Math.acos; + PRIMITIVES["atan"] = function(y, x) { return arguments.length >= 2 ? Math.atan2(y, x) : Math.atan(y); }; + PRIMITIVES["exp"] = Math.exp; + PRIMITIVES["log"] = Math.log; + PRIMITIVES["expt"] = Math.pow; + PRIMITIVES["quotient"] = function(a, b) { return Math.trunc(a / b); }; + PRIMITIVES["gcd"] = function(a, b) { + a = Math.abs(a); b = Math.abs(b); + while (b) { var t = b; b = a % b; a = t; } + return a; + }; + PRIMITIVES["lcm"] = function(a, b) { + var g = PRIMITIVES["gcd"](Math.abs(a), Math.abs(b)); + return g === 0 ? 0 : Math.abs(a / g * b); + }; + PRIMITIVES["number->string"] = function(n, r) { + if (n && n._rational) return n._n + "/" + n._d; + if (r === undefined || r === null) return String(n); + return Math.floor(n).toString(r); + }; + PRIMITIVES["string->number"] = function(s, r) { + s = String(s); + if (r !== undefined && r !== null) { + var radix = r | 0; + var valid = "0123456789abcdefghijklmnopqrstuvwxyz".slice(0, radix); + var norm = s.toLowerCase(); + var start = norm[0] === '-' ? 1 : 0; + if (norm.length <= start) return NIL; + for (var i = start; i < norm.length; i++) { + if (valid.indexOf(norm[i]) === -1) return NIL; + } + return parseInt(s, radix); + } + if (s === '') return NIL; + var n = Number(s); + return isNaN(n) ? NIL : n; + }; +''', + "stdlib.rational": ''' + // stdlib.rational + function SxRational(n, d) { + function gcd(a, b) { while (b) { var t=b; b=a%b; a=t; } return a; } + if (d === 0) throw new Error("make-rational: denominator cannot be zero"); + var sign = (d < 0) ? -1 : 1; + var g = gcd(Math.abs(n), Math.abs(d)); + this._n = sign * n / g; + this._d = sign * d / g; + this._rational = true; + } + SxRational.prototype.toString = function() { return this._n + "/" + this._d; }; + PRIMITIVES["make-rational"] = function(n, d) { + var r = new SxRational(Math.trunc(n), Math.trunc(d)); + if (r._d === 1) return r._n; + return r; + }; + PRIMITIVES["rational?"] = function(v) { return v instanceof SxRational; }; + PRIMITIVES["numerator"] = function(r) { return r instanceof SxRational ? r._n : r; }; + PRIMITIVES["denominator"] = function(r) { return r instanceof SxRational ? r._d : 1; }; + var makeRational = PRIMITIVES["make-rational"]; +''', + "stdlib.hash-table": ''' + // stdlib.hash-table + function SxHashTable() { this.data = new Map(); this._hash_table = true; } + PRIMITIVES["make-hash-table"] = function() { return new SxHashTable(); }; + PRIMITIVES["hash-table?"] = function(x) { return x instanceof SxHashTable; }; + PRIMITIVES["hash-table-set!"] = function(ht, k, v) { ht.data.set(k, v); return null; }; + PRIMITIVES["hash-table-ref"] = function(ht, k, dflt) { + if (ht.data.has(k)) return ht.data.get(k); + if (arguments.length > 2) return dflt; + throw new Error("hash-table-ref: key not found"); + }; + PRIMITIVES["hash-table-delete!"] = function(ht, k) { ht.data.delete(k); return null; }; + PRIMITIVES["hash-table-size"] = function(ht) { return ht.data.size; }; + PRIMITIVES["hash-table-keys"] = function(ht) { return Array.from(ht.data.keys()); }; + PRIMITIVES["hash-table-values"] = function(ht) { return Array.from(ht.data.values()); }; + PRIMITIVES["hash-table->alist"] = function(ht) { + var result = []; + ht.data.forEach(function(v, k) { result.push([k, v]); }); + return result; + }; + PRIMITIVES["hash-table-for-each"] = function(ht, fn) { + ht.data.forEach(function(v, k) { apply(fn, [k, v]); }); + return null; + }; + PRIMITIVES["hash-table-merge!"] = function(dst, src) { + src.data.forEach(function(v, k) { dst.data.set(k, v); }); + return null; + }; +''', + "stdlib.regexp": ''' + // stdlib.regexp — native JS RegExp wrappers + function SxRegexp(source, flags) { + this._regexp = true; + this.source = source; + this.flags = flags || ""; + } + function sxRxCompile(rx) { + if (!rx._compiled) { + var jsFlags = ""; + if (rx.flags.indexOf("i") >= 0) jsFlags += "i"; + if (rx.flags.indexOf("m") >= 0) jsFlags += "m"; + if (rx.flags.indexOf("s") >= 0) jsFlags += "s"; + rx._compiled = new RegExp(rx.source, jsFlags); + } + return rx._compiled; + } + function sxRxMatchDict(m, input) { + if (!m) return NIL; + var groups = []; + for (var i = 1; i < m.length; i++) groups.push(m[i] !== undefined ? m[i] : ""); + return {"match": m[0], "start": m.index, "end": m.index + m[0].length, + "input": input, "groups": groups}; + } + PRIMITIVES["make-regexp"] = function(src, flags) { + return new SxRegexp(src, flags || ""); + }; + PRIMITIVES["regexp?"] = function(v) { return v instanceof SxRegexp; }; + PRIMITIVES["regexp-source"] = function(rx) { return rx.source; }; + PRIMITIVES["regexp-flags"] = function(rx) { return rx.flags; }; + PRIMITIVES["regexp-match"] = function(rx, s) { + var re = new RegExp(sxRxCompile(rx).source, + sxRxCompile(rx).flags.replace("g","")); + var m = s.match(re); + return sxRxMatchDict(m, s); + }; + PRIMITIVES["regexp-match-all"] = function(rx, s) { + var compiled = sxRxCompile(rx); + var re = new RegExp(compiled.source, "g" + compiled.flags.replace("g","")); + var results = [], m; + while ((m = re.exec(s)) !== null) { + results.push(sxRxMatchDict(m, s)); + if (m[0].length === 0) re.lastIndex++; + } + return results; + }; + PRIMITIVES["regexp-replace"] = function(rx, s, replacement) { + var compiled = sxRxCompile(rx); + var re = new RegExp(compiled.source, compiled.flags.replace("g","")); + return s.replace(re, replacement); + }; + PRIMITIVES["regexp-replace-all"] = function(rx, s, replacement) { + var compiled = sxRxCompile(rx); + var re = new RegExp(compiled.source, "g" + compiled.flags.replace("g","")); + return s.replace(re, replacement); + }; + PRIMITIVES["regexp-split"] = function(rx, s) { + var re = sxRxCompile(rx); + return s.split(re); + }; +''', + "stdlib.sets": ''' + // stdlib.sets — structural sets keyed by write-to-string serialization + function SxSet() { this.data = new Map(); this._sxset = true; } + SxSet.prototype._type = "set"; + function sxSetKey(v) { return sxWriteVal(v, "write"); } + function sxSetSeed(s, lst) { + if (Array.isArray(lst)) lst.forEach(function(v) { s.data.set(sxSetKey(v), v); }); + return s; + } + PRIMITIVES["make-set"] = function() { + var s = new SxSet(); + if (arguments.length > 0 && Array.isArray(arguments[0])) sxSetSeed(s, arguments[0]); + return s; + }; + PRIMITIVES["set?"] = function(v) { return v instanceof SxSet; }; + PRIMITIVES["set-add!"] = function(s, v) { s.data.set(sxSetKey(v), v); return NIL; }; + PRIMITIVES["set-member?"] = function(s, v) { return s.data.has(sxSetKey(v)); }; + PRIMITIVES["set-remove!"] = function(s, v) { s.data.delete(sxSetKey(v)); return NIL; }; + PRIMITIVES["set-size"] = function(s) { return s.data.size; }; + PRIMITIVES["set->list"] = function(s) { return Array.from(s.data.values()); }; + PRIMITIVES["list->set"] = function(lst) { + var s = new SxSet(); + if (Array.isArray(lst)) lst.forEach(function(v) { s.data.set(sxSetKey(v), v); }); + return s; + }; + PRIMITIVES["set-union"] = function(a, b) { + var s = new SxSet(); + a.data.forEach(function(v, k) { s.data.set(k, v); }); + b.data.forEach(function(v, k) { s.data.set(k, v); }); + return s; + }; + PRIMITIVES["set-intersection"] = function(a, b) { + var s = new SxSet(); + a.data.forEach(function(v, k) { if (b.data.has(k)) s.data.set(k, v); }); + return s; + }; + PRIMITIVES["set-difference"] = function(a, b) { + var s = new SxSet(); + a.data.forEach(function(v, k) { if (!b.data.has(k)) s.data.set(k, v); }); + return s; + }; + PRIMITIVES["set-for-each"] = function(s, fn) { + s.data.forEach(function(v) { apply(fn, [v]); }); + return NIL; + }; + PRIMITIVES["set-map"] = function(s, fn) { + var out = new SxSet(); + s.data.forEach(function(v) { + var r = apply(fn, [v]); + out.data.set(sxSetKey(r), r); + }); + return out; + }; +''', + "stdlib.bytevectors": ''' + // stdlib.bytevectors — R7RS bytevector type backed by Uint8Array + function SxBytevector(size_or_buf) { + if (size_or_buf instanceof Uint8Array) { + this.data = size_or_buf; + } else { + this.data = new Uint8Array(typeof size_or_buf === "number" ? size_or_buf : 0); + } + this._bytevector = true; + } + SxBytevector.prototype._type = "bytevector"; + PRIMITIVES["make-bytevector"] = function(n, fill) { + var bv = new SxBytevector(n); + if (fill !== undefined) bv.data.fill(fill & 0xff); + return bv; + }; + PRIMITIVES["bytevector?"] = function(v) { return v instanceof SxBytevector; }; + PRIMITIVES["bytevector-length"] = function(bv) { return bv.data.length; }; + PRIMITIVES["bytevector-u8-ref"] = function(bv, i) { return bv.data[i]; }; + PRIMITIVES["bytevector-u8-set!"] = function(bv, i, byte) { bv.data[i] = byte & 0xff; return NIL; }; + PRIMITIVES["bytevector-copy"] = function(bv, start, end_) { + var s = start === undefined ? 0 : start; + var e = end_ === undefined ? bv.data.length : end_; + return new SxBytevector(bv.data.slice(s, e)); + }; + PRIMITIVES["bytevector-copy!"] = function(dst, at, src, start, end_) { + var s = start === undefined ? 0 : start; + var e = end_ === undefined ? src.data.length : end_; + dst.data.set(src.data.subarray(s, e), at); + return NIL; + }; + PRIMITIVES["bytevector-append"] = function() { + var total = 0; + for (var i = 0; i < arguments.length; i++) total += arguments[i].data.length; + var result = new Uint8Array(total); + var pos = 0; + for (var i = 0; i < arguments.length; i++) { + result.set(arguments[i].data, pos); + pos += arguments[i].data.length; + } + return new SxBytevector(result); + }; + PRIMITIVES["utf8->string"] = function(bv, start, end_) { + var s = start === undefined ? 0 : start; + var e = end_ === undefined ? bv.data.length : end_; + var dec = new TextDecoder("utf-8"); + return dec.decode(bv.data.subarray(s, e)); + }; + PRIMITIVES["string->utf8"] = function(str, start, end_) { + var enc = new TextEncoder(); + var full = enc.encode(str); + var s = start === undefined ? 0 : start; + var e = end_ === undefined ? full.length : end_; + return new SxBytevector(full.slice(s, e)); + }; + PRIMITIVES["bytevector->list"] = function(bv) { + var out = []; + for (var i = 0; i < bv.data.length; i++) out.push(bv.data[i]); + return out; + }; + PRIMITIVES["list->bytevector"] = function(lst) { + if (!Array.isArray(lst)) lst = []; + var b = new Uint8Array(lst.length); + for (var i = 0; i < lst.length; i++) b[i] = lst[i] & 0xff; + return new SxBytevector(b); + }; +''', } # Modules to include by default (all) _ALL_JS_MODULES = list(PRIMITIVES_JS_MODULES.keys()) @@ -1234,6 +1923,16 @@ PLATFORM_JS_PRE = ''' if (x._macro) return "macro"; if (x._raw) return "raw-html"; if (x._sx_expr) return "sx-expr"; + if (x._char) return "char"; + if (x._eof) return "eof-object"; + if (x._port) return x._kind === "input" ? "input-port" : "output-port"; + if (x._vector) return "vector"; + if (x._string_buffer) return "string-buffer"; + if (x._hash_table) return "hash-table"; + if (x._sxset) return "set"; + if (x._regexp) return "regexp"; + if (x._bytevector) return "bytevector"; + if (x._rational) return "rational"; if (typeof Node !== "undefined" && x instanceof Node) return "dom-node"; if (Array.isArray(x)) return "list"; if (typeof x === "object") return "dict"; @@ -1400,6 +2099,12 @@ PLATFORM_JS_PRE = ''' // Placeholder — overridden by transpiled version from render.sx function isRenderExpr(expr) { return false; } + // Last error continuation — saved when a raise goes unhandled, for post-mortem inspection. + var _lastErrorKont_ = null; + + // hostError — throw a host-level error that propagates out of cekRun. + function hostError(msg) { throw new Error(typeof msg === "string" ? msg : inspect(msg)); } + // Render dispatch — call the active adapter's render function. // Set by each adapter when loaded; defaults to identity (no rendering). var _renderExprFn = null; @@ -1485,12 +2190,21 @@ PLATFORM_JS_POST = ''' var mod = PRIMITIVES["mod"]; var indexOf_ = PRIMITIVES["index-of"]; var hasKey = PRIMITIVES["has-key?"]; + var vectorToList = PRIMITIVES["vector->list"]; + var listToVector = PRIMITIVES["list->vector"]; + var isVector = PRIMITIVES["vector?"]; + var vectorLength = PRIMITIVES["vector-length"]; + var vectorRef = PRIMITIVES["vector-ref"]; + var reverse = PRIMITIVES["reverse"]; + var stringToSymbol = PRIMITIVES["string->symbol"]; + var symbolToString = PRIMITIVES["symbol->string"]; function zip(a, b) { var r = []; for (var i = 0; i < Math.min(a.length, b.length); i++) r.push([a[i], b[i]]); return r; } function append_b(arr, x) { arr.push(x); return arr; } var apply = function(f, args) { if (isLambda(f)) return trampoline(callLambda(f, args, lambdaClosure(f))); return f.apply(null, args); }; + PRIMITIVES["apply"] = apply; // Additional primitive aliases used by adapter/engine transpiled code var split = PRIMITIVES["split"]; @@ -1743,6 +2457,13 @@ CEK_FIXUPS_JS = ''' PRIMITIVES["lambda-name"] = lambdaName; PRIMITIVES["component?"] = isComponent; PRIMITIVES["island?"] = isIsland; + PRIMITIVES["parameter?"] = parameter_p; + PRIMITIVES["parameter-uid"] = parameterUid; + PRIMITIVES["parameter-default"] = parameterDefault; + PRIMITIVES["make-parameter"] = function(defaultVal, converter) { + var p = new SxParameter(defaultVal, converter || null); + return p; + }; PRIMITIVES["make-symbol"] = function(n) { return new Symbol(n); }; PRIMITIVES["is-html-tag?"] = function(n) { return HTML_TAGS.indexOf(n) >= 0; }; function makeEnv() { return merge(componentEnv, PRIMITIVES); } @@ -1857,6 +2578,14 @@ PLATFORM_PARSER_JS = r""" } function sxExprSource(e) { return typeof e === "string" ? e : (e && e.source ? e.source : String(e)); } var charFromCode = PRIMITIVES["char-from-code"]; + var makeChar = PRIMITIVES["make-char"]; + var charToInteger = PRIMITIVES["char->integer"]; + var isChar = PRIMITIVES["char?"]; + var _readerMacros = {}; + function readerMacroGet(name) { return _readerMacros[name] || false; } + function readerMacroSet(name, fn) { _readerMacros[name] = fn; } + PRIMITIVES["reader-macro-get"] = readerMacroGet; + PRIMITIVES["reader-macro-set!"] = readerMacroSet; """ @@ -2031,7 +2760,7 @@ PLATFORM_DOM_JS = """ } function domDispatch(el, name, detail) { - if (!_hasDom || !el) return false; + if (!_hasDom || !el || typeof el.dispatchEvent !== "function") return false; var evt = new CustomEvent(name, { bubbles: true, cancelable: true, detail: detail || {} }); return el.dispatchEvent(evt); } @@ -2157,6 +2886,14 @@ PLATFORM_ORCHESTRATION_JS = """ // Platform interface — Orchestration (browser-only) // ========================================================================= + // --- Stubs for define-library functions not transpiled by extract_defines --- + // These are defined in orchestration.sx's define-library and called from + // boot.sx top-level defines. The JS bootstrapper only transpiles top-level + // defines, so we provide stubs here for functions that need a JS identity. + + function flushCollectedStyles() { return NIL; } + function processElements(root) { return NIL; } + // --- Browser/Network --- function browserNavigate(url) { @@ -2642,6 +3379,10 @@ PLATFORM_ORCHESTRATION_JS = """ return el && el.closest ? el.closest(sel) : null; } + function domDocument() { + return _hasDom ? document : null; + } + function domBody() { return _hasDom ? document.body : null; } @@ -3085,6 +3826,8 @@ PLATFORM_BOOT_JS = """ // Platform interface — Boot (mount, hydrate, scripts, cookies) // ========================================================================= + function preloadIslandDefs() { return NIL; } + function resolveMountTarget(target) { if (typeof target === "string") return _hasDom ? document.querySelector(target) : null; return target; @@ -3237,6 +3980,18 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_ // Core primitives that require native JS (cannot be expressed via FFI) // ----------------------------------------------------------------------- PRIMITIVES["error"] = function(msg) { throw new Error(msg); }; + PRIMITIVES["host-error"] = function(msg) { throw new Error(typeof msg === "string" ? msg : inspect(msg)); }; + PRIMITIVES["try-catch"] = function(tryFn, catchFn) { + try { + return cekRun(continueWithCall(tryFn, [], makeEnv(), [], [])); + } catch(e) { + var msg = e && e.message ? e.message : String(e); + return cekRun(continueWithCall(catchFn, [msg], makeEnv(), [msg], [])); + } + }; + PRIMITIVES["without-io-hook"] = function(thunk) { + return cekRun(continueWithCall(thunk, [], makeEnv(), [], [])); + }; PRIMITIVES["sort"] = function(lst) { if (!Array.isArray(lst)) return lst; return lst.slice().sort(function(a, b) { @@ -3304,7 +4059,7 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_ PRIMITIVES["dom-tag-name"] = domTagName; PRIMITIVES["dom-get-prop"] = domGetProp; PRIMITIVES["dom-set-prop"] = domSetProp; - PRIMITIVES["reactive-text"] = reactiveText; + if (typeof reactiveText === "function") PRIMITIVES["reactive-text"] = reactiveText; PRIMITIVES["set-interval"] = setInterval_; PRIMITIVES["clear-interval"] = clearInterval_; PRIMITIVES["promise-then"] = promiseThen; @@ -3493,35 +4248,35 @@ def public_api_js(has_html, has_sx, has_dom, has_engine, has_orch, has_boot, has elif has_orch: api_lines.append(' init: typeof engineInit === "function" ? engineInit : null,') if has_deps: - api_lines.append(' scanRefs: scanRefs,') - api_lines.append(' scanComponentsFromSource: scanComponentsFromSource,') - api_lines.append(' transitiveDeps: transitiveDeps,') - api_lines.append(' computeAllDeps: computeAllDeps,') - api_lines.append(' componentsNeeded: componentsNeeded,') - api_lines.append(' pageComponentBundle: pageComponentBundle,') - api_lines.append(' pageCssClasses: pageCssClasses,') - api_lines.append(' scanIoRefs: scanIoRefs,') - api_lines.append(' transitiveIoRefs: transitiveIoRefs,') - api_lines.append(' computeAllIoRefs: computeAllIoRefs,') - api_lines.append(' componentPure_p: componentPure_p,') + api_lines.append(' scanRefs: typeof scanRefs === "function" ? scanRefs : null,') + api_lines.append(' scanComponentsFromSource: typeof scanComponentsFromSource === "function" ? scanComponentsFromSource : null,') + api_lines.append(' transitiveDeps: typeof transitiveDeps === "function" ? transitiveDeps : null,') + api_lines.append(' computeAllDeps: typeof computeAllDeps === "function" ? computeAllDeps : null,') + api_lines.append(' componentsNeeded: typeof componentsNeeded === "function" ? componentsNeeded : null,') + api_lines.append(' pageComponentBundle: typeof pageComponentBundle === "function" ? pageComponentBundle : null,') + api_lines.append(' pageCssClasses: typeof pageCssClasses === "function" ? pageCssClasses : null,') + api_lines.append(' scanIoRefs: typeof scanIoRefs === "function" ? scanIoRefs : null,') + api_lines.append(' transitiveIoRefs: typeof transitiveIoRefs === "function" ? transitiveIoRefs : null,') + api_lines.append(' computeAllIoRefs: typeof computeAllIoRefs === "function" ? computeAllIoRefs : null,') + api_lines.append(' componentPure_p: typeof componentPure_p === "function" ? componentPure_p : null,') if has_page_helpers: - api_lines.append(' categorizeSpecialForms: categorizeSpecialForms,') - api_lines.append(' buildReferenceData: buildReferenceData,') - api_lines.append(' buildAttrDetail: buildAttrDetail,') - api_lines.append(' buildHeaderDetail: buildHeaderDetail,') - api_lines.append(' buildEventDetail: buildEventDetail,') - api_lines.append(' buildComponentSource: buildComponentSource,') - api_lines.append(' buildBundleAnalysis: buildBundleAnalysis,') - api_lines.append(' buildRoutingAnalysis: buildRoutingAnalysis,') - api_lines.append(' buildAffinityAnalysis: buildAffinityAnalysis,') + api_lines.append(' categorizeSpecialForms: typeof categorizeSpecialForms === "function" ? categorizeSpecialForms : null,') + api_lines.append(' buildReferenceData: typeof buildReferenceData === "function" ? buildReferenceData : null,') + api_lines.append(' buildAttrDetail: typeof buildAttrDetail === "function" ? buildAttrDetail : null,') + api_lines.append(' buildHeaderDetail: typeof buildHeaderDetail === "function" ? buildHeaderDetail : null,') + api_lines.append(' buildEventDetail: typeof buildEventDetail === "function" ? buildEventDetail : null,') + api_lines.append(' buildComponentSource: typeof buildComponentSource === "function" ? buildComponentSource : null,') + api_lines.append(' buildBundleAnalysis: typeof buildBundleAnalysis === "function" ? buildBundleAnalysis : null,') + api_lines.append(' buildRoutingAnalysis: typeof buildRoutingAnalysis === "function" ? buildRoutingAnalysis : null,') + api_lines.append(' buildAffinityAnalysis: typeof buildAffinityAnalysis === "function" ? buildAffinityAnalysis : null,') if has_router: - api_lines.append(' splitPathSegments: splitPathSegments,') - api_lines.append(' parseRoutePattern: parseRoutePattern,') - api_lines.append(' matchRoute: matchRoute,') - api_lines.append(' findMatchingRoute: findMatchingRoute,') - api_lines.append(' urlToExpr: urlToExpr,') - api_lines.append(' autoQuoteUnknowns: autoQuoteUnknowns,') - api_lines.append(' prepareUrlExpr: prepareUrlExpr,') + api_lines.append(' splitPathSegments: typeof splitPathSegments === "function" ? splitPathSegments : null,') + api_lines.append(' parseRoutePattern: typeof parseRoutePattern === "function" ? parseRoutePattern : null,') + api_lines.append(' matchRoute: typeof matchRoute === "function" ? matchRoute : null,') + api_lines.append(' findMatchingRoute: typeof findMatchingRoute === "function" ? findMatchingRoute : null,') + api_lines.append(' urlToExpr: typeof urlToExpr === "function" ? urlToExpr : null,') + api_lines.append(' autoQuoteUnknowns: typeof autoQuoteUnknowns === "function" ? autoQuoteUnknowns : null,') + api_lines.append(' prepareUrlExpr: typeof prepareUrlExpr === "function" ? prepareUrlExpr : null,') if has_dom: api_lines.append(' registerIo: typeof registerIoPrimitive === "function" ? registerIoPrimitive : null,') @@ -3529,21 +4284,21 @@ def public_api_js(has_html, has_sx, has_dom, has_engine, has_orch, has_boot, has api_lines.append(' asyncRender: typeof asyncSxRenderWithEnv === "function" ? asyncSxRenderWithEnv : null,') api_lines.append(' asyncRenderToDom: typeof asyncRenderToDom === "function" ? asyncRenderToDom : null,') if has_signals: - api_lines.append(' signal: signal,') - api_lines.append(' deref: deref,') - api_lines.append(' reset: reset_b,') - api_lines.append(' swap: swap_b,') - api_lines.append(' computed: computed,') - api_lines.append(' effect: effect,') - api_lines.append(' batch: batch,') - api_lines.append(' isSignal: isSignal,') - api_lines.append(' makeSignal: makeSignal,') - api_lines.append(' defStore: defStore,') - api_lines.append(' useStore: useStore,') - api_lines.append(' clearStores: clearStores,') - api_lines.append(' emitEvent: emitEvent,') - api_lines.append(' onEvent: onEvent,') - api_lines.append(' bridgeEvent: bridgeEvent,') + api_lines.append(' signal: typeof signal === "function" ? signal : null,') + api_lines.append(' deref: typeof deref === "function" ? deref : null,') + api_lines.append(' reset: typeof reset_b === "function" ? reset_b : null,') + api_lines.append(' swap: typeof swap_b === "function" ? swap_b : null,') + api_lines.append(' computed: typeof computed === "function" ? computed : null,') + api_lines.append(' effect: typeof effect === "function" ? effect : null,') + api_lines.append(' batch: typeof batch === "function" ? batch : null,') + api_lines.append(' isSignal: typeof isSignal === "function" ? isSignal : null,') + api_lines.append(' makeSignal: typeof makeSignal === "function" ? makeSignal : null,') + api_lines.append(' defStore: typeof defStore === "function" ? defStore : null,') + api_lines.append(' useStore: typeof useStore === "function" ? useStore : null,') + api_lines.append(' clearStores: typeof clearStores === "function" ? clearStores : null,') + api_lines.append(' emitEvent: typeof emitEvent === "function" ? emitEvent : null,') + api_lines.append(' onEvent: typeof onEvent === "function" ? onEvent : null,') + api_lines.append(' bridgeEvent: typeof bridgeEvent === "function" ? bridgeEvent : null,') api_lines.append(' makeSpread: makeSpread,') api_lines.append(' isSpread: isSpread,') api_lines.append(' spreadAttrs: spreadAttrs,') diff --git a/hosts/javascript/run_tests.js b/hosts/javascript/run_tests.js index a142f1bc..79a17798 100644 --- a/hosts/javascript/run_tests.js +++ b/hosts/javascript/run_tests.js @@ -293,6 +293,8 @@ env["pop-suite"] = function() { return null; }; +env["test-allowed?"] = function(name) { return true; }; + // Load test framework const projectDir = path.join(__dirname, "..", ".."); const specTests = path.join(projectDir, "spec", "tests"); @@ -341,6 +343,20 @@ if (fs.existsSync(swapPath)) { } } +// Load spec library files (define-library modules imported by tests) +for (const libFile of ["stdlib.sx", "signals.sx", "coroutines.sx"]) { + const libPath = path.join(projectDir, "spec", libFile); + if (fs.existsSync(libPath)) { + const libSrc = fs.readFileSync(libPath, "utf8"); + const libExprs = Sx.parse(libSrc); + for (const expr of libExprs) { + try { Sx.eval(expr, env); } catch (e) { + console.error(`Error loading spec/${libFile}: ${e.message}`); + } + } + } +} + // Load tw system (needed by spec/tests/test-tw.sx) const twDir = path.join(projectDir, "shared", "sx", "templates"); for (const twFile of ["tw-type.sx", "tw-layout.sx", "tw.sx"]) { diff --git a/hosts/javascript/transpiler.sx b/hosts/javascript/transpiler.sx index 6c6f8f1b..4609b050 100644 --- a/hosts/javascript/transpiler.sx +++ b/hosts/javascript/transpiler.sx @@ -66,14 +66,16 @@ "with" "yield")) -(define js-renames {:ho-filter "hoFilter" :thunk-env "thunkEnv" :cek-run "cekRun" :*custom-special-forms* "_customSpecialForms" :with-island-scope "withIslandScope" :step-sf-if "stepSfIf" :dom-is-fragment? "domIsFragment" :process-bindings "processBindings" :call-thunk "callThunk" :fetch-streaming "fetchStreaming" :bind-inline-handlers "bindInlineHandlers" :set-interval "setInterval_" :number? "isNumber" :reactive-list "reactiveList" :expand-macro "expandMacro" :handle-history "handleHistory" :page-render-plan "pageRenderPlan" :make-let-frame "makeLetFrame" :parse-comp-params "parseCompParams" :next-retry-ms "nextRetryMs" :fetch-request "fetchRequest" :kont-push "kontPush" :macro-body "macroBody" :for-each-indexed "forEachIndexed" :step-ho-for-each "stepHoForEach" :set-render-active! "setRenderActiveB" :local-storage-set "localStorageSet" :dom-get-attr "domGetAttr" :parse-element-args "parseElementArgs" :process-emit-elements "processEmitElements" :build-request-body "buildRequestBody" :kont-top "kontTop" :event-detail "eventDetail" :match-route "matchRoute" :handle-popstate "handlePopstate" :event-source-listen "eventSourceListen" :select-from-container "selectFromContainer" :try-eval-content "tryEvalContent" :query-page-scripts "queryPageScripts" :scope-emit! "scopeEmit" :promise-delayed "promiseDelayed" :make-call-frame "makeCallFrame" :HTML_TAGS "HTML_TAGS" :macro-rest-param "macroRestParam" :env-has? "envHas" :make-raw-html "makeRawHtml" :dom-set-style "domSetStyle" :try-parse-json "tryParseJson" :host-call "hostCall" :VERB_SELECTOR "VERB_SELECTOR" :render-dom-element "renderDomElement" :escape-html "escapeHtml" :parse-sse-swap "parseSseSwap" :disable-elements "disableElements" :starts-with? "startsWith" :parse-env-attr "parseEnvAttr" :ho-some "hoSome" :eval-cond-scheme "evalCondScheme" :ends-with? "endsWith" :>= "gte_" :dom-dispatch "domDispatch" :preload-cache-set "preloadCacheSet" :signal-subscribers "signalSubscribers" :step-sf-provide "stepSfProvide" :signal-add-sub! "signalAddSub" :render-lambda-html "renderLambdaHtml" :dom-set-data "domSetData" :make-thread-frame "makeThreadFrame" :make-sx-expr "makeSxExpr" :pop-wind! "popWind" :dom-append-to-head "domAppendToHead" :hoist-head-elements "hoistHeadElements" :make-reset-frame "makeResetFrame" :flush-subscribers "flushSubscribers" :controller-signal "controllerSignal" :clear-interval "clearInterval_" :children-to-fragment "childrenToFragment" :sx-render-component "sxRenderComponent" :with-transition "withTransition" :scan-io-refs-walk "scanIoRefsWalk" :step-sf-scope "stepSfScope" :get-primitive "getPrimitive" :_preload-cache "_preloadCache" :select-html-from-doc "selectHtmlFromDoc" :browser-location-href "browserLocationHref" :sf-case-loop "sfCaseLoop" :sf-dynamic-wind "sfDynamicWind" :symbol-name "symbolName" :set-lambda-name! "setLambdaName" :host-get "hostGet" :aser-fragment "aserFragment" :render-dom-unknown-component "renderDomUnknownComponent" :!= "notEqual_" :SX_VERSION "SX_VERSION" :render-html-element "renderHtmlElement" :dom-first-child "domFirstChild" :bind-client-route-click "bindClientRouteClick" :sf-cond-clojure "sfCondClojure" :MATH_NS "MATH_NS" :default-trigger "defaultTrigger" :signal-remove-sub! "signalRemoveSub" :make-cek-state "makeCekState" :emit! "sxEmit" :sf-quote "sfQuote" :bind-boost-form "bindBoostForm" :component-params "componentParams" :do-preload "doPreload" :component-affinity "componentAffinity" :eval-case-aser "evalCaseAser" :sf-begin "sfBegin" :revert-optimistic "revertOptimistic" :whitespace? "isWhitespace" :host-typeof "hostTypeof" :dom-insert-adjacent-html "domInsertAdjacentHtml" :step-sf-set! "stepSfSet" :error-message "errorMessage" :schedule-idle "scheduleIdle" :find-matching-route "findMatchingRoute" :component-body "componentBody" :qq-expand "qqExpand" :provide-push! "providePush" :make-keyword "makeKeyword" :do-fetch "doFetch" :component-deps "componentDeps" :component-set-io-refs! "componentSetIoRefs" :escape-string "escapeString" :make-island "makeIsland" :nil "NIL" :log-parse-error "logParseError" :enable-cek-reactive! "enableCekReactive" :signal-set-value! "signalSetValue" :env-set! "envSet" :clear-timeout "clearTimeout_" :sf-defcomp "sfDefcomp" :step-ho-map "stepHoMap" :dom-parse-html "domParseHtml" :make-lambda "makeLambda" :sf-if "sfIf" :make-route-segment "makeRouteSegment" :lambda-closure "lambdaClosure" :render-target "renderTarget" :dom-attr-list "domAttrList" :log-warn "logWarn" :eval-call "evalCall" :sync-attrs "syncAttrs" :make-case-frame "makeCaseFrame" :render-dom-component "renderDomComponent" :dom-child-nodes "domChildNodes" :collect! "sxCollect" :use-store "useStore" :classify-trigger "classifyTrigger" :engine-init "engineInit" :list? "isList" :index-of "indexOf_" :component-io-refs "componentIoRefs" :dom-remove "domRemove" :set-document-title "setDocumentTitle" :primitive? "isPrimitive" :parse-trigger-spec "parseTriggerSpec" :local-storage-get "localStorageGet" :dom-get-data "domGetData" :scan-refs-walk "scanRefsWalk" :abort-previous-target "abortPreviousTarget" :thunk-expr "thunkExpr" :create-comment "createComment" :component-closure "componentClosure" :render-dom-form? "isRenderDomForm" :sx-render-with-env "sxRenderWithEnv" :cek-phase "cekPhase" :prevent-default "preventDefault_" :true "true" :definition-form? "isDefinitionForm" :make-map-frame "makeMapFrame" :scope-pop! "scopePop" :contains? "contains" :bind-preload-for "bindPreloadFor" :dom-focus "domFocus" :sf-thread-first "sfThreadFirst" :find-oob-swaps "findOobSwaps" :dom-query-by-id "domQueryById" :handle-sx-response "handleSxResponse" :page-css-classes "pageCssClasses" :odd? "isOdd" :compute-all-deps "computeAllDeps" :has-reactive-reset-frame? "hasReactiveResetFrame_p" :sx-expr-source "sxExprSource" :render-html-form? "isRenderHtmlForm" :lambda-name "lambdaName" :parse-number "parseNumber" :regex-find-all "regexFindAll" :step-sf-define "stepSfDefine" :resolve-mount-target "resolveMountTarget" :emitted "sxEmitted" :browser-push-state "browserPushState" :signal-value "signalValue" :sf-defmacro "sfDefmacro" :swap-dom-nodes "swapDomNodes" :scan-components-from-source "scanComponentsFromSource" :lambda-body "lambdaBody" :scope-peek "scopePeek" :signal-deps "signalDeps" :aser-call "aserCall" :bind-sse-swap "bindSseSwap" :make-for-each-frame "makeForEachFrame" :make-and-frame "makeAndFrame" :parse-macro-params "parseMacroParams" :dispatch-trigger-events "dispatchTriggerEvents" :event-source-connect "eventSourceConnect" :type-of "typeOf" :map-indexed "mapIndexed" :render-lambda-dom "renderLambdaDom" :boot-init "bootInit" :clear-collected! "sxClearCollected" :render-value-to-html "renderValueToHtml" :dispatch-html-form "dispatchHtmlForm" :should-boost-link? "shouldBoostLink" :step-eval "stepEval" :morph-node "morphNode" :track-controller "trackController" :cek-kont "cekKont" :dom-query-all "domQueryAll" :env-merge "envMerge" :raw-html-content "rawHtmlContent" :reactive-fragment "reactiveFragment" :ho-map "hoMap" :browser-scroll-to "browserScrollTo" :render-attrs "renderAttrs" :RENDER_HTML_FORMS "RENDER_HTML_FORMS" :make-reduce-frame "makeReduceFrame" :*batch-depth* "_batchDepth" :kf-name "kfName" :parse-retry-spec "parseRetrySpec" :dom-document "domDocument" :render-to-sx "renderToSx" :host-global "hostGlobal" :scan-refs "scanRefs" :dom-replace-child "domReplaceChild" :signal-set-deps! "signalSetDeps" :empty-dict? "isEmptyDict" :execute-request "executeRequest" :step-eval-list "stepEvalList" :zero? "isZero" :dom-remove-child "domRemoveChild" :compute-all-io-refs "computeAllIoRefs" :sx-render "sxRender" :components-needed "componentsNeeded" :host-set! "hostSet" :sf-case "sfCase" :make-cek-continuation "makeCekContinuation" :sf-let "sfLet" :cek-env "cekEnv" :step-sf-lambda "stepSfLambda" :notify-subscribers "notifySubscribers" :*render-check* "_renderCheck" :step-sf-deref "stepSfDeref" :browser-media-matches? "browserMediaMatches" :parse-time "parseTime" :process-elements "processElements" :try-catch "tryCatch" :filter-params "filterParams" :ident-start? "isIdentStart" :format-date "formatDate" :def-store "defStore" :post-swap "postSwap" :fetch-preload "fetchPreload" :is-processed? "isProcessed" :call-lambda "callLambda" :_page-routes "_pageRoutes" :continuation-data "continuationData" :try-client-route "tryClientRoute" :merge-spread-attrs "mergeSpreadAttrs" :*use-cek-reactive* "_useCekReactive" :cek-step "cekStep" :promise-resolve "promiseResolve" :clear-processed! "clearProcessed" :step-sf-and "stepSfAnd" :strip-component-scripts "stripComponentScripts" :split-path-segments "splitPathSegments" :<= "lte_" :dom-has-class? "domHasClass" :bind-event "bindEvent" :render-to-html "renderToHtml" :dom-add-class "domAddClass" :process-one "processOne" :sx-hydrate "sxHydrate" :render-active? "renderActiveP" :collected "sxCollected" :clear-stores "clearStores" :dom-get-prop "domGetProp" :empty? "isEmpty" :step-sf-when "stepSfWhen" :strip-tags "stripTags" :component-has-children? "componentHasChildren" :VOID_ELEMENTS "VOID_ELEMENTS" :promise-then "promiseThen" :parse-swap-spec "parseSwapSpec" :json-parse "jsonParse" :dom-parent "domParent" :process-oob-swaps "processOobSwaps" :signal? "isSignal" :local-storage-remove "localStorageRemove" :register-io-deps "registerIoDeps" :parse-route-pattern "parseRoutePattern" :process-sx-scripts "processSxScripts" :*store-registry* "_storeRegistry" :dom-ensure-element "domEnsureElement" :eval-expr "evalExpr" :transitive-deps "transitiveDeps" :make-set-frame "makeSetFrame" :get-render-env "getRenderEnv" :sf-named-let "sfNamedLet" :reactive-shift-deref "reactiveShiftDeref" :escape-attr "escapeAttr" :process-component-script "processComponentScript" :transitive-io-refs "transitiveIoRefs" :component-pure? "componentPure_p" :sf-and "sfAnd" :apply-optimistic "applyOptimistic" :ho-every "hoEvery" :dom-parse-html-document "domParseHtmlDocument" :island? "isIsland" :emit-event "emitEvent" :step-ho-reduce "stepHoReduce" :render-dom-raw "renderDomRaw" :clear-loading-state "clearLoadingState" :dom-clone "domClone" :fetch-and-restore "fetchAndRestore" :render-dom-island "renderDomIsland" :step-sf-begin "stepSfBegin" :to-kebab "toKebab" :replace "replace_" :mark-processed! "markProcessed" :insert-remaining-siblings "insertRemainingSiblings" :sx-update-element "sxUpdateElement" :env-extend "envExtend" :handle-html-response "handleHtmlResponse" :dict-delete! "dictDelete" :make-component "makeComponent" :make-cond-frame "makeCondFrame" :sx-load-components "sxLoadComponents" :sf-lambda "sfLambda" :abort-previous "abortPrevious" :step-eval-call "stepEvalCall" :store-env-attr "storeEnvAttr" :chunk-every "chunkEvery" :dom-append "domAppend" :eval-cond-clojure "evalCondClojure" :morph-children "morphChildren" :make-when-frame "makeWhenFrame" :frame-type "frameType" :dom-set-inner-html "domSetInnerHtml" :process-response-headers "processResponseHeaders" :dom-query "domQuery" :dom-remove-class "domRemoveClass" :thunk? "isThunk" :kont-pop "kontPop" :eval-list "evalList" :resolve-target "resolveTarget" :dom-is-child-of? "domIsChildOf" :lambda? "isLambda" :dom-insert-after "domInsertAfter" :make-dynamic-wind-frame "makeDynamicWindFrame" :promise-catch "promiseCatch" :host-new "hostNew" :kont-capture-to-reactive-reset "kontCaptureToReactiveReset" :serialize-island-state "serializeIslandState" :handle-retry "handleRetry" :step-sf-thread-first "stepSfThreadFirst" :make-reactive-reset-frame "makeReactiveResetFrame" :dom-listen "domListen" :even? "isEven" :get-verb-info "getVerbInfo" :dispose-island "disposeIsland" :dom-child-list "domChildList" :log-info "logInfo" :macro-closure "macroClosure" :dict-has? "dictHas" :browser-reload "browserReload" :cond-scheme? "condScheme_p" :make-scope-frame "makeScopeFrame" :sf-define "sfDefine" :ident-char? "isIdentChar" :sx-serialize "sxSerialize" :render-dom-fragment "renderDomFragment" :dom-has-attr? "domHasAttr" :dom-is-active-element? "domIsActiveElement" :dom-create-element "domCreateElement" :create-text-node "createTextNode" :lambda-params "lambdaParams" :host-await "hostAwait" :macro? "isMacro" :dom-text-content "domTextContent" :step-sf-case "stepSfCase" :request-animation-frame "requestAnimationFrame_" :sf-case-step-loop "sfCaseStepLoop" :process-boosted "processBoosted" :sf-cond "sfCond" :dom-head "domHead" :component-io-refs-cached "componentIoRefsCached" :bind-triggers "bindTriggers" :every? "isEvery" :dom-closest "domClosest" :component? "isComponent" :make-handler-def "makeHandlerDef" :should-boost-form? "shouldBoostForm" :parse-header-value "parseHeaderValue" :render-to-dom "renderToDom" :make-or-frame "makeOrFrame" :has-key? "dictHas" :dom-body-inner-html "domBodyInnerHtml" :process-css-response "processCssResponse" :url-pathname "urlPathname" :aser-special "aserSpecial" :create-script-clone "createScriptClone" :match-route-segments "matchRouteSegments" :cek-reactive-text "cekReactiveText" :PRELOAD_TTL "PRELOAD_TTL" :cek-control "cekControl" :bridge-event "bridgeEvent" :resolve-suspense "resolveSuspense" :dom-remove-children-after "domRemoveChildrenAfter" :track-controller-target "trackControllerTarget" :clear-sx-comp-cookie "clearSxCompCookie" :cross-origin? "isCrossOrigin" :extract-response-css "extractResponseCss" :bind-sse "bindSse" :show-indicator "showIndicator" :bind-client-route-link "bindClientRouteLink" :scope-push! "scopePush" :component-set-deps! "componentSetDeps" :element-value "elementValue" :cek-try "cekTry" :make-page-def "makePageDef" :render-html-component "renderHtmlComponent" :ENGINE_VERBS "ENGINE_VERBS" :process-sse "processSse" :loaded-component-names "loadedComponentNames" :browser-replace-state "browserReplaceState" :dom-next-sibling "domNextSibling" :sf-when "sfWhen" :sx-mount "sxMount" :make-query-def "makeQueryDef" :activate-scripts "activateScripts" :now-ms "nowMs" :bind-preload "bindPreload" :preload-cache-get "preloadCacheGet" :validate-for-request "validateForRequest" :BOOLEAN_ATTRS "BOOLEAN_ATTRS" :digit? "isDigit" :zip-pairs "zipPairs" :dom-set-text-content "domSetTextContent" :parse-keyword-args "parseKeywordArgs" :ho-map-indexed "hoMapIndexed" :cek-value "cekValue" :env-components "envComponents" :dict? "isDict" :is-else-clause? "isElseClause" :reactive-attr "reactiveAttr" :sf-quasiquote "sfQuasiquote" :create-fragment "createFragment" :is-render-expr? "isRenderExpr" :spread-attrs "spreadAttrs" :render-html-island "renderHtmlIsland" :aser-list "aserList" :provide-pop! "providePop" :swap-html-string "swapHtmlString" :render-expr "renderExpr" :dom-set-attr "domSetAttr" :boost-descendants "boostDescendants" :browser-prompt "browserPrompt" :HEAD_HOIST_SELECTOR "HEAD_HOIST_SELECTOR" :make-deref-frame "makeDerefFrame" :dom-tag-name "domTagName" :scope-emitted "sxEmitted" :query-sx-scripts "querySxScripts" :strip-prefix "stripPrefix" :scan-io-refs "scanIoRefs" :step-sf-cond "stepSfCond" :dom-id "domId" :dom-body "domBody" :make-macro "makeMacro" :identical? "isIdentical" :cek-reactive-attr "cekReactiveAttr" :step-sf-or "stepSfOr" :render-dom-list "renderDomList" :init-css-tracking "initCssTracking" :sx-serialize-dict "sxSerializeDict" :try-async-eval-content "tryAsyncEvalContent" :register-in-scope "registerInScope" :cek-terminal? "cekTerminal_p" :step-ho-filter "stepHoFilter" :sf-set! "sfSetBang" :false "false" :browser-navigate "browserNavigate" :dom-node-type "domNodeType" :bind-boost-link "bindBoostLink" :scan-css-classes "scanCssClasses" :dom-matches? "domMatches" :set-sx-comp-cookie "setSxCompCookie" :ho-reduce "hoReduce" :ho-form? "isHoForm" :macro-params "macroParams" :on-event "onEvent" :parse-int "parseInt_" :step-sf-reset "stepSfReset" :*render-fn* "_renderFn" :dom-outer-html "domOuterHtml" :special-form? "isSpecialForm" :observe-intersection "observeIntersection" :make-env "makeEnv" :make-signal "makeSignal" :push-wind! "pushWind" :dom-set-prop "domSetProp" :eval-expr-cek "evalExprCek" :callable? "isCallable" :sf-defisland "sfDefisland" :kont-capture-to-reset "kontCaptureToReset" :handle-fetch-success "handleFetchSuccess" :dom-get-style "domGetStyle" :sf-cond-scheme "sfCondScheme" :keyword-name "keywordName" :env-bind! "envBind" :map-dict "mapDict" :host-callback "hostCallback" :remove-head-element "removeHeadElement" :context "sxContext" :dom-is-input-element? "domIsInputElement" :spread? "isSpread" :make-cek-value "makeCekValue" :step-continue "stepContinue" :dom-window "domWindow" :hydrate-island "hydrateIsland" :make-action-def "makeActionDef" :kont-empty? "kontEmpty_p" :make-filter-frame "makeFilterFrame" :make-thunk "makeThunk" :make-symbol "makeSymbol" :dict-get "dictGet" :dispatch-render-form "dispatchRenderForm" :dom-prepend "domPrepend" :make-begin-frame "makeBeginFrame" :merge-envs "mergeEnvs" :continue-with-call "continueWithCall" :browser-confirm "browserConfirm" :make-spread "makeSpread" :register-special-form! "registerSpecialForm" :csrf-token "csrfToken" :for-each "forEach" :make-dict-frame "makeDictFrame" :trampoline-cek "trampolineCek" :sf-letrec "sfLetrec" :DEFAULT_SWAP "DEFAULT_SWAP" :component-name "componentName" :*batch-queue* "_batchQueue" :component-css-classes "componentCssClasses" :make-arg-frame "makeArgFrame" :dict-set! "dictSet" :step-sf-let "stepSfLet" :browser-same-origin? "browserSameOrigin" :sx-hydrate-islands "sxHydrateIslands" :make-define-frame "makeDefineFrame" :process-page-scripts "processPageScripts" :ho-for-each "hoForEach" :stop-propagation "stopPropagation_" :sx-process-scripts "sxProcessScripts" :make-if-frame "makeIfFrame" :sf-or "sfOr" :dom-insert-before "domInsertBefore" :step-sf-shift "stepSfShift" :format-decimal "formatDecimal" :json-serialize "jsonSerialize" :defcomp-kwarg "defcompKwarg" :reactive-text "reactiveText" :dom-remove-attr "domRemoveAttr" :eval-cond "evalCond" :_css-hash "_cssHash" :fetch-location "fetchLocation" :sx-hydrate-elements "sxHydrateElements" :dispose-computed "disposeComputed" :abort-error? "isAbortError" :set-timeout "setTimeout_" :new-abort-controller "newAbortController" :nil? "isNil" :env-get "envGet" :call-component "callComponent" :SVG_NS "SVG_NS" :RENDER_DOM_FORMS "RENDER_DOM_FORMS" :build-request-headers "buildRequestHeaders" :page-component-bundle "pageComponentBundle" :render-list-to-html "renderListToHtml" :string? "isString" :dom-node-name "domNodeName" :hoist-head-elements-full "hoistHeadElementsFull"}) +(define js-renames {:ho-filter "hoFilter" :thunk-env "thunkEnv" :cek-run "cekRun" :*custom-special-forms* "_customSpecialForms" :with-island-scope "withIslandScope" :step-sf-if "stepSfIf" :dom-is-fragment? "domIsFragment" :process-bindings "processBindings" :call-thunk "callThunk" :fetch-streaming "fetchStreaming" :bind-inline-handlers "bindInlineHandlers" :set-interval "setInterval_" :number? "isNumber" :reactive-list "reactiveList" :expand-macro "expandMacro" :handle-history "handleHistory" :page-render-plan "pageRenderPlan" :make-let-frame "makeLetFrame" :parse-comp-params "parseCompParams" :next-retry-ms "nextRetryMs" :fetch-request "fetchRequest" :kont-push "kontPush" :macro-body "macroBody" :for-each-indexed "forEachIndexed" :step-ho-for-each "stepHoForEach" :set-render-active! "setRenderActiveB" :local-storage-set "localStorageSet" :dom-get-attr "domGetAttr" :parse-element-args "parseElementArgs" :process-emit-elements "processEmitElements" :build-request-body "buildRequestBody" :kont-top "kontTop" :event-detail "eventDetail" :match-route "matchRoute" :handle-popstate "handlePopstate" :event-source-listen "eventSourceListen" :select-from-container "selectFromContainer" :try-eval-content "tryEvalContent" :query-page-scripts "queryPageScripts" :scope-emit! "scopeEmit" :promise-delayed "promiseDelayed" :make-call-frame "makeCallFrame" :HTML_TAGS "HTML_TAGS" :macro-rest-param "macroRestParam" :env-has? "envHas" :make-raw-html "makeRawHtml" :dom-set-style "domSetStyle" :try-parse-json "tryParseJson" :host-call "hostCall" :VERB_SELECTOR "VERB_SELECTOR" :render-dom-element "renderDomElement" :escape-html "escapeHtml" :parse-sse-swap "parseSseSwap" :disable-elements "disableElements" :starts-with? "startsWith" :parse-env-attr "parseEnvAttr" :ho-some "hoSome" :eval-cond-scheme "evalCondScheme" :ends-with? "endsWith" :>= "gte_" :dom-dispatch "domDispatch" :preload-cache-set "preloadCacheSet" :signal-subscribers "signalSubscribers" :step-sf-provide "stepSfProvide" :signal-add-sub! "signalAddSub" :render-lambda-html "renderLambdaHtml" :dom-set-data "domSetData" :make-thread-frame "makeThreadFrame" :make-sx-expr "makeSxExpr" :pop-wind! "popWind" :dom-append-to-head "domAppendToHead" :hoist-head-elements "hoistHeadElements" :make-reset-frame "makeResetFrame" :flush-subscribers "flushSubscribers" :controller-signal "controllerSignal" :clear-interval "clearInterval_" :children-to-fragment "childrenToFragment" :sx-render-component "sxRenderComponent" :with-transition "withTransition" :scan-io-refs-walk "scanIoRefsWalk" :step-sf-scope "stepSfScope" :get-primitive "getPrimitive" :_preload-cache "_preloadCache" :select-html-from-doc "selectHtmlFromDoc" :browser-location-href "browserLocationHref" :sf-case-loop "sfCaseLoop" :sf-dynamic-wind "sfDynamicWind" :symbol-name "symbolName" :set-lambda-name! "setLambdaName" :host-get "hostGet" :aser-fragment "aserFragment" :render-dom-unknown-component "renderDomUnknownComponent" :!= "notEqual_" :SX_VERSION "SX_VERSION" :render-html-element "renderHtmlElement" :dom-first-child "domFirstChild" :bind-client-route-click "bindClientRouteClick" :sf-cond-clojure "sfCondClojure" :MATH_NS "MATH_NS" :default-trigger "defaultTrigger" :signal-remove-sub! "signalRemoveSub" :make-cek-state "makeCekState" :emit! "sxEmit" :sf-quote "sfQuote" :bind-boost-form "bindBoostForm" :component-params "componentParams" :do-preload "doPreload" :component-affinity "componentAffinity" :eval-case-aser "evalCaseAser" :sf-begin "sfBegin" :revert-optimistic "revertOptimistic" :whitespace? "isWhitespace" :host-typeof "hostTypeof" :dom-insert-adjacent-html "domInsertAdjacentHtml" :step-sf-set! "stepSfSet" :error-message "errorMessage" :schedule-idle "scheduleIdle" :find-matching-route "findMatchingRoute" :component-body "componentBody" :qq-expand "qqExpand" :provide-push! "providePush" :make-keyword "makeKeyword" :do-fetch "doFetch" :component-deps "componentDeps" :component-set-io-refs! "componentSetIoRefs" :escape-string "escapeString" :make-island "makeIsland" :nil "NIL" :log-parse-error "logParseError" :enable-cek-reactive! "enableCekReactive" :signal-set-value! "signalSetValue" :env-set! "envSet" :clear-timeout "clearTimeout_" :sf-defcomp "sfDefcomp" :step-ho-map "stepHoMap" :dom-parse-html "domParseHtml" :make-lambda "makeLambda" :sf-if "sfIf" :make-route-segment "makeRouteSegment" :lambda-closure "lambdaClosure" :render-target "renderTarget" :dom-attr-list "domAttrList" :log-warn "logWarn" :eval-call "evalCall" :sync-attrs "syncAttrs" :make-case-frame "makeCaseFrame" :render-dom-component "renderDomComponent" :dom-child-nodes "domChildNodes" :collect! "sxCollect" :use-store "useStore" :classify-trigger "classifyTrigger" :engine-init "engineInit" :list? "isList" :index-of "indexOf_" :component-io-refs "componentIoRefs" :dom-remove "domRemove" :set-document-title "setDocumentTitle" :primitive? "isPrimitive" :parse-trigger-spec "parseTriggerSpec" :local-storage-get "localStorageGet" :dom-get-data "domGetData" :scan-refs-walk "scanRefsWalk" :abort-previous-target "abortPreviousTarget" :thunk-expr "thunkExpr" :create-comment "createComment" :component-closure "componentClosure" :render-dom-form? "isRenderDomForm" :sx-render-with-env "sxRenderWithEnv" :cek-phase "cekPhase" :prevent-default "preventDefault_" :true "true" :definition-form? "isDefinitionForm" :make-map-frame "makeMapFrame" :scope-pop! "scopePop" :contains? "contains" :bind-preload-for "bindPreloadFor" :dom-focus "domFocus" :sf-thread-first "sfThreadFirst" :find-oob-swaps "findOobSwaps" :dom-query-by-id "domQueryById" :handle-sx-response "handleSxResponse" :page-css-classes "pageCssClasses" :odd? "isOdd" :compute-all-deps "computeAllDeps" :has-reactive-reset-frame? "hasReactiveResetFrame_p" :sx-expr-source "sxExprSource" :render-html-form? "isRenderHtmlForm" :lambda-name "lambdaName" :parse-number "parseNumber" :regex-find-all "regexFindAll" :step-sf-define "stepSfDefine" :resolve-mount-target "resolveMountTarget" :emitted "sxEmitted" :browser-push-state "browserPushState" :signal-value "signalValue" :sf-defmacro "sfDefmacro" :swap-dom-nodes "swapDomNodes" :scan-components-from-source "scanComponentsFromSource" :lambda-body "lambdaBody" :scope-peek "scopePeek" :signal-deps "signalDeps" :aser-call "aserCall" :bind-sse-swap "bindSseSwap" :make-for-each-frame "makeForEachFrame" :make-and-frame "makeAndFrame" :parse-macro-params "parseMacroParams" :dispatch-trigger-events "dispatchTriggerEvents" :event-source-connect "eventSourceConnect" :type-of "typeOf" :map-indexed "mapIndexed" :render-lambda-dom "renderLambdaDom" :boot-init "bootInit" :clear-collected! "sxClearCollected" :render-value-to-html "renderValueToHtml" :dispatch-html-form "dispatchHtmlForm" :should-boost-link? "shouldBoostLink" :step-eval "stepEval" :morph-node "morphNode" :track-controller "trackController" :cek-kont "cekKont" :dom-query-all "domQueryAll" :env-merge "envMerge" :raw-html-content "rawHtmlContent" :reactive-fragment "reactiveFragment" :ho-map "hoMap" :browser-scroll-to "browserScrollTo" :render-attrs "renderAttrs" :RENDER_HTML_FORMS "RENDER_HTML_FORMS" :make-reduce-frame "makeReduceFrame" :*batch-depth* "_batchDepth" :kf-name "kfName" :parse-retry-spec "parseRetrySpec" :dom-document "domDocument" :render-to-sx "renderToSx" :host-global "hostGlobal" :scan-refs "scanRefs" :dom-replace-child "domReplaceChild" :signal-set-deps! "signalSetDeps" :empty-dict? "isEmptyDict" :execute-request "executeRequest" :step-eval-list "stepEvalList" :zero? "isZero" :dom-remove-child "domRemoveChild" :compute-all-io-refs "computeAllIoRefs" :sx-render "sxRender" :components-needed "componentsNeeded" :host-set! "hostSet" :sf-case "sfCase" :make-cek-continuation "makeCekContinuation" :sf-let "sfLet" :cek-env "cekEnv" :step-sf-lambda "stepSfLambda" :notify-subscribers "notifySubscribers" :*render-check* "_renderCheck" :step-sf-deref "stepSfDeref" :browser-media-matches? "browserMediaMatches" :parse-time "parseTime" :process-elements "processElements" :try-catch "tryCatch" :filter-params "filterParams" :ident-start? "isIdentStart" :format-date "formatDate" :def-store "defStore" :post-swap "postSwap" :fetch-preload "fetchPreload" :is-processed? "isProcessed" :call-lambda "callLambda" :_page-routes "_pageRoutes" :continuation-data "continuationData" :try-client-route "tryClientRoute" :merge-spread-attrs "mergeSpreadAttrs" :*use-cek-reactive* "_useCekReactive" :cek-step "cekStep" :promise-resolve "promiseResolve" :clear-processed! "clearProcessed" :step-sf-and "stepSfAnd" :strip-component-scripts "stripComponentScripts" :split-path-segments "splitPathSegments" :<= "lte_" :dom-has-class? "domHasClass" :bind-event "bindEvent" :render-to-html "renderToHtml" :dom-add-class "domAddClass" :process-one "processOne" :sx-hydrate "sxHydrate" :render-active? "renderActiveP" :collected "sxCollected" :clear-stores "clearStores" :dom-get-prop "domGetProp" :empty? "isEmpty" :step-sf-when "stepSfWhen" :strip-tags "stripTags" :component-has-children? "componentHasChildren" :VOID_ELEMENTS "VOID_ELEMENTS" :promise-then "promiseThen" :parse-swap-spec "parseSwapSpec" :json-parse "jsonParse" :dom-parent "domParent" :process-oob-swaps "processOobSwaps" :signal? "isSignal" :local-storage-remove "localStorageRemove" :register-io-deps "registerIoDeps" :parse-route-pattern "parseRoutePattern" :process-sx-scripts "processSxScripts" :*store-registry* "_storeRegistry" :dom-ensure-element "domEnsureElement" :eval-expr "evalExpr" :transitive-deps "transitiveDeps" :make-set-frame "makeSetFrame" :get-render-env "getRenderEnv" :sf-named-let "sfNamedLet" :reactive-shift-deref "reactiveShiftDeref" :escape-attr "escapeAttr" :process-component-script "processComponentScript" :transitive-io-refs "transitiveIoRefs" :component-pure? "componentPure_p" :sf-and "sfAnd" :apply-optimistic "applyOptimistic" :ho-every "hoEvery" :dom-parse-html-document "domParseHtmlDocument" :island? "isIsland" :emit-event "emitEvent" :step-ho-reduce "stepHoReduce" :render-dom-raw "renderDomRaw" :clear-loading-state "clearLoadingState" :dom-clone "domClone" :fetch-and-restore "fetchAndRestore" :render-dom-island "renderDomIsland" :step-sf-begin "stepSfBegin" :to-kebab "toKebab" :replace "replace_" :mark-processed! "markProcessed" :insert-remaining-siblings "insertRemainingSiblings" :sx-update-element "sxUpdateElement" :env-extend "envExtend" :handle-html-response "handleHtmlResponse" :dict-delete! "dictDelete" :make-component "makeComponent" :make-cond-frame "makeCondFrame" :sx-load-components "sxLoadComponents" :sf-lambda "sfLambda" :abort-previous "abortPrevious" :step-eval-call "stepEvalCall" :store-env-attr "storeEnvAttr" :chunk-every "chunkEvery" :dom-append "domAppend" :eval-cond-clojure "evalCondClojure" :morph-children "morphChildren" :make-when-frame "makeWhenFrame" :frame-type "frameType" :dom-set-inner-html "domSetInnerHtml" :process-response-headers "processResponseHeaders" :dom-query "domQuery" :dom-remove-class "domRemoveClass" :thunk? "isThunk" :kont-pop "kontPop" :eval-list "evalList" :resolve-target "resolveTarget" :dom-is-child-of? "domIsChildOf" :lambda? "isLambda" :dom-insert-after "domInsertAfter" :make-dynamic-wind-frame "makeDynamicWindFrame" :promise-catch "promiseCatch" :host-new "hostNew" :kont-capture-to-reactive-reset "kontCaptureToReactiveReset" :serialize-island-state "serializeIslandState" :handle-retry "handleRetry" :step-sf-thread-first "stepSfThreadFirst" :make-reactive-reset-frame "makeReactiveResetFrame" :dom-listen "domListen" :even? "isEven" :get-verb-info "getVerbInfo" :dispose-island "disposeIsland" :dom-child-list "domChildList" :log-info "logInfo" :macro-closure "macroClosure" :dict-has? "dictHas" :browser-reload "browserReload" :cond-scheme? "condScheme_p" :make-scope-frame "makeScopeFrame" :sf-define "sfDefine" :ident-char? "isIdentChar" :sx-serialize "sxSerialize" :render-dom-fragment "renderDomFragment" :dom-has-attr? "domHasAttr" :dom-is-active-element? "domIsActiveElement" :dom-create-element "domCreateElement" :create-text-node "createTextNode" :lambda-params "lambdaParams" :host-await "hostAwait" :macro? "isMacro" :dom-text-content "domTextContent" :step-sf-case "stepSfCase" :request-animation-frame "requestAnimationFrame_" :sf-case-step-loop "sfCaseStepLoop" :process-boosted "processBoosted" :sf-cond "sfCond" :dom-head "domHead" :component-io-refs-cached "componentIoRefsCached" :bind-triggers "bindTriggers" :every? "isEvery" :dom-closest "domClosest" :component? "isComponent" :make-handler-def "makeHandlerDef" :should-boost-form? "shouldBoostForm" :parse-header-value "parseHeaderValue" :render-to-dom "renderToDom" :make-or-frame "makeOrFrame" :has-key? "dictHas" :dom-body-inner-html "domBodyInnerHtml" :process-css-response "processCssResponse" :url-pathname "urlPathname" :aser-special "aserSpecial" :create-script-clone "createScriptClone" :match-route-segments "matchRouteSegments" :cek-reactive-text "cekReactiveText" :PRELOAD_TTL "PRELOAD_TTL" :cek-control "cekControl" :bridge-event "bridgeEvent" :resolve-suspense "resolveSuspense" :dom-remove-children-after "domRemoveChildrenAfter" :track-controller-target "trackControllerTarget" :clear-sx-comp-cookie "clearSxCompCookie" :cross-origin? "isCrossOrigin" :extract-response-css "extractResponseCss" :bind-sse "bindSse" :show-indicator "showIndicator" :bind-client-route-link "bindClientRouteLink" :scope-push! "scopePush" :component-set-deps! "componentSetDeps" :element-value "elementValue" :cek-try "cekTry" :make-page-def "makePageDef" :render-html-component "renderHtmlComponent" :ENGINE_VERBS "ENGINE_VERBS" :process-sse "processSse" :loaded-component-names "loadedComponentNames" :browser-replace-state "browserReplaceState" :dom-next-sibling "domNextSibling" :sf-when "sfWhen" :sx-mount "sxMount" :make-query-def "makeQueryDef" :activate-scripts "activateScripts" :now-ms "nowMs" :bind-preload "bindPreload" :preload-cache-get "preloadCacheGet" :validate-for-request "validateForRequest" :BOOLEAN_ATTRS "BOOLEAN_ATTRS" :digit? "isDigit" :zip-pairs "zipPairs" :dom-set-text-content "domSetTextContent" :parse-keyword-args "parseKeywordArgs" :ho-map-indexed "hoMapIndexed" :cek-value "cekValue" :env-components "envComponents" :dict? "isDict" :is-else-clause? "isElseClause" :reactive-attr "reactiveAttr" :sf-quasiquote "sfQuasiquote" :create-fragment "createFragment" :is-render-expr? "isRenderExpr" :spread-attrs "spreadAttrs" :render-html-island "renderHtmlIsland" :aser-list "aserList" :provide-pop! "providePop" :swap-html-string "swapHtmlString" :render-expr "renderExpr" :dom-set-attr "domSetAttr" :boost-descendants "boostDescendants" :browser-prompt "browserPrompt" :HEAD_HOIST_SELECTOR "HEAD_HOIST_SELECTOR" :make-deref-frame "makeDerefFrame" :dom-tag-name "domTagName" :scope-emitted "sxEmitted" :query-sx-scripts "querySxScripts" :strip-prefix "stripPrefix" :scan-io-refs "scanIoRefs" :step-sf-cond "stepSfCond" :dom-id "domId" :dom-body "domBody" :make-macro "makeMacro" :identical? "isIdentical" :cek-reactive-attr "cekReactiveAttr" :step-sf-or "stepSfOr" :render-dom-list "renderDomList" :init-css-tracking "initCssTracking" :sx-serialize-dict "sxSerializeDict" :try-async-eval-content "tryAsyncEvalContent" :register-in-scope "registerInScope" :cek-terminal? "cekTerminal_p" :step-ho-filter "stepHoFilter" :sf-set! "sfSetBang" :false "false" :browser-navigate "browserNavigate" :dom-node-type "domNodeType" :bind-boost-link "bindBoostLink" :scan-css-classes "scanCssClasses" :dom-matches? "domMatches" :set-sx-comp-cookie "setSxCompCookie" :ho-reduce "hoReduce" :ho-form? "isHoForm" :macro-params "macroParams" :on-event "onEvent" :parse-int "parseInt_" :step-sf-reset "stepSfReset" :*render-fn* "_renderFn" :dom-outer-html "domOuterHtml" :special-form? "isSpecialForm" :observe-intersection "observeIntersection" :make-env "makeEnv" :make-signal "makeSignal" :push-wind! "pushWind" :dom-set-prop "domSetProp" :eval-expr-cek "evalExprCek" :callable? "isCallable" :sf-defisland "sfDefisland" :kont-capture-to-reset "kontCaptureToReset" :handle-fetch-success "handleFetchSuccess" :dom-get-style "domGetStyle" :sf-cond-scheme "sfCondScheme" :keyword-name "keywordName" :env-bind! "envBind" :map-dict "mapDict" :host-callback "hostCallback" :remove-head-element "removeHeadElement" :context "sxContext" :dom-is-input-element? "domIsInputElement" :spread? "isSpread" :make-cek-value "makeCekValue" :step-continue "stepContinue" :dom-window "domWindow" :hydrate-island "hydrateIsland" :make-action-def "makeActionDef" :kont-empty? "kontEmpty_p" :make-filter-frame "makeFilterFrame" :make-thunk "makeThunk" :make-symbol "makeSymbol" :dict-get "dictGet" :dispatch-render-form "dispatchRenderForm" :dom-prepend "domPrepend" :make-begin-frame "makeBeginFrame" :merge-envs "mergeEnvs" :continue-with-call "continueWithCall" :browser-confirm "browserConfirm" :make-spread "makeSpread" :register-special-form! "registerSpecialForm" :csrf-token "csrfToken" :for-each "forEach" :make-dict-frame "makeDictFrame" :trampoline-cek "trampolineCek" :sf-letrec "sfLetrec" :DEFAULT_SWAP "DEFAULT_SWAP" :component-name "componentName" :*batch-queue* "_batchQueue" :component-css-classes "componentCssClasses" :make-arg-frame "makeArgFrame" :dict-set! "dictSet" :step-sf-let "stepSfLet" :browser-same-origin? "browserSameOrigin" :sx-hydrate-islands "sxHydrateIslands" :make-define-frame "makeDefineFrame" :process-page-scripts "processPageScripts" :ho-for-each "hoForEach" :stop-propagation "stopPropagation_" :sx-process-scripts "sxProcessScripts" :make-if-frame "makeIfFrame" :sf-or "sfOr" :dom-insert-before "domInsertBefore" :step-sf-shift "stepSfShift" :format-decimal "formatDecimal" :json-serialize "jsonSerialize" :defcomp-kwarg "defcompKwarg" :reactive-text "reactiveText" :dom-remove-attr "domRemoveAttr" :eval-cond "evalCond" :_css-hash "_cssHash" :fetch-location "fetchLocation" :sx-hydrate-elements "sxHydrateElements" :dispose-computed "disposeComputed" :abort-error? "isAbortError" :set-timeout "setTimeout_" :new-abort-controller "newAbortController" :nil? "isNil" :env-get "envGet" :call-component "callComponent" :SVG_NS "SVG_NS" :RENDER_DOM_FORMS "RENDER_DOM_FORMS" :build-request-headers "buildRequestHeaders" :page-component-bundle "pageComponentBundle" :render-list-to-html "renderListToHtml" :string? "isString" :dom-node-name "domNodeName" :hoist-head-elements-full "hoistHeadElementsFull" :vector->list "vectorToList" :list->vector "listToVector" :vector? "isVector" :string->symbol "stringToSymbol" :symbol->string "symbolToString"}) + +(define js-char-renames {:integer->char "integerToChar" :string->list "stringToList" :char? "isChar" :char->integer "charToInteger" :list->string "listToString"}) (define js-mangle (fn ((name :as string)) (let - ((renamed (get js-renames name))) + ((renamed (or (get js-renames name) (get js-char-renames name)))) (if (not (nil? renamed)) renamed @@ -105,7 +107,10 @@ js-capitalize (fn ((s :as string)) - (if (empty? s) s (str (upper (slice s 0 1)) (slice s 1))))) + (if + (empty? s) + s + (str (upper (slice s 0 1)) (slice s 1))))) (define js-quote-string @@ -245,7 +250,10 @@ "\n" (map (fn (e) (js-statement e)) - (slice body-parts 0 (- (len body-parts) 1)))) + (slice + body-parts + 0 + (- (len body-parts) 1)))) (if (> (len body-parts) 1) "\n" "") (js-emit-tail-as-stmt name (last body-parts)))) " } else { return NIL; }")) @@ -351,7 +359,9 @@ (str (join "\n" - (map (fn (e) (js-statement e)) (slice body 0 (- (len body) 1)))) + (map + (fn (e) (js-statement e)) + (slice body 0 (- (len body) 1)))) (if (> (len body) 1) "\n" "") (js-emit-tail-as-stmt name (last body)))))) @@ -417,7 +427,10 @@ ((cond-e (js-expr (nth args 0))) (then-e (js-expr (nth args 1))) (else-e - (if (>= (len args) 3) (js-expr (nth args 2)) "NIL"))) + (if + (>= (len args) 3) + (js-expr (nth args 2)) + "NIL"))) (str "(isSxTruthy(" cond-e ") ? " then-e " : " else-e ")")) (= op "when") (js-emit-when expr) @@ -569,7 +582,9 @@ (define js-collect-params - (fn ((params :as list)) (js-collect-params-loop params 0 (list) nil))) + (fn + ((params :as list)) + (js-collect-params-loop params 0 (list) nil))) (define js-collect-params-loop @@ -698,7 +713,12 @@ (b) (let ((vname (if (= (type-of (first b)) "symbol") (symbol-name (first b)) (str (first b))))) - (str " var " (js-mangle vname) " = " (js-expr (nth b 1)) ";"))) + (str + " var " + (js-mangle vname) + " = " + (js-expr (nth b 1)) + ";"))) bindings) (js-parse-clojure-let-bindings bindings 0 (list)))))) @@ -786,7 +806,12 @@ ((vname (if (= (type-of (first b)) "symbol") (symbol-name (first b)) (str (first b))))) (append! parts - (str "var " (js-mangle vname) " = " (js-expr (nth b 1)) ";")))) + (str + "var " + (js-mangle vname) + " = " + (js-expr (nth b 1)) + ";")))) bindings) (js-append-clojure-bindings bindings parts 0))))) @@ -814,7 +839,8 @@ (fn (expr) (let - ((cond-e (js-expr (nth expr 1))) (body-parts (rest (rest expr)))) + ((cond-e (js-expr (nth expr 1))) + (body-parts (rest (rest expr)))) (if (= (len body-parts) 1) (str @@ -1000,7 +1026,9 @@ (define js-emit-dict-literal - (fn ((pairs :as list)) (str "{" (js-dict-pairs-str pairs 0 (list)) "}"))) + (fn + ((pairs :as list)) + (str "{" (js-dict-pairs-str pairs 0 (list)) "}"))) (define js-dict-pairs-str @@ -1102,7 +1130,11 @@ (js-expr (nth expr 3)) ";") (= name "append!") - (str (js-expr (nth expr 1)) ".push(" (js-expr (nth expr 2)) ");") + (str + (js-expr (nth expr 1)) + ".push(" + (js-expr (nth expr 2)) + ");") (= name "env-bind!") (str "envBind(" @@ -1178,7 +1210,8 @@ (fn (expr) (let - ((cond-e (js-expr (nth expr 1))) (body-parts (rest (rest expr)))) + ((cond-e (js-expr (nth expr 1))) + (body-parts (rest (rest expr)))) (str "if (isSxTruthy(" cond-e diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 823df835..cdae24d6 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -37,7 +37,10 @@ let rec deep_equal a b = match a, b with | Nil, Nil -> true | Bool a, Bool b -> a = b + | Integer a, Integer b -> a = b | Number a, Number b -> a = b + | Integer a, Number b -> float_of_int a = b + | Number a, Integer b -> a = float_of_int b | String a, String b -> a = b | Symbol a, Symbol b -> a = b | Keyword a, Keyword b -> a = b @@ -226,7 +229,7 @@ let make_test_env () = | [String s] -> let parsed = Sx_parser.parse_all s in (match parsed with - | [List (Symbol "sxbc" :: Number _ :: payload :: _)] -> payload + | [List (Symbol "sxbc" :: (Number _ | Integer _) :: payload :: _)] -> payload | _ -> raise (Eval_error "bytecode-deserialize: invalid sxbc format")) | _ -> raise (Eval_error "bytecode-deserialize: expected string")); @@ -240,7 +243,7 @@ let make_test_env () = | [String s] -> let parsed = Sx_parser.parse_all s in (match parsed with - | [List (Symbol "cek-state" :: Number _ :: payload :: _)] -> payload + | [List (Symbol "cek-state" :: (Number _ | Integer _) :: payload :: _)] -> payload | _ -> raise (Eval_error "cek-deserialize: invalid cek-state format")) | _ -> raise (Eval_error "cek-deserialize: expected string")); @@ -320,7 +323,10 @@ let make_test_env () = bind "identical?" (fun args -> match args with | [a; b] -> Bool (match a, b with + | Integer x, Integer y -> x = y | Number x, Number y -> x = y + | Integer x, Number y -> float_of_int x = y + | Number x, Integer y -> x = float_of_int y | String x, String y -> x = y | Bool x, Bool y -> x = y | Nil, Nil -> true @@ -366,11 +372,15 @@ let make_test_env () = bind "append!" (fun args -> match args with - | [ListRef r; v; Number n] when int_of_float n = 0 -> + | [ListRef r; v; (Number n)] when int_of_float n = 0 -> r := v :: !r; ListRef r (* prepend *) + | [ListRef r; v; (Integer 0)] -> + r := v :: !r; ListRef r (* prepend Integer index *) | [ListRef r; v] -> r := !r @ [v]; ListRef r (* append in place *) - | [List items; v; Number n] when int_of_float n = 0 -> + | [List items; v; (Number n)] when int_of_float n = 0 -> List (v :: items) (* immutable prepend *) + | [List items; v; (Integer 0)] -> + List (v :: items) (* immutable prepend Integer index *) | [List items; v] -> List (items @ [v]) (* immutable fallback *) | _ -> raise (Eval_error "append!: expected list and value")); @@ -546,7 +556,10 @@ let make_test_env () = bind "batch-begin!" (fun _args -> Sx_ref.batch_begin_b ()); bind "batch-end!" (fun _args -> Sx_ref.batch_end_b ()); bind "now-ms" (fun _args -> Number 1000.0); - bind "random-int" (fun args -> match args with [Number lo; _] -> Number lo | _ -> Number 0.0); + bind "random-int" (fun args -> match args with + | [Number lo; _] -> Number lo + | [Integer lo; _] -> Integer lo + | _ -> Integer 0); bind "try-rerender-page" (fun _args -> Nil); bind "collect!" (fun args -> match args with @@ -1107,6 +1120,47 @@ let make_test_env () = | _ :: _ -> String "confirmed" | _ -> Nil); + bind "values" (fun args -> + match args with + | [v] -> v + | vs -> + let d = Hashtbl.create 2 in + Hashtbl.replace d "_values" (Bool true); + Hashtbl.replace d "_list" (List vs); + Dict d); + + bind "call-with-values" (fun args -> + match args with + | [producer; consumer] -> + let result = Sx_ref.cek_call producer (List []) in + let spread = (match result with + | Dict d when (match Hashtbl.find_opt d "_values" with Some (Bool true) -> true | _ -> false) -> + (match Hashtbl.find_opt d "_list" with Some (List l) -> l | _ -> [result]) + | _ -> [result]) + in + Sx_ref.cek_call consumer (List spread) + | _ -> raise (Eval_error "call-with-values: expected 2 args")); + + bind "promise?" (fun args -> + match args with + | [v] -> Bool (Sx_ref.is_promise v) + | _ -> Bool false); + + bind "make-promise" (fun args -> + match args with + | [v] -> + let d = Hashtbl.create 4 in + Hashtbl.replace d "_promise" (Bool true); + Hashtbl.replace d "forced" (Bool true); + Hashtbl.replace d "value" v; + Dict d + | _ -> Nil); + + bind "force" (fun args -> + match args with + | [p] -> Sx_ref.force_promise p + | _ -> Nil); + env (* ====================================================================== *) @@ -1142,18 +1196,20 @@ let run_foundation_tests () = in Printf.printf "Suite: parser\n"; - assert_eq "number" (Number 42.0) (List.hd (parse_all "42")); + assert_eq "number" (Integer 42) (List.hd (parse_all "42")); assert_eq "string" (String "hello") (List.hd (parse_all "\"hello\"")); assert_eq "bool true" (Bool true) (List.hd (parse_all "true")); assert_eq "nil" Nil (List.hd (parse_all "nil")); assert_eq "keyword" (Keyword "class") (List.hd (parse_all ":class")); assert_eq "symbol" (Symbol "foo") (List.hd (parse_all "foo")); - assert_eq "list" (List [Symbol "+"; Number 1.0; Number 2.0]) (List.hd (parse_all "(+ 1 2)")); + assert_eq "list" (List [Symbol "+"; Integer 1; Integer 2]) (List.hd (parse_all "(+ 1 2)")); (match List.hd (parse_all "(div :class \"card\" (p \"hi\"))") with | List [Symbol "div"; Keyword "class"; String "card"; List [Symbol "p"; String "hi"]] -> incr pass_count; Printf.printf " PASS: nested list\n" | v -> incr fail_count; Printf.printf " FAIL: nested list — got %s\n" (Sx_types.inspect v)); (match List.hd (parse_all "'(1 2 3)") with + | List [Symbol "quote"; List [Integer 1; Integer 2; Integer 3]] -> + incr pass_count; Printf.printf " PASS: quote sugar\n" | List [Symbol "quote"; List [Number 1.0; Number 2.0; Number 3.0]] -> incr pass_count; Printf.printf " PASS: quote sugar\n" | v -> incr fail_count; Printf.printf " FAIL: quote sugar — got %s\n" (Sx_types.inspect v)); @@ -1161,7 +1217,7 @@ let run_foundation_tests () = | Dict d when dict_has d "a" && dict_has d "b" -> incr pass_count; Printf.printf " PASS: dict literal\n" | v -> incr fail_count; Printf.printf " FAIL: dict literal — got %s\n" (Sx_types.inspect v)); - assert_eq "comment" (Number 42.0) (List.hd (parse_all ";; comment\n42")); + assert_eq "comment" (Integer 42) (List.hd (parse_all ";; comment\n42")); assert_eq "string escape" (String "hello\nworld") (List.hd (parse_all "\"hello\\nworld\"")); assert_eq "multiple exprs" (Number 2.0) (Number (float_of_int (List.length (parse_all "(1 2 3) (4 5)")))); @@ -1978,6 +2034,10 @@ let run_spec_tests env test_files = (match Hashtbl.find_opt d "children" with | Some (List l) when i >= 0 && i < List.length l -> List.nth l i | _ -> (match Hashtbl.find_opt d (string_of_int i) with Some v -> v | None -> Nil)) + | [Dict d; Integer n] -> + (match Hashtbl.find_opt d "children" with + | Some (List l) when n >= 0 && n < List.length l -> List.nth l n + | _ -> (match Hashtbl.find_opt d (string_of_int n) with Some v -> v | None -> Nil)) | _ -> Nil); (* Stringify a value for DOM string properties *) @@ -2052,8 +2112,8 @@ let run_spec_tests env test_files = Hashtbl.replace d "childNodes" (List []) | _ -> ()); stored - | [ListRef r; Number n; value] -> - let idx = int_of_float n in + | [ListRef r; idx_v; value] when (match idx_v with Number _ | Integer _ -> true | _ -> false) -> + let idx = match idx_v with Number n -> int_of_float n | Integer n -> n | _ -> 0 in let lst = !r in if idx >= 0 && idx < List.length lst then r := List.mapi (fun i v -> if i = idx then value else v) lst @@ -2190,7 +2250,7 @@ let run_spec_tests env test_files = | [String name; value] -> let attrs = match Hashtbl.find_opt d "attributes" with Some (Dict a) -> a | _ -> let a = Hashtbl.create 4 in Hashtbl.replace d "attributes" (Dict a); a in - let sv = match value with String s -> s | Number n -> + let sv = match value with String s -> s | Integer n -> string_of_int n | Number n -> let i = int_of_float n in if float_of_int i = n then string_of_int i else string_of_float n | _ -> Sx_types.inspect value in Hashtbl.replace attrs name (String sv); @@ -2632,6 +2692,7 @@ let run_spec_tests env test_files = let rec json_of_value = function | Nil -> `Null | Bool b -> `Bool b + | Integer n -> `Int n | Number n -> if Float.is_integer n && Float.abs n < 1e16 then `Int (int_of_float n) else `Float n @@ -2647,8 +2708,8 @@ let run_spec_tests env test_files = let rec value_of_json = function | `Null -> Nil | `Bool b -> Bool b - | `Int i -> Number (float_of_int i) - | `Intlit s -> (try Number (float_of_string s) with _ -> String s) + | `Int i -> Integer i + | `Intlit s -> (try Integer (int_of_string s) with _ -> try Number (float_of_string s) with _ -> String s) | `Float f -> Number f | `String s -> String s | `List xs -> List (List.map value_of_json xs) @@ -2811,6 +2872,7 @@ let run_spec_tests env test_files = match sx_vm_execute with | Some fn -> Sx_ref.cek_call fn (List args) | None -> Nil))); + load_module "stdlib.sx" spec_dir; (* pure SX stdlib: format etc. *) load_module "signals.sx" spec_dir; (* core reactive primitives *) load_module "signals.sx" web_dir; (* web extensions *) load_module "freeze.sx" lib_dir; diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index a14d9e25..e1fb4314 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -296,6 +296,10 @@ let read_blob () = (* consume trailing newline *) (try ignore (input_line stdin) with End_of_file -> ()); data + | [List [Symbol "blob"; Integer n]] -> + let data = read_exact_bytes n in + (try ignore (input_line stdin) with End_of_file -> ()); + data | _ -> raise (Eval_error ("read_blob: expected (blob N), got: " ^ line)) (** Batch IO mode — collect requests during aser-slot, resolve after. *) @@ -357,6 +361,11 @@ let rec read_io_response () = | [List (Symbol "io-response" :: Number n :: values)] when int_of_float n = !current_epoch -> (match values with [v] -> v | _ -> List values) + | [List [Symbol "io-response"; Integer n; value]] + when n = !current_epoch -> value + | [List (Symbol "io-response" :: Integer n :: values)] + when n = !current_epoch -> + (match values with [v] -> v | _ -> List values) (* Legacy untagged: (io-response value) — accept for backwards compat *) | [List [Symbol "io-response"; value]] -> value | [List (Symbol "io-response" :: values)] -> @@ -396,6 +405,12 @@ let read_batched_io_response () = when int_of_float n = !current_epoch -> s | [List [Symbol "io-response"; Number n; v]] when int_of_float n = !current_epoch -> serialize_value v + | [List [Symbol "io-response"; Integer n; String s]] + when n = !current_epoch -> s + | [List [Symbol "io-response"; Integer n; SxExpr s]] + when n = !current_epoch -> s + | [List [Symbol "io-response"; Integer n; v]] + when n = !current_epoch -> serialize_value v (* Legacy untagged *) | [List [Symbol "io-response"; String s]] | [List [Symbol "io-response"; SxExpr s]] -> s @@ -959,6 +974,7 @@ let setup_io_bridges env = bind "sleep" (fun args -> io_request "sleep" args); bind "set-response-status" (fun args -> match args with | [Number n] -> _pending_response_status := int_of_float n; Nil + | [Integer n] -> _pending_response_status := n; Nil | _ -> Nil); bind "set-response-header" (fun args -> io_request "set-response-header" args) @@ -1361,6 +1377,7 @@ let rec dispatch env cmd = | Bool true -> "true" | Bool false -> "false" | Number n -> Sx_types.format_number n + | Integer n -> string_of_int n | String s -> "\"" ^ escape_sx_string s ^ "\"" | Symbol s -> s | Keyword k -> ":" ^ k @@ -1374,6 +1391,10 @@ let rec dispatch env cmd = | Island i -> "~" ^ i.i_name | SxExpr s -> s | RawHTML s -> "\"" ^ escape_sx_string s ^ "\"" + | Char n -> Sx_types.inspect (Char n) + | Eof -> Sx_types.inspect Eof + | Port _ -> Sx_types.inspect result + | Rational (n, d) -> Printf.sprintf "%d/%d" n d | _ -> "nil" in send_ok_raw (raw_serialize result) @@ -4450,6 +4471,8 @@ let site_mode () = match exprs with | [List [Symbol "epoch"; Number n]] -> current_epoch := int_of_float n + | [List [Symbol "epoch"; Integer n]] -> + current_epoch := n (* render-page: full SSR pipeline — URL → complete HTML *) | [List [Symbol "render-page"; String path]] -> (try match http_render_page env path [] with @@ -4507,6 +4530,8 @@ let () = (* Epoch marker: (epoch N) — set current epoch, read next command *) | [List [Symbol "epoch"; Number n]] -> current_epoch := int_of_float n + | [List [Symbol "epoch"; Integer n]] -> + current_epoch := n | [cmd] -> dispatch env cmd | _ -> send_error ("Expected single command, got " ^ string_of_int (List.length exprs)) end diff --git a/hosts/ocaml/bootstrap.py b/hosts/ocaml/bootstrap.py index 0c9023a2..9f04f7ae 100644 --- a/hosts/ocaml/bootstrap.py +++ b/hosts/ocaml/bootstrap.py @@ -47,7 +47,9 @@ open Sx_runtime let trampoline_fn : (value -> value) ref = ref (fun v -> v) let trampoline v = !trampoline_fn v - +(* Step limit for timeout detection — set to 0 to disable *) +let step_limit : int ref = ref 0 +let step_count : int ref = ref 0 (* === Mutable globals — backing refs for transpiler's !_ref / _ref := === *) let _strict_ref = ref (Bool false) @@ -126,6 +128,90 @@ let enhance_error_with_trace msg = _last_error_kont_ref := Nil; msg ^ (format_comp_trace trace) +(* Hand-written sf_define_type — skipped from transpile because the spec uses + &rest params and empty-dict literals that the transpiler can't emit cleanly. + Implements: (define-type Name (Ctor1 f1 f2) (Ctor2 f3) ...) + Creates constructor fns, Name?/Ctor? predicates, Ctor-field accessors, + and records ctors in *adt-registry*. *) +let sf_define_type args env_val = + let items = (match args with List l -> l | _ -> []) in + let type_sym = List.nth items 0 in + let type_name = value_to_string type_sym in + let ctor_specs = List.tl items in + let env_has_v k = sx_truthy (env_has env_val (String k)) in + let env_bind_v k v = ignore (env_bind env_val (String k) v) in + let env_get_v k = env_get env_val (String k) in + if not (env_has_v "*adt-registry*") then + env_bind_v "*adt-registry*" (Dict (Hashtbl.create 8)); + let registry = env_get_v "*adt-registry*" in + let ctor_names = List.map (fun spec -> + (match spec with List (sym :: _) -> String (value_to_string sym) | _ -> Nil) + ) ctor_specs in + (match registry with Dict d -> Hashtbl.replace d type_name (List ctor_names) | _ -> ()); + env_bind_v (type_name ^ "?") + (NativeFn (type_name ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> Bool (Hashtbl.mem d "_adt" && + (match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false)) + | _ -> Bool false) + | _ -> Bool false))); + List.iter (fun spec -> + (match spec with + | List (sym :: fields) -> + let cn = value_to_string sym in + let field_names = List.map value_to_string fields in + let arity = List.length fields in + env_bind_v cn + (NativeFn (cn, fun ctor_args -> + if List.length ctor_args <> arity then + raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d" + cn arity (List.length ctor_args))) + else begin + let d = Hashtbl.create 4 in + Hashtbl.replace d "_adt" (Bool true); + Hashtbl.replace d "_type" (String type_name); + Hashtbl.replace d "_ctor" (String cn); + Hashtbl.replace d "_fields" (List ctor_args); + Dict d + end)); + env_bind_v (cn ^ "?") + (NativeFn (cn ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> Bool (Hashtbl.mem d "_adt" && + (match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false)) + | _ -> Bool false) + | _ -> Bool false))); + List.iteri (fun idx fname -> + env_bind_v (cn ^ "-" ^ fname) + (NativeFn (cn ^ "-" ^ fname, fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> + (match Hashtbl.find_opt d "_fields" with + | Some (List fs) -> + if idx < List.length fs then List.nth fs idx + else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds")) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT"))) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict"))) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg"))))) + ) field_names + | _ -> ()) + ) ctor_specs; + Nil + +(* Register define-type via custom_special_forms so the CEK dispatch finds it. + The top-level (register-special-form! ...) in spec/evaluator.sx is not a + define and therefore is not transpiled; we wire it up here instead. *) +let () = ignore (register_special_form (String "define-type") + (NativeFn ("define-type", fun call_args -> + match call_args with + | [args; env] -> sf_define_type args env + | _ -> Nil))) """ @@ -171,7 +257,10 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str: "debug-log", "debug_log", "range", "chunk-every", "zip-pairs", "string-contains?", "starts-with?", "ends-with?", "string-replace", "trim", "split", "index-of", - "pad-left", "pad-right", "char-at", "substring"} + "pad-left", "pad-right", "char-at", "substring", + # sf-define-type uses &rest + empty-dict literals that the transpiler + # can't emit as valid OCaml; hand-written implementation in FIXUPS. + "sf-define-type"} defines = [(n, e) for n, e in defines if n not in skip] # Deduplicate — keep last definition for each name (CEK overrides tree-walk) diff --git a/hosts/ocaml/lib/sx_parser.ml b/hosts/ocaml/lib/sx_parser.ml index 78edd5a9..71a2d49e 100644 --- a/hosts/ocaml/lib/sx_parser.ml +++ b/hosts/ocaml/lib/sx_parser.ml @@ -89,10 +89,38 @@ let read_symbol s = while s.pos < s.len && is_symbol_char s.src.[s.pos] do advance s done; String.sub s.src start (s.pos - start) +let gcd a b = + let rec g a b = if b = 0 then a else g b (a mod b) in g (abs a) (abs b) + +let make_rat n d = + if d = 0 then raise (Parse_error "rational: division by zero"); + let sign = if d < 0 then -1 else 1 in + let g = gcd (abs n) (abs d) in + let rn = sign * n / g and rd = sign * d / g in + if rd = 1 then Integer rn else Rational (rn, rd) + let try_number str = - match float_of_string_opt str with - | Some n -> Some (Number n) - | None -> None + (* Integers (no '.' or 'e'/'E') → exact Integer; rationals N/D; floats → inexact Number *) + let has_dec = String.contains str '.' in + let has_exp = String.contains str 'e' || String.contains str 'E' in + if has_dec || has_exp then + match float_of_string_opt str with + | Some n -> Some (Number n) + | None -> None + else + match String.split_on_char '/' str with + | [num_s; den_s] when num_s <> "" && den_s <> "" -> + (match int_of_string_opt num_s, int_of_string_opt den_s with + | Some n, Some d -> (try Some (make_rat n d) with _ -> None) + | _ -> None) + | _ -> + match int_of_string_opt str with + | Some n -> Some (Integer n) + | None -> + (* handles "nan", "inf", "-inf" *) + match float_of_string_opt str with + | Some n -> Some (Number n) + | None -> None let rec read_value s : value = skip_whitespace_and_comments s; @@ -108,6 +136,34 @@ let rec read_value s : value = | '"' -> String (read_string s) | '\'' -> advance s; List [Symbol "quote"; read_value s] | '`' -> advance s; List [Symbol "quasiquote"; read_value s] + | '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\\' -> + (* Character literal: #\a, #\space, #\newline, etc. *) + advance s; advance s; + if at_end s then raise (Parse_error "Unexpected end of input after #\\"); + let char_start = s.pos in + (* Read a name if starts with ident char, else single char *) + if is_ident_start s.src.[s.pos] then begin + while s.pos < s.len && is_ident_char s.src.[s.pos] do advance s done; + let name = String.sub s.src char_start (s.pos - char_start) in + let cp = match name with + | "space" -> 32 | "newline" -> 10 | "tab" -> 9 + | "return" -> 13 | "nul" -> 0 | "null" -> 0 + | "escape" -> 27 | "delete" -> 127 | "backspace" -> 8 + | "altmode" -> 27 | "rubout" -> 127 + | _ -> Char.code name.[0] (* single letter like #\a *) + in Char cp + end else begin + let c = s.src.[s.pos] in + advance s; + Char (Char.code c) + end + | '#' when s.pos + 1 < s.len && + (s.src.[s.pos + 1] = 't' || s.src.[s.pos + 1] = 'f') && + (s.pos + 2 >= s.len || not (is_ident_char s.src.[s.pos + 2])) -> + (* #t / #f — boolean literals (R7RS shorthand) *) + let b = s.src.[s.pos + 1] = 't' in + advance s; advance s; + Bool b | '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' -> (* Datum comment: #; discards next expression *) advance s; advance s; diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 3e0768f4..ac03e182 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -51,8 +51,17 @@ let get_primitive name = (* Trampoline hook — set by sx_ref after initialization to break circular dep *) let trampoline_hook : (value -> value) ref = ref (fun v -> v) +let as_int = function + | Integer n -> n + | Number n -> int_of_float n + | v -> raise (Eval_error ("Expected number, got " ^ type_of v)) + +let all_ints = List.for_all (function Integer _ -> true | _ -> false) + let rec as_number = function + | Integer n -> float_of_int n | Number n -> n + | Rational(n, d) -> float_of_int n /. float_of_int d | Bool true -> 1.0 | Bool false -> 0.0 | Nil -> 0.0 @@ -79,6 +88,7 @@ let as_bool = function let rec to_string = function | String s -> s + | Integer n -> string_of_int n | Number n -> Sx_types.format_number n | Bool true -> "true" | Bool false -> "false" @@ -90,52 +100,180 @@ let rec to_string = function | RawHTML s -> s | v -> inspect v +let gensym_counter = ref 0 + +let rat_gcd a b = + let rec g a b = if b = 0 then a else g b (a mod b) in g (abs a) (abs b) + +let make_rat n d = + if d = 0 then raise (Eval_error "rational: division by zero"); + let sign = if d < 0 then -1 else 1 in + let g = rat_gcd (abs n) (abs d) in + let rn = sign * n / g and rd = sign * d / g in + if rd = 1 then Integer rn else Rational (rn, rd) + +let rat_of_val = function + | Integer n -> (n, 1) + | Rational(n,d) -> (n, d) + | v -> raise (Eval_error ("expected integer or rational, got " ^ type_of v)) + +let has_rational args = List.exists (function Rational _ -> true | _ -> false) args +let has_float args = List.exists (function Number _ -> true | _ -> false) args + +let rat_add (an, ad) (bn, bd) = make_rat (an * bd + bn * ad) (ad * bd) +let rat_sub (an, ad) (bn, bd) = make_rat (an * bd - bn * ad) (ad * bd) +let rat_mul (an, ad) (bn, bd) = make_rat (an * bn) (ad * bd) +let rat_div (an, ad) (bn, bd) = + if bn = 0 then raise (Eval_error "rational: division by zero"); + make_rat (an * bd) (ad * bn) + +(* write/display serializers *) +let rec sx_write_val = function + | Nil -> "()" + | Eof -> "#!eof" + | Bool true -> "#t" + | Bool false -> "#f" + | Integer n -> string_of_int n + | Number n -> + let s = Printf.sprintf "%g" n in + (* Ensure float-like if no decimal point *) + if String.contains s '.' || String.contains s 'e' then s else s + | Rational(n, d) -> Printf.sprintf "%d/%d" n d + | String s -> + let buf = Buffer.create (String.length s + 2) in + Buffer.add_char buf '"'; + String.iter (function + | '"' -> Buffer.add_string buf "\\\"" + | '\\' -> Buffer.add_string buf "\\\\" + | '\n' -> Buffer.add_string buf "\\n" + | '\r' -> Buffer.add_string buf "\\r" + | '\t' -> Buffer.add_string buf "\\t" + | c -> Buffer.add_char buf c) s; + Buffer.add_char buf '"'; + Buffer.contents buf + | Char n -> + if n = 32 then "#\\space" + else if n = 10 then "#\\newline" + else if n = 9 then "#\\tab" + else Printf.sprintf "#\\%c" (Char.chr (n land 0xFF)) + | Symbol s -> s + | Keyword k -> ":" ^ k + | List items | ListRef { contents = items } -> + "(" ^ String.concat " " (List.map sx_write_val items) ^ ")" + | v -> inspect v + +and sx_display_val = function + | String s -> s + | Char n -> String.make 1 (Char.chr (n land 0xFF)) + | v -> sx_write_val v + let () = (* === Arithmetic === *) register "+" (fun args -> - Number (List.fold_left (fun acc a -> acc +. as_number a) 0.0 args)); + if all_ints args then + Integer (List.fold_left (fun acc a -> match a with Integer n -> acc + n | _ -> acc) 0 args) + else if has_rational args && not (has_float args) then + List.fold_left (fun acc a -> + match acc, a with + | Integer an, _ -> rat_add (an, 1) (rat_of_val a) + | Rational(an,ad), _ -> rat_add (an, ad) (rat_of_val a) + | _ -> acc + ) (Integer 0) args + else + Number (List.fold_left (fun acc a -> acc +. as_number a) 0.0 args)); register "-" (fun args -> match args with - | [] -> Number 0.0 + | [] -> Integer 0 + | [Integer n] -> Integer (-n) + | [Rational(n,d)] -> make_rat (-n) d | [a] -> Number (-. (as_number a)) - | a :: rest -> Number (List.fold_left (fun acc x -> acc -. as_number x) (as_number a) rest)); + | _ when all_ints args -> + (match args with + | Integer h :: tl -> + Integer (List.fold_left (fun acc a -> match a with Integer n -> acc - n | _ -> acc) h tl) + | _ -> Number 0.0) + | _ when has_rational args && not (has_float args) -> + (match args with + | h :: tl -> + List.fold_left (fun acc a -> + match acc with + | Integer an -> rat_sub (an, 1) (rat_of_val a) + | Rational(an,ad) -> rat_sub (an, ad) (rat_of_val a) + | _ -> acc + ) h tl + | _ -> Integer 0) + | a :: rest -> + Number (List.fold_left (fun acc x -> acc -. as_number x) (as_number a) rest)); register "*" (fun args -> - Number (List.fold_left (fun acc a -> acc *. as_number a) 1.0 args)); + if all_ints args then + Integer (List.fold_left (fun acc a -> match a with Integer n -> acc * n | _ -> acc) 1 args) + else if has_rational args && not (has_float args) then + List.fold_left (fun acc a -> + match acc with + | Integer an -> rat_mul (an, 1) (rat_of_val a) + | Rational(an,ad) -> rat_mul (an, ad) (rat_of_val a) + | _ -> acc + ) (Integer 1) args + else + Number (List.fold_left (fun acc a -> acc *. as_number a) 1.0 args)); register "/" (fun args -> match args with + | [Integer a; Integer b] -> make_rat a b + | [Rational(an,ad); Integer b] -> make_rat an (ad * b) + | [Integer a; Rational(bn,bd)] -> make_rat (a * bd) bn + | [Rational(an,ad); Rational(bn,bd)] -> rat_div (an, ad) (bn, bd) | [a; b] -> Number (as_number a /. as_number b) | _ -> raise (Eval_error "/: expected 2 args")); register "mod" (fun args -> match args with + | [Integer a; Integer b] -> Integer (a mod b) | [a; b] -> Number (Float.rem (as_number a) (as_number b)) | _ -> raise (Eval_error "mod: expected 2 args")); register "inc" (fun args -> - match args with [a] -> Number (as_number a +. 1.0) | _ -> raise (Eval_error "inc: 1 arg")); + match args with + | [Integer n] -> Integer (n + 1) + | [a] -> Number (as_number a +. 1.0) + | _ -> raise (Eval_error "inc: 1 arg")); register "dec" (fun args -> - match args with [a] -> Number (as_number a -. 1.0) | _ -> raise (Eval_error "dec: 1 arg")); + match args with + | [Integer n] -> Integer (n - 1) + | [a] -> Number (as_number a -. 1.0) + | _ -> raise (Eval_error "dec: 1 arg")); register "abs" (fun args -> - match args with [a] -> Number (Float.abs (as_number a)) | _ -> raise (Eval_error "abs: 1 arg")); + match args with + | [Integer n] -> Integer (abs n) + | [a] -> Number (Float.abs (as_number a)) + | _ -> raise (Eval_error "abs: 1 arg")); register "floor" (fun args -> - match args with [a] -> Number (floor (as_number a)) + match args with + | [Integer n] -> Integer n + | [a] -> Integer (int_of_float (floor (as_number a))) | _ -> raise (Eval_error "floor: 1 arg")); register "ceil" (fun args -> - match args with [a] -> Number (ceil (as_number a)) + match args with + | [Integer n] -> Integer n + | [a] -> Integer (int_of_float (ceil (as_number a))) | _ -> raise (Eval_error "ceil: 1 arg")); register "round" (fun args -> match args with - | [a] -> Number (Float.round (as_number a)) + | [Integer n] -> Integer n + | [a] -> Integer (int_of_float (Float.round (as_number a))) | [a; b] -> - let n = as_number a and places = int_of_float (as_number b) in + let n = as_number a and places = as_int b in let factor = 10.0 ** float_of_int places in Number (Float.round (n *. factor) /. factor) | _ -> raise (Eval_error "round: 1-2 args")); register "min" (fun args -> match args with | [] -> raise (Eval_error "min: at least 1 arg") + | _ when all_ints args -> + Integer (List.fold_left (fun acc a -> match a with Integer n -> min acc n | _ -> acc) max_int args) | _ -> Number (List.fold_left (fun acc a -> Float.min acc (as_number a)) Float.infinity args)); register "max" (fun args -> match args with | [] -> raise (Eval_error "max: at least 1 arg") + | _ when all_ints args -> + Integer (List.fold_left (fun acc a -> match a with Integer n -> max acc n | _ -> acc) min_int args) | _ -> Number (List.fold_left (fun acc a -> Float.max acc (as_number a)) Float.neg_infinity args)); register "sqrt" (fun args -> match args with [a] -> Number (Float.sqrt (as_number a)) | _ -> raise (Eval_error "sqrt: 1 arg")); @@ -167,7 +305,10 @@ let () = register "acos" (fun args -> match args with [a] -> Number (Float.acos (as_number a)) | _ -> raise (Eval_error "acos: 1 arg")); register "atan" (fun args -> - match args with [a] -> Number (Float.atan (as_number a)) | _ -> raise (Eval_error "atan: 1 arg")); + match args with + | [a] -> Number (Float.atan (as_number a)) + | [y; x] -> Number (Float.atan2 (as_number y) (as_number x)) + | _ -> raise (Eval_error "atan: 1-2 args")); register "atan2" (fun args -> match args with [a; b] -> Number (Float.atan2 (as_number a) (as_number b)) | _ -> raise (Eval_error "atan2: 2 args")); @@ -189,6 +330,7 @@ let () = Number (Float.sqrt sum)); register "sign" (fun args -> match args with + | [Integer n] -> Integer (if n > 0 then 1 else if n < 0 then -1 else 0) | [a] -> let n = as_number a in Number (if Float.is_nan n then Float.nan @@ -234,33 +376,158 @@ let () = | _ -> raise (Eval_error "clamp: 3 args")); register "truncate" (fun args -> match args with - | [a] -> let n = as_number a in Number (if n >= 0.0 then floor n else ceil n) + | [Integer n] -> Integer n + | [a] -> let n = as_number a in Integer (int_of_float (if n >= 0.0 then floor n else ceil n)) | _ -> raise (Eval_error "truncate: 1 arg")); register "remainder" (fun args -> match args with + | [Integer a; Integer b] -> Integer (a mod b) | [a; b] -> Number (Float.rem (as_number a) (as_number b)) | _ -> raise (Eval_error "remainder: 2 args")); register "modulo" (fun args -> match args with + | [Integer a; Integer b] -> + let r = a mod b in + Integer (if r = 0 || (r > 0) = (b > 0) then r else r + b) | [a; b] -> let a = as_number a and b = as_number b in let r = Float.rem a b in Number (if r = 0.0 || (r > 0.0) = (b > 0.0) then r else r +. b) | _ -> raise (Eval_error "modulo: 2 args")); register "exact?" (fun args -> - match args with [Number f] -> Bool (Float.is_integer f) | [_] -> Bool false + match args with + | [Integer _] -> Bool true + | [Number _] -> Bool false + | [_] -> Bool false | _ -> raise (Eval_error "exact?: 1 arg")); register "inexact?" (fun args -> - match args with [Number f] -> Bool (not (Float.is_integer f)) | [_] -> Bool false + match args with + | [Number _] -> Bool true + | [Integer _] -> Bool false + | [_] -> Bool false | _ -> raise (Eval_error "inexact?: 1 arg")); register "exact->inexact" (fun args -> - match args with [Number n] -> Number n | [a] -> Number (as_number a) + match args with + | [Integer n] -> Number (float_of_int n) + | [Number n] -> Number n + | [Rational(n,d)] -> Number (float_of_int n /. float_of_int d) + | [a] -> Number (as_number a) | _ -> raise (Eval_error "exact->inexact: 1 arg")); register "inexact->exact" (fun args -> match args with - | [Number n] -> if Float.is_integer n then Number n else Number (Float.round n) - | [a] -> Number (Float.round (as_number a)) + | [Integer n] -> Integer n + | [Number n] -> Integer (int_of_float (Float.round n)) + | [a] -> Integer (int_of_float (Float.round (as_number a))) | _ -> raise (Eval_error "inexact->exact: 1 arg")); + register "expt" (fun args -> + match args with + | [Integer a; Integer b] when b >= 0 -> + let rec ipow base e acc = if e = 0 then acc else ipow base (e - 1) (acc * base) in + Integer (ipow a b 1) + | [a; b] -> Number (Float.pow (as_number a) (as_number b)) + | _ -> raise (Eval_error "expt: 2 args")); + register "quotient" (fun args -> + match args with + | [Integer a; Integer b] -> Integer (Int.div a b) + | [a; b] -> + let n = as_number a /. as_number b in + Integer (int_of_float (if n >= 0.0 then floor n else ceil n)) + | _ -> raise (Eval_error "quotient: 2 args")); + let rec igcd a b = if b = 0 then a else igcd b (a mod b) in + register "gcd" (fun args -> + match args with + | [Integer a; Integer b] -> Integer (igcd (abs a) (abs b)) + | [a; b] -> + let rec fgcd a b = if b = 0.0 then a else fgcd b (Float.rem a b) in + Number (fgcd (abs_float (as_number a)) (abs_float (as_number b))) + | _ -> raise (Eval_error "gcd: 2 args")); + register "lcm" (fun args -> + match args with + | [Integer a; Integer b] -> + let g = igcd (abs a) (abs b) in + if g = 0 then Integer 0 else Integer (abs a / g * abs b) + | [a; b] -> + let a = abs_float (as_number a) and b = abs_float (as_number b) in + let rec fgcd a b = if b = 0.0 then a else fgcd b (Float.rem a b) in + let g = fgcd a b in + if g = 0.0 then Number 0.0 else Number (a /. g *. b) + | _ -> raise (Eval_error "lcm: 2 args")); + register "number->string" (fun args -> + let digits = "0123456789abcdefghijklmnopqrstuvwxyz" in + let int_to_radix n r = + if n = 0 then "0" + else begin + let neg = n < 0 in + let buf = Buffer.create 16 in + let rec go n = if n > 0 then begin go (n / r); Buffer.add_char buf digits.[n mod r] end in + go (abs n); + (if neg then "-" else "") ^ Buffer.contents buf + end + in + match args with + | [Integer n] -> String (string_of_int n) + | [Number f] -> String (Printf.sprintf "%g" f) + | [Rational(n,d)] -> String (Printf.sprintf "%d/%d" n d) + | [Integer n; Integer r] -> + if r < 2 || r > 36 then raise (Eval_error "number->string: radix out of range"); + String (int_to_radix n r) + | [Number f; Integer r] -> + if r < 2 || r > 36 then raise (Eval_error "number->string: radix out of range"); + String (int_to_radix (int_of_float f) r) + | _ -> raise (Eval_error "number->string: 1-2 args")); + register "string->number" (fun args -> + match args with + | [String s] -> + (try Integer (int_of_string s) + with _ -> try Number (float_of_string s) + with _ -> Nil) + | [String s; Integer r] -> + (try + let neg = String.length s > 0 && s.[0] = '-' in + let start = if neg then 1 else 0 in + let n = ref 0 in + for i = start to String.length s - 1 do + let c = Char.code s.[i] in + let d = if c >= 48 && c <= 57 then c - 48 + else if c >= 97 && c <= 122 then c - 87 + else if c >= 65 && c <= 90 then c - 55 + else raise Exit + in + if d >= r then raise Exit; + n := !n * r + d + done; + Integer (if neg then - !n else !n) + with _ -> Nil) + | _ -> raise (Eval_error "string->number: 1-2 args")); + let make_rational_val n d = + if d = 0 then raise (Eval_error "make-rational: denominator cannot be zero"); + let rec gcd a b = if b = 0 then a else gcd b (a mod b) in + let sign = if d < 0 then -1 else 1 in + let g = gcd (abs n) (abs d) in + let rn = sign * n / g and rd = sign * d / g in + if rd = 1 then Integer rn else Rational (rn, rd) + in + register "make-rational" (fun args -> + match args with + | [Integer n; Integer d] -> make_rational_val n d + | [Number f; Integer d] -> make_rational_val (int_of_float f) d + | [Integer n; Number f] -> make_rational_val n (int_of_float f) + | _ -> raise (Eval_error "make-rational: expected 2 integers")); + register "rational?" (fun args -> + match args with + | [Rational _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "rational?: expected 1 arg")); + register "numerator" (fun args -> + match args with + | [Rational (n, _)] -> Integer n + | [Integer n] -> Integer n + | _ -> raise (Eval_error "numerator: expected rational or integer")); + register "denominator" (fun args -> + match args with + | [Rational (_, d)] -> Integer d + | [Integer _] -> Integer 1 + | _ -> raise (Eval_error "denominator: expected rational or integer")); register "parse-int" (fun args -> let parse_leading_int s = let len = String.length s in @@ -276,10 +543,11 @@ let () = else None in match args with - | [String s] -> (match parse_leading_int s with Some n -> Number (float_of_int n) | None -> Nil) + | [String s] -> (match parse_leading_int s with Some n -> Integer n | None -> Nil) | [String s; default_val] -> - (match parse_leading_int s with Some n -> Number (float_of_int n) | None -> default_val) - | [Number n] | [Number n; _] -> Number (float_of_int (int_of_float n)) + (match parse_leading_int s with Some n -> Integer n | None -> default_val) + | [Integer n] | [Integer n; _] -> Integer n + | [Number n] | [Number n; _] -> Integer (int_of_float n) | [_; default_val] -> default_val | _ -> Nil); register "parse-float" (fun args -> @@ -296,7 +564,15 @@ let () = let rec safe_eq a b = if a == b then true (* physical equality fast path *) else match a, b with + | Integer x, Integer y -> x = y | Number x, Number y -> x = y + | Integer x, Number y -> float_of_int x = y + | Number x, Integer y -> x = float_of_int y + | Rational(n, d), Number y -> float_of_int n /. float_of_int d = y + | Number x, Rational(n, d) -> x = float_of_int n /. float_of_int d + | Rational(an, ad), Rational(bn, bd) -> an * bd = bn * ad + | Rational(n, d), Integer y -> n = y * d + | Integer x, Rational(n, d) -> x * d = n | String x, String y -> x = y | Bool x, Bool y -> x = y | Nil, Nil -> true @@ -368,9 +644,21 @@ let () = register "nil?" (fun args -> match args with [a] -> Bool (is_nil a) | _ -> raise (Eval_error "nil?: 1 arg")); register "number?" (fun args -> - match args with [Number _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "number?: 1 arg")); + match args with + | [Integer _] | [Number _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "number?: 1 arg")); register "integer?" (fun args -> - match args with [Number f] -> Bool (Float.is_integer f) | [_] -> Bool false | _ -> raise (Eval_error "integer?: 1 arg")); + match args with + | [Integer _] -> Bool true + | [Number f] -> Bool (Float.is_integer f) + | [_] -> Bool false + | _ -> raise (Eval_error "integer?: 1 arg")); + register "float?" (fun args -> + match args with + | [Number _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "float?: 1 arg")); register "string?" (fun args -> match args with [String _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "string?: 1 arg")); register "boolean?" (fun args -> @@ -412,7 +700,7 @@ let () = register "trim" (fun args -> match args with [a] -> String (String.trim (as_string a)) | _ -> raise (Eval_error "trim: 1 arg")); register "string-length" (fun args -> - match args with [a] -> Number (float_of_int (String.length (as_string a))) + match args with [a] -> Integer (String.length (as_string a)) | _ -> raise (Eval_error "string-length: 1 arg")); register "string-contains?" (fun args -> match args with @@ -446,7 +734,11 @@ let () = in find 0 | [List items; target] | [ListRef { contents = items }; target] -> let eq a b = match a, b with - | String x, String y -> x = y | Number x, Number y -> x = y + | Integer x, Integer y -> x = y + | Number x, Number y -> x = y + | Integer x, Number y -> float_of_int x = y + | Number x, Integer y -> x = float_of_int y + | String x, String y -> x = y | Symbol x, Symbol y -> x = y | Keyword x, Keyword y -> x = y | Bool x, Bool y -> x = y | Nil, Nil -> true | _ -> a == b in let rec find i = function @@ -457,22 +749,22 @@ let () = | _ -> raise (Eval_error "index-of: 2 string args or list+target")); register "substring" (fun args -> match args with - | [String s; Number start; Number end_] -> - let i = int_of_float start and j = int_of_float end_ in + | [String s; start_v; end_v] -> + let i = as_int start_v and j = as_int end_v in let len = String.length s in let i = max 0 (min i len) and j = max 0 (min j len) in String (String.sub s i (max 0 (j - i))) | _ -> raise (Eval_error "substring: 3 args")); register "substr" (fun args -> match args with - | [String s; Number start; Number len] -> - let i = int_of_float start and n = int_of_float len in + | [String s; start_v; len_v] -> + let i = as_int start_v and n = as_int len_v in let sl = String.length s in let i = max 0 (min i sl) in let n = max 0 (min n (sl - i)) in String (String.sub s i n) - | [String s; Number start] -> - let i = int_of_float start in + | [String s; start_v] -> + let i = as_int start_v in let sl = String.length s in let i = max 0 (min i sl) in String (String.sub s i (sl - i)) @@ -497,6 +789,7 @@ let () = | String s -> s | SxExpr s -> s | RawHTML s -> s | Keyword k -> k | Symbol s -> s | Nil -> "" | Bool true -> "true" | Bool false -> "false" + | Integer n -> string_of_int n | Number n -> if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n | Thunk _ as t -> (match !_sx_trampoline_fn t with String s -> s | v -> to_string v) | v -> to_string v @@ -523,28 +816,35 @@ let () = | _ -> raise (Eval_error "replace: 3 string args")); register "char-from-code" (fun args -> match args with - | [Number n] -> + | [a] -> + let n = as_int a in let buf = Buffer.create 4 in - Buffer.add_utf_8_uchar buf (Uchar.of_int (int_of_float n)); + Buffer.add_utf_8_uchar buf (Uchar.of_int n); String (Buffer.contents buf) | _ -> raise (Eval_error "char-from-code: 1 arg")); register "char-at" (fun args -> match args with - | [String s; Number n] -> - let i = int_of_float n in + | [String s; n] -> + let i = as_int n in if i >= 0 && i < String.length s then String (String.make 1 s.[i]) else Nil | _ -> raise (Eval_error "char-at: string and index")); register "char-code" (fun args -> match args with - | [String s] when String.length s > 0 -> Number (float_of_int (Char.code s.[0])) + | [String s] when String.length s > 0 -> Integer (Char.code s.[0]) | _ -> raise (Eval_error "char-code: 1 non-empty string arg")); register "parse-number" (fun args -> match args with | [String s] -> - (try Number (float_of_string s) - with Failure _ -> Nil) + let has_dec = String.contains s '.' in + let has_exp = String.contains s 'e' || String.contains s 'E' in + if has_dec || has_exp then + (try Number (float_of_string s) with Failure _ -> Nil) + else + (match int_of_string_opt s with + | Some n -> Integer n + | None -> (try Number (float_of_string s) with Failure _ -> Nil)) | _ -> raise (Eval_error "parse-number: 1 string arg")); (* === Regex (PCRE-compatible — same syntax as JS RegExp) === *) @@ -621,17 +921,17 @@ let () = register "list" (fun args -> ListRef (ref args)); register "len" (fun args -> match args with - | [List l] | [ListRef { contents = l }] -> Number (float_of_int (List.length l)) - | [String s] -> Number (float_of_int (String.length s)) - | [Dict d] -> Number (float_of_int (Hashtbl.length d)) - | [Nil] | [Bool false] -> Number 0.0 - | [Bool true] -> Number 1.0 - | [Number _] -> Number 1.0 - | [RawHTML s] -> Number (float_of_int (String.length s)) - | [SxExpr s] -> Number (float_of_int (String.length s)) - | [Spread pairs] -> Number (float_of_int (List.length pairs)) + | [List l] | [ListRef { contents = l }] -> Integer (List.length l) + | [String s] -> Integer (String.length s) + | [Dict d] -> Integer (Hashtbl.length d) + | [Nil] | [Bool false] -> Integer 0 + | [Bool true] -> Integer 1 + | [Number _] | [Integer _] -> Integer 1 + | [RawHTML s] -> Integer (String.length s) + | [SxExpr s] -> Integer (String.length s) + | [Spread pairs] -> Integer (List.length pairs) | [Component _] | [Island _] | [Lambda _] | [NativeFn _] - | [Macro _] | [Thunk _] | [Keyword _] | [Symbol _] -> Number 0.0 + | [Macro _] | [Thunk _] | [Keyword _] | [Symbol _] -> Integer 0 | _ -> raise (Eval_error (Printf.sprintf "len: %d args" (List.length args)))); register "length" (Hashtbl.find primitives "len"); @@ -658,10 +958,10 @@ let () = | _ -> raise (Eval_error "init: 1 list arg")); register "nth" (fun args -> match args with - | [List l; Number n] | [ListRef { contents = l }; Number n] -> - (try List.nth l (int_of_float n) with _ -> Nil) - | [String s; Number n] -> - let i = int_of_float n in + | [List l; n] | [ListRef { contents = l }; n] -> + (try List.nth l (as_int n) with _ -> Nil) + | [String s; n] -> + let i = as_int n in if i >= 0 && i < String.length s then String (String.make 1 s.[i]) else Nil | _ -> raise (Eval_error "nth: list/string and number")); @@ -707,7 +1007,10 @@ let () = let safe_eq a b = a == b || (match a, b with + | Integer x, Integer y -> x = y | Number x, Number y -> x = y + | Integer x, Number y -> float_of_int x = y + | Number x, Integer y -> x = float_of_int y | String x, String y -> x = y | Bool x, Bool y -> x = y | Nil, Nil -> true @@ -729,33 +1032,45 @@ let () = | _ -> raise (Eval_error "contains?: 2 args")); register "range" (fun args -> match args with - | [Number stop] -> - let n = int_of_float stop in - List (List.init (max 0 n) (fun i -> Number (float_of_int i))) - | [Number start; Number stop] -> - let s = int_of_float start and e = int_of_float stop in + | [stop_v] -> + let n = as_int stop_v in + List (List.init (max 0 n) (fun i -> Integer i)) + | [start_v; stop_v] -> + let s = as_int start_v and e = as_int stop_v in let len = max 0 (e - s) in - List (List.init len (fun i -> Number (float_of_int (s + i)))) - | [Number start; Number stop; Number step] -> - let s = start and e = stop and st = step in - if st = 0.0 then List [] - else - let items = ref [] in - let i = ref s in - if st > 0.0 then - (while !i < e do items := Number !i :: !items; i := !i +. st done) - else - (while !i > e do items := Number !i :: !items; i := !i +. st done); - List (List.rev !items) + List (List.init len (fun i -> Integer (s + i))) + | [start_v; stop_v; step_v] -> + (match start_v, stop_v, step_v with + | Integer s, Integer e, Integer st -> + if st = 0 then List [] + else + let items = ref [] in + let i = ref s in + if st > 0 then + (while !i < e do items := Integer !i :: !items; i := !i + st done) + else + (while !i > e do items := Integer !i :: !items; i := !i + st done); + List (List.rev !items) + | _ -> + let s = as_number start_v and e = as_number stop_v and st = as_number step_v in + if st = 0.0 then List [] + else + let items = ref [] in + let i = ref s in + if st > 0.0 then + (while !i < e do items := Number !i :: !items; i := !i +. st done) + else + (while !i > e do items := Number !i :: !items; i := !i +. st done); + List (List.rev !items)) | _ -> raise (Eval_error "range: 1-3 args")); register "slice" (fun args -> match args with - | [(List l | ListRef { contents = l }); Number start] -> - let i = max 0 (int_of_float start) in + | [(List l | ListRef { contents = l }); start_v] -> + let i = max 0 (as_int start_v) in let rec drop n = function _ :: xs when n > 0 -> drop (n-1) xs | l -> l in List (drop i l) - | [(List l | ListRef { contents = l }); Number start; Number end_] -> - let i = max 0 (int_of_float start) and j = int_of_float end_ in + | [(List l | ListRef { contents = l }); start_v; end_v] -> + let i = max 0 (as_int start_v) and j = as_int end_v in let len = List.length l in let j = min j len in let rec take_range idx = function @@ -765,11 +1080,11 @@ let () = else if idx >= i then x :: take_range (idx+1) xs else take_range (idx+1) xs in List (take_range 0 l) - | [String s; Number start] -> - let i = max 0 (int_of_float start) in + | [String s; start_v] -> + let i = max 0 (as_int start_v) in String (String.sub s i (max 0 (String.length s - i))) - | [String s; Number start; Number end_] -> - let i = max 0 (int_of_float start) and j = int_of_float end_ in + | [String s; start_v; end_v] -> + let i = max 0 (as_int start_v) and j = as_int end_v in let sl = String.length s in let j = min j sl in String (String.sub s i (max 0 (j - i))) @@ -798,24 +1113,24 @@ let () = | _ -> raise (Eval_error "zip-pairs: 1 list")); register "take" (fun args -> match args with - | [(List l | ListRef { contents = l }); Number n] -> + | [(List l | ListRef { contents = l }); n] -> let rec take_n i = function | x :: xs when i > 0 -> x :: take_n (i-1) xs | _ -> [] - in List (take_n (int_of_float n) l) + in List (take_n (as_int n) l) | _ -> raise (Eval_error "take: list and number")); register "drop" (fun args -> match args with - | [(List l | ListRef { contents = l }); Number n] -> + | [(List l | ListRef { contents = l }); n] -> let rec drop_n i = function | _ :: xs when i > 0 -> drop_n (i-1) xs | l -> l - in List (drop_n (int_of_float n) l) + in List (drop_n (as_int n) l) | _ -> raise (Eval_error "drop: list and number")); register "chunk-every" (fun args -> match args with - | [(List l | ListRef { contents = l }); Number n] -> - let size = int_of_float n in + | [(List l | ListRef { contents = l }); n] -> + let size = as_int n in let rec go = function | [] -> [] | l -> @@ -855,8 +1170,9 @@ let () = match args with | [Dict d; String k] -> dict_get d k | [Dict d; Keyword k] -> dict_get d k - | [List l; Number n] | [ListRef { contents = l }; Number n] -> - (try List.nth l (int_of_float n) with _ -> Nil) + | [List l; n] | [ListRef { contents = l }; n] + when (match n with Number _ | Integer _ -> true | _ -> false) -> + (try List.nth l (as_int n) with _ -> Nil) | [Nil; _] -> Nil (* nil.anything → nil *) | [_; _] -> Nil (* type mismatch → nil (matches JS/Python behavior) *) | _ -> Nil); @@ -897,8 +1213,8 @@ let () = register "mutable-list" (fun _args -> ListRef (ref [])); register "set-nth!" (fun args -> match args with - | [ListRef r; Number n; v] -> - let i = int_of_float n in + | [ListRef r; idx; v] -> + let i = as_int idx in let l = !r in r := List.mapi (fun j x -> if j = i then v else x) l; Nil @@ -1025,15 +1341,15 @@ let () = register "identical?" (fun args -> match args with | [a; b] -> - (* Physical identity for reference types, structural for values. - Numbers/strings/booleans from different constant pools must - compare equal when their values match. *) let identical = match a, b with + | Integer x, Integer y -> x = y | Number x, Number y -> x = y - | String x, String y -> x = y (* String.equal *) + | Integer x, Number y -> float_of_int x = y + | Number x, Integer y -> x = float_of_int y + | String x, String y -> x = y | Bool x, Bool y -> x = y | Nil, Nil -> true - | _ -> a == b (* reference identity for dicts, lists, etc. *) + | _ -> a == b in Bool identical | _ -> raise (Eval_error "identical?: 2 args")); register "make-spread" (fun args -> @@ -1071,7 +1387,7 @@ let () = register "map-indexed" (fun args -> match args with | [f; (List items | ListRef { contents = items })] -> - List (List.mapi (fun i x -> call_any f [Number (float_of_int i); x]) items) + List (List.mapi (fun i x -> call_any f [Integer i; x]) items) | [_; Nil] -> List [] | _ -> raise (Eval_error "map-indexed: expected (fn list)")); register "filter" (fun args -> @@ -1114,26 +1430,26 @@ let () = (* ---- VM stack primitives (vm.sx platform interface) ---- *) register "make-vm-stack" (fun args -> match args with - | [Number n] -> ListRef (ref (List.init (int_of_float n) (fun _ -> Nil))) + | [n] -> ListRef (ref (List.init (as_int n) (fun _ -> Nil))) | _ -> raise (Eval_error "make-vm-stack: expected (size)")); register "vm-stack-get" (fun args -> match args with - | [ListRef r; Number n] -> List.nth !r (int_of_float n) + | [ListRef r; n] -> List.nth !r (as_int n) | _ -> raise (Eval_error "vm-stack-get: expected (stack idx)")); register "vm-stack-set!" (fun args -> match args with - | [ListRef r; Number n; v] -> - let i = int_of_float n in + | [ListRef r; n; v] -> + let i = as_int n in r := List.mapi (fun j x -> if j = i then v else x) !r; Nil | _ -> raise (Eval_error "vm-stack-set!: expected (stack idx val)")); register "vm-stack-length" (fun args -> match args with - | [ListRef r] -> Number (float_of_int (List.length !r)) + | [ListRef r] -> Integer (List.length !r) | _ -> raise (Eval_error "vm-stack-length: expected (stack)")); register "vm-stack-copy!" (fun args -> match args with - | [ListRef src; ListRef dst; Number n] -> - let count = int_of_float n in + | [ListRef src; ListRef dst; n] -> + let count = as_int n in let src_items = !src in dst := List.mapi (fun i x -> if i < count then List.nth src_items i else x) !dst; Nil | _ -> raise (Eval_error "vm-stack-copy!: expected (src dst count)")); @@ -1215,23 +1531,31 @@ let () = (* R7RS vectors — mutable fixed-size arrays *) register "make-vector" (fun args -> match args with - | [Number n] -> Vector (Array.make (int_of_float n) Nil) - | [Number n; fill] -> Vector (Array.make (int_of_float n) fill) + | [n] -> Vector (Array.make (as_int n) Nil) + | [n; fill] -> Vector (Array.make (as_int n) fill) | _ -> raise (Eval_error "make-vector: expected (length) or (length fill)")); register "vector" (fun args -> Vector (Array.of_list args)); register "vector?" (fun args -> match args with [Vector _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "vector?: 1 arg")); register "vector-length" (fun args -> - match args with [Vector arr] -> Number (float_of_int (Array.length arr)) + match args with [Vector arr] -> Integer (Array.length arr) | _ -> raise (Eval_error "vector-length: expected vector")); register "vector-ref" (fun args -> match args with - | [Vector arr; Number n] -> arr.(int_of_float n) + | [Vector arr; n] -> + let i = as_int n in + if i < 0 || i >= Array.length arr then + raise (Eval_error (Printf.sprintf "vector-ref: index %d out of bounds (length %d)" i (Array.length arr))); + arr.(i) | _ -> raise (Eval_error "vector-ref: expected (vector index)")); register "vector-set!" (fun args -> match args with - | [Vector arr; Number n; v] -> arr.(int_of_float n) <- v; Nil + | [Vector arr; n; v] -> + let i = as_int n in + if i < 0 || i >= Array.length arr then + raise (Eval_error (Printf.sprintf "vector-set!: index %d out of bounds (length %d)" i (Array.length arr))); + arr.(i) <- v; Nil | _ -> raise (Eval_error "vector-set!: expected (vector index value)")); register "vector->list" (fun args -> match args with [Vector arr] -> List (Array.to_list arr) @@ -1246,8 +1570,35 @@ let () = | [Vector arr; v] -> Array.fill arr 0 (Array.length arr) v; Nil | _ -> raise (Eval_error "vector-fill!: expected (vector value)")); register "vector-copy" (fun args -> - match args with [Vector arr] -> Vector (Array.copy arr) - | _ -> raise (Eval_error "vector-copy: expected vector")); + match args with + | [Vector arr] -> Vector (Array.copy arr) + | [Vector arr; s] -> + let start = as_int s in + let len = Array.length arr - start in + if len <= 0 then Vector [||] else Vector (Array.sub arr start len) + | [Vector arr; s; e] -> + let start = as_int s in + let stop = min (as_int e) (Array.length arr) in + let len = stop - start in + if len <= 0 then Vector [||] else Vector (Array.sub arr start len) + | _ -> raise (Eval_error "vector-copy: expected (vector) or (vector start) or (vector start end)")); + + (* String buffers — O(1) amortised append for string building in loops *) + register "make-string-buffer" (fun _ -> StringBuffer (Buffer.create 64)); + register "string-buffer?" (fun args -> + match args with [StringBuffer _] -> Bool true | [_] -> Bool false + | _ -> raise (Eval_error "string-buffer?: expected 1 arg")); + register "string-buffer-append!" (fun args -> + match args with + | [StringBuffer buf; String s] -> Buffer.add_string buf s; Nil + | [StringBuffer _; v] -> raise (Eval_error ("string-buffer-append!: expected string, got " ^ type_of v)) + | _ -> raise (Eval_error "string-buffer-append!: expected (buffer string)")); + register "string-buffer->string" (fun args -> + match args with [StringBuffer buf] -> String (Buffer.contents buf) + | _ -> raise (Eval_error "string-buffer->string: expected (buffer)")); + register "string-buffer-length" (fun args -> + match args with [StringBuffer buf] -> Integer (Buffer.length buf) + | _ -> raise (Eval_error "string-buffer-length: expected (buffer)")); (* Capability-based sandboxing — gate IO operations *) let cap_stack : string list ref = ref [] in @@ -1871,4 +2222,782 @@ let () = | [rx] -> let (_, _, flags) = regex_of_value rx in String flags - | _ -> raise (Eval_error "regex-flags: (regex)")) + | _ -> raise (Eval_error "regex-flags: (regex)")); + + (* make-regexp / regexp? / regexp-match / regexp-match-all / regexp-replace / regexp-replace-all / regexp-split *) + let parse_re_flags flags = + let opts = ref [] in + String.iter (function + | 'i' -> opts := `CASELESS :: !opts + | 'm' -> opts := `MULTILINE :: !opts + | 's' -> opts := `DOTALL :: !opts + | _ -> ()) flags; + !opts + in + let make_regexp_value source flags = + let opts = parse_re_flags flags in + try + let compiled = Re.compile (Re.Pcre.re ~flags:opts source) in + SxRegexp (source, flags, compiled) + with _ -> raise (Eval_error ("make-regexp: invalid pattern: " ^ source)) + in + let match_dict g input = + let d = Hashtbl.create 4 in + Hashtbl.replace d "match" (String (Re.Group.get g 0)); + Hashtbl.replace d "start" (Integer (Re.Group.start g 0)); + Hashtbl.replace d "end" (Integer (Re.Group.stop g 0)); + Hashtbl.replace d "input" (String input); + let count = Re.Group.nb_groups g in + let groups = ref [] in + for i = count - 1 downto 1 do + let s = try Re.Group.get g i with Not_found -> "" in + groups := String s :: !groups + done; + Hashtbl.replace d "groups" (List !groups); + Dict d + in + register "make-regexp" (fun args -> + match args with + | [String src] -> make_regexp_value src "" + | [String src; String flags] -> make_regexp_value src flags + | _ -> raise (Eval_error "make-regexp: (pattern [flags])")); + register "regexp?" (fun args -> + match args with + | [SxRegexp _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "regexp?: 1 arg")); + register "regexp-source" (fun args -> + match args with + | [SxRegexp (src, _, _)] -> String src + | _ -> raise (Eval_error "regexp-source: expected regexp")); + register "regexp-flags" (fun args -> + match args with + | [SxRegexp (_, flags, _)] -> String flags + | _ -> raise (Eval_error "regexp-flags: expected regexp")); + register "regexp-match" (fun args -> + match args with + | [SxRegexp (_, _, re); String s] -> + (match Re.exec_opt re s with + | None -> Nil + | Some g -> match_dict g s) + | _ -> raise (Eval_error "regexp-match: (regexp string)")); + register "regexp-match-all" (fun args -> + match args with + | [SxRegexp (_, _, re); String s] -> + List (List.map (fun g -> match_dict g s) (Re.all re s)) + | _ -> raise (Eval_error "regexp-match-all: (regexp string)")); + register "regexp-replace" (fun args -> + match args with + | [SxRegexp (_, _, re); String s; String replacement] -> + (match Re.exec_opt re s with + | None -> String s + | Some g -> + let buf = Buffer.create (String.length s) in + let i = ref 0 in + let n = String.length replacement in + let expand () = + while !i < n do + let c = replacement.[!i] in + if c = '$' && !i + 1 < n then + (match replacement.[!i + 1] with + | '&' -> Buffer.add_string buf (Re.Group.get g 0); i := !i + 2 + | '$' -> Buffer.add_char buf '$'; i := !i + 2 + | c when c >= '0' && c <= '9' -> + let idx = Char.code c - Char.code '0' in + (try Buffer.add_string buf (Re.Group.get g idx) with Not_found -> ()); + i := !i + 2 + | _ -> Buffer.add_char buf c; incr i) + else (Buffer.add_char buf c; incr i) + done + in + Buffer.add_string buf (String.sub s 0 (Re.Group.start g 0)); + expand (); + Buffer.add_string buf (String.sub s (Re.Group.stop g 0) + (String.length s - Re.Group.stop g 0)); + String (Buffer.contents buf)) + | _ -> raise (Eval_error "regexp-replace: (regexp string replacement)")); + register "regexp-replace-all" (fun args -> + match args with + | [SxRegexp (_, _, re); String s; String replacement] -> + let expand g = + let buf = Buffer.create (String.length replacement) in + let i = ref 0 in + let n = String.length replacement in + while !i < n do + let c = replacement.[!i] in + if c = '$' && !i + 1 < n then + (match replacement.[!i + 1] with + | '&' -> Buffer.add_string buf (Re.Group.get g 0); i := !i + 2 + | '$' -> Buffer.add_char buf '$'; i := !i + 2 + | c when c >= '0' && c <= '9' -> + let idx = Char.code c - Char.code '0' in + (try Buffer.add_string buf (Re.Group.get g idx) with Not_found -> ()); + i := !i + 2 + | _ -> Buffer.add_char buf c; incr i) + else (Buffer.add_char buf c; incr i) + done; + Buffer.contents buf + in + String (Re.replace re ~f:expand s) + | _ -> raise (Eval_error "regexp-replace-all: (regexp string replacement)")); + register "regexp-split" (fun args -> + match args with + | [SxRegexp (_, _, re); String s] -> + List (List.map (fun x -> String x) (Re.split re s)) + | _ -> raise (Eval_error "regexp-split: (regexp string)")); + (* Bitwise operations *) + register "bitwise-and" (fun args -> + match args with + | [Integer a; Integer b] -> Integer (a land b) + | _ -> raise (Eval_error "bitwise-and: expected (integer integer)")); + register "bitwise-or" (fun args -> + match args with + | [Integer a; Integer b] -> Integer (a lor b) + | _ -> raise (Eval_error "bitwise-or: expected (integer integer)")); + register "bitwise-xor" (fun args -> + match args with + | [Integer a; Integer b] -> Integer (a lxor b) + | _ -> raise (Eval_error "bitwise-xor: expected (integer integer)")); + register "bitwise-not" (fun args -> + match args with + | [Integer a] -> Integer (lnot a) + | _ -> raise (Eval_error "bitwise-not: expected (integer)")); + register "arithmetic-shift" (fun args -> + match args with + | [Integer a; Integer count] -> + Integer (if count >= 0 then a lsl count else a asr (-count)) + | _ -> raise (Eval_error "arithmetic-shift: expected (integer integer)")); + register "bit-count" (fun args -> + match args with + | [Integer a] -> + let n = ref (abs a) in + let c = ref 0 in + while !n <> 0 do + c := !c + (!n land 1); + n := !n lsr 1 + done; + Integer !c + | _ -> raise (Eval_error "bit-count: expected (integer)")); + register "integer-length" (fun args -> + match args with + | [Integer a] -> + let n = ref (abs a) in + let bits = ref 0 in + while !n <> 0 do + incr bits; + n := !n lsr 1 + done; + Integer !bits + | _ -> raise (Eval_error "integer-length: expected (integer)")); + + (* Phase 10: mutable hash tables *) + register "make-hash-table" (fun _ -> HashTable (Hashtbl.create 16)); + register "hash-table?" (fun args -> + match args with + | [HashTable _] -> Bool true + | [_] -> Bool false + | _ -> Bool false); + register "hash-table-set!" (fun args -> + match args with + | [HashTable ht; k; v] -> + (try Hashtbl.replace ht k v + with _ -> + (* fallback: scan for physically equal key *) + let found = ref false in + Hashtbl.iter (fun ek _ -> if ek == k then (Hashtbl.replace ht ek v; found := true)) ht; + if not !found then Hashtbl.replace ht k v); + Nil + | _ -> raise (Eval_error "hash-table-set!: expected (ht key val)")); + register "hash-table-ref" (fun args -> + match args with + | [HashTable ht; k] -> + (try Hashtbl.find ht k + with Not_found -> raise (Eval_error ("hash-table-ref: key not found"))) + | [HashTable ht; k; default] -> + (try Hashtbl.find ht k with Not_found -> default) + | _ -> raise (Eval_error "hash-table-ref: expected (ht key) or (ht key default)")); + register "hash-table-delete!" (fun args -> + match args with + | [HashTable ht; k] -> Hashtbl.remove ht k; Nil + | _ -> raise (Eval_error "hash-table-delete!: expected (ht key)")); + register "hash-table-size" (fun args -> + match args with + | [HashTable ht] -> Integer (Hashtbl.length ht) + | _ -> raise (Eval_error "hash-table-size: expected (ht)")); + register "hash-table-keys" (fun args -> + match args with + | [HashTable ht] -> List (Hashtbl.fold (fun k _ acc -> k :: acc) ht []) + | _ -> raise (Eval_error "hash-table-keys: expected (ht)")); + register "hash-table-values" (fun args -> + match args with + | [HashTable ht] -> List (Hashtbl.fold (fun _ v acc -> v :: acc) ht []) + | _ -> raise (Eval_error "hash-table-values: expected (ht)")); + register "hash-table->alist" (fun args -> + match args with + | [HashTable ht] -> + List (Hashtbl.fold (fun k v acc -> List [k; v] :: acc) ht []) + | _ -> raise (Eval_error "hash-table->alist: expected (ht)")); + register "hash-table-for-each" (fun args -> + match args with + | [HashTable ht; fn] -> + Hashtbl.iter (fun k v -> ignore (!Sx_types._cek_call_ref fn (List [k; v]))) ht; + Nil + | _ -> raise (Eval_error "hash-table-for-each: expected (ht fn)")); + register "hash-table-merge!" (fun args -> + match args with + | [HashTable dst; HashTable src] -> + Hashtbl.iter (fun k v -> Hashtbl.replace dst k v) src; + Nil + | _ -> raise (Eval_error "hash-table-merge!: expected (dst src)")); + (* Phase 11: sequence protocol *) + let seq_to_list v = + match v with + | Nil -> List [] + | List _ -> v + | ListRef { contents = items } -> List items + | Vector arr -> List (Array.to_list arr) + | String s -> + let chars = ref [] in + String.iter (fun c -> chars := String (String.make 1 c) :: !chars) s; + List (List.rev !chars) + | _ -> v + in + register "seq-to-list" (fun args -> + match args with + | [v] -> seq_to_list v + | _ -> raise (Eval_error "seq-to-list: expected 1 arg")); + register "sequence-to-list" (fun args -> + match args with + | [v] -> seq_to_list v + | _ -> raise (Eval_error "sequence-to-list: expected 1 arg")); + register "sequence-to-vector" (fun args -> + match args with + | [v] -> (match seq_to_list v with List xs -> Vector (Array.of_list xs) | x -> x) + | _ -> raise (Eval_error "sequence-to-vector: expected 1 arg")); + register "sequence-length" (fun args -> + match args with + | [String s] -> Integer (String.length s) + | [Vector arr] -> Integer (Array.length arr) + | [v] -> (match seq_to_list v with + | List xs -> Integer (List.length xs) + | _ -> raise (Eval_error "sequence-length: expected sequence")) + | _ -> raise (Eval_error "sequence-length: expected 1 arg")); + register "sequence-ref" (fun args -> + match args with + | [String s; Integer i] -> + if i < 0 || i >= String.length s + then raise (Eval_error (Printf.sprintf "sequence-ref: index %d out of bounds" i)) + else String (String.make 1 (String.get s i)) + | [String s; Number n] -> + let i = int_of_float n in + if i < 0 || i >= String.length s + then raise (Eval_error (Printf.sprintf "sequence-ref: index %d out of bounds" i)) + else String (String.make 1 (String.get s i)) + | [v; idx] -> + let lst = seq_to_list v in + let i = (match idx with Integer n -> n | Number n -> int_of_float n | _ -> raise (Eval_error "sequence-ref: index must be number")) in + (match lst with + | List xs -> + (try List.nth xs i + with _ -> raise (Eval_error (Printf.sprintf "sequence-ref: index %d out of bounds" i))) + | _ -> raise (Eval_error "sequence-ref: expected sequence")) + | _ -> raise (Eval_error "sequence-ref: expected (seq index)")); + register "sequence-append" (fun args -> + match args with + | [String s1; String s2] -> String (s1 ^ s2) + | [v1; v2] -> + let l1 = seq_to_list v1 in + let l2 = seq_to_list v2 in + (match l1, l2 with + | List xs1, List xs2 -> List (xs1 @ xs2) + | _ -> raise (Eval_error "sequence-append: expected sequences")) + | _ -> raise (Eval_error "sequence-append: expected 2 args")); + register "in-range" (fun args -> + match args with + | [Integer n] -> + let rec build i acc = if i < 0 then acc else build (i-1) (Integer i :: acc) in + List (build (n-1) []) + | [Number n] -> + let hi = int_of_float n in + let rec build i acc = if i < 0 then acc else build (i-1) (Integer i :: acc) in + List (build (hi-1) []) + | [Integer lo; Integer hi] -> + let rec build i acc = if i < lo then acc else build (i-1) (Integer i :: acc) in + List (build (hi-1) []) + | [Number lo; Number hi] -> + let lo_i = int_of_float lo and hi_i = int_of_float hi in + let rec build i acc = if i < lo_i then acc else build (i-1) (Integer i :: acc) in + List (build (hi_i-1) []) + | [Integer lo; Integer hi; Integer step] -> + if step = 0 then raise (Eval_error "in-range: step cannot be zero"); + let rec build i acc = + if (step > 0 && i >= hi) || (step < 0 && i <= hi) then acc + else build (i + step) (Integer i :: acc) in + List (List.rev (build lo [])) + | _ -> raise (Eval_error "in-range: expected (end) or (start end) or (start end step)")); + (* === gensym + symbol interning === *) + register "gensym" (fun args -> + let prefix = match args with + | [] -> "g" + | [String s] -> s + | [Symbol s] -> s + | _ -> raise (Eval_error "gensym: expected optional prefix string") in + incr gensym_counter; + Symbol (prefix ^ string_of_int !gensym_counter)); + register "string->symbol" (fun args -> + match args with + | [String s] -> Symbol s + | _ -> raise (Eval_error "string->symbol: expected 1 string")); + register "symbol->string" (fun args -> + match args with + | [Symbol s] -> String s + | _ -> raise (Eval_error "symbol->string: expected 1 symbol")); + register "intern" (fun args -> + match args with + | [String s] -> Symbol s + | _ -> raise (Eval_error "intern: expected 1 string")); + register "symbol-interned?" (fun args -> + match args with + | [Symbol _] -> Bool true + | _ -> raise (Eval_error "symbol-interned?: expected 1 symbol")); + (* Phase 13: character type *) + let char_downcase_cp n = + if n >= 65 && n <= 90 then n + 32 else n in + let char_upcase_cp n = + if n >= 97 && n <= 122 then n - 32 else n in + register "make-char" (fun args -> + match args with + | [Integer n] -> Char n + | _ -> raise (Eval_error "make-char: expected integer codepoint")); + register "char?" (fun args -> + match args with + | [Char _] -> Bool true | [_] -> Bool false + | _ -> raise (Eval_error "char?: expected 1 argument")); + register "char->integer" (fun args -> + match args with + | [Char n] -> Integer n + | _ -> raise (Eval_error "char->integer: expected char")); + register "integer->char" (fun args -> + match args with + | [Integer n] -> Char n + | _ -> raise (Eval_error "integer->char: expected integer")); + register "char-upcase" (fun args -> + match args with + | [Char n] -> Char (char_upcase_cp n) + | _ -> raise (Eval_error "char-upcase: expected char")); + register "char-downcase" (fun args -> + match args with + | [Char n] -> Char (char_downcase_cp n) + | _ -> raise (Eval_error "char-downcase: expected char")); + register "char=?" (fun args -> match args with [Char a; Char b] -> Bool (a = b) | _ -> raise (Eval_error "char=?: expected 2 chars")); + register "char match args with [Char a; Char b] -> Bool (a < b) | _ -> raise (Eval_error "char?" (fun args -> match args with [Char a; Char b] -> Bool (a > b) | _ -> raise (Eval_error "char>?: expected 2 chars")); + register "char<=?" (fun args -> match args with [Char a; Char b] -> Bool (a <= b) | _ -> raise (Eval_error "char<=?: expected 2 chars")); + register "char>=?" (fun args -> match args with [Char a; Char b] -> Bool (a >= b) | _ -> raise (Eval_error "char>=?: expected 2 chars")); + register "char-ci=?" (fun args -> match args with [Char a; Char b] -> Bool (char_downcase_cp a = char_downcase_cp b) | _ -> raise (Eval_error "char-ci=?: expected 2 chars")); + register "char-ci match args with [Char a; Char b] -> Bool (char_downcase_cp a < char_downcase_cp b) | _ -> raise (Eval_error "char-ci?" (fun args -> match args with [Char a; Char b] -> Bool (char_downcase_cp a > char_downcase_cp b) | _ -> raise (Eval_error "char-ci>?: expected 2 chars")); + register "char-ci<=?" (fun args -> match args with [Char a; Char b] -> Bool (char_downcase_cp a <= char_downcase_cp b) | _ -> raise (Eval_error "char-ci<=?: expected 2 chars")); + register "char-ci>=?" (fun args -> match args with [Char a; Char b] -> Bool (char_downcase_cp a >= char_downcase_cp b) | _ -> raise (Eval_error "char-ci>=?: expected 2 chars")); + register "char-alphabetic?" (fun args -> + match args with + | [Char n] -> Bool ((n >= 65 && n <= 90) || (n >= 97 && n <= 122)) + | _ -> raise (Eval_error "char-alphabetic?: expected char")); + register "char-numeric?" (fun args -> + match args with + | [Char n] -> Bool (n >= 48 && n <= 57) + | _ -> raise (Eval_error "char-numeric?: expected char")); + register "char-whitespace?" (fun args -> + match args with + | [Char n] -> Bool (n = 32 || n = 9 || n = 10 || n = 13) + | _ -> raise (Eval_error "char-whitespace?: expected char")); + register "char-upper-case?" (fun args -> + match args with + | [Char n] -> Bool (n >= 65 && n <= 90) + | _ -> raise (Eval_error "char-upper-case?: expected char")); + register "char-lower-case?" (fun args -> + match args with + | [Char n] -> Bool (n >= 97 && n <= 122) + | _ -> raise (Eval_error "char-lower-case?: expected char")); + register "string->list" (fun args -> + match args with + | [String s] -> + let chars = ref [] in + String.iter (fun c -> chars := Char (Char.code c) :: !chars) s; + List (List.rev !chars) + | _ -> raise (Eval_error "string->list: expected string")); + register "list->string" (fun args -> + match args with + | [List chars] | [ListRef { contents = chars }] -> + let buf = Buffer.create (List.length chars) in + List.iter (function + | Char n -> Buffer.add_char buf (Char.chr (n land 0xFF)) + | v -> raise (Eval_error ("list->string: expected char, got " ^ type_of v)) + ) chars; + String (Buffer.contents buf) + | _ -> raise (Eval_error "list->string: expected list of chars")); + (* Phase 14 — EOF object + string ports *) + register "eof-object" (fun _args -> Eof); + register "eof-object?" (fun args -> + match args with + | [Eof] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "eof-object?: expected 1 argument")); + register "open-input-string" (fun args -> + match args with + | [String s] -> + Port { sp_closed = false; sp_kind = PortInput (s, ref 0) } + | _ -> raise (Eval_error "open-input-string: expected string")); + register "open-output-string" (fun args -> + match args with + | [] -> Port { sp_closed = false; sp_kind = PortOutput (Buffer.create 64) } + | _ -> raise (Eval_error "open-output-string: expected no arguments")); + register "get-output-string" (fun args -> + match args with + | [Port { sp_kind = PortOutput buf; _ }] -> String (Buffer.contents buf) + | _ -> raise (Eval_error "get-output-string: expected output port")); + register "port?" (fun args -> + match args with + | [Port _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "port?: expected 1 argument")); + register "input-port?" (fun args -> + match args with + | [Port { sp_kind = PortInput _; _ }] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "input-port?: expected 1 argument")); + register "output-port?" (fun args -> + match args with + | [Port { sp_kind = PortOutput _; _ }] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "output-port?: expected 1 argument")); + register "close-port" (fun args -> + match args with + | [Port p] -> p.sp_closed <- true; Nil + | _ -> raise (Eval_error "close-port: expected port")); + register "read-char" (fun args -> + match args with + | [] -> raise (Eval_error "read-char: no default port in this host") + | [Port p] -> + (match p.sp_kind with + | PortOutput _ -> raise (Eval_error "read-char: expected input port") + | PortInput (src, pos) -> + if p.sp_closed || !pos >= String.length src then Eof + else begin + let cp = Char.code src.[!pos] in + incr pos; + Char cp + end) + | _ -> raise (Eval_error "read-char: expected input port")); + register "peek-char" (fun args -> + match args with + | [] -> raise (Eval_error "peek-char: no default port in this host") + | [Port p] -> + (match p.sp_kind with + | PortOutput _ -> raise (Eval_error "peek-char: expected input port") + | PortInput (src, pos) -> + if p.sp_closed || !pos >= String.length src then Eof + else Char (Char.code src.[!pos])) + | _ -> raise (Eval_error "peek-char: expected input port")); + register "read-line" (fun args -> + match args with + | [] -> raise (Eval_error "read-line: no default port in this host") + | [Port p] -> + (match p.sp_kind with + | PortOutput _ -> raise (Eval_error "read-line: expected input port") + | PortInput (src, pos) -> + if p.sp_closed || !pos >= String.length src then Eof + else begin + let start = !pos in + let len = String.length src in + while !pos < len && src.[!pos] <> '\n' do incr pos done; + let line = String.sub src start (!pos - start) in + if !pos < len then incr pos; + String line + end) + | _ -> raise (Eval_error "read-line: expected input port")); + register "write-char" (fun args -> + match args with + | [Char n; Port p] -> + (match p.sp_kind with + | PortInput _ -> raise (Eval_error "write-char: expected output port") + | PortOutput buf -> + if not p.sp_closed then + Buffer.add_char buf (Char.chr (n land 0xFF)); + Nil) + | _ -> raise (Eval_error "write-char: expected char and output port")); + register "write-string" (fun args -> + match args with + | [String s; Port p] -> + (match p.sp_kind with + | PortInput _ -> raise (Eval_error "write-string: expected output port") + | PortOutput buf -> + if not p.sp_closed then Buffer.add_string buf s; + Nil) + | _ -> raise (Eval_error "write-string: expected string and output port")); + register "char-ready?" (fun args -> + match args with + | [Port { sp_closed = false; sp_kind = PortInput (src, pos); _ }] -> + Bool (!pos < String.length src) + | [Port _] -> Bool false + | _ -> raise (Eval_error "char-ready?: expected input port")) +; + (* === read / write / display === *) + let rec read_postprocess = function + | List [] -> Nil + | List items -> List (List.map read_postprocess items) + | v -> v + in + register "read" (fun args -> + match args with + | [] -> Eof + | [Port p] -> + (match p.sp_kind with + | PortOutput _ -> raise (Eval_error "read: expected input port") + | PortInput (src, pos) -> + let len = String.length src in + if p.sp_closed || !pos >= len then Eof + else begin + let sub = String.sub src !pos (len - !pos) in + let s = Sx_parser.make_state sub in + Sx_parser.skip_whitespace_and_comments s; + if Sx_parser.at_end s then (pos := len; Eof) + else + (try let form = read_postprocess (Sx_parser.read_value s) in + pos := !pos + s.pos; form + with _ -> pos := len; Eof) + end) + | _ -> raise (Eval_error "read: expected optional input port")); + register "write" (fun args -> + match args with + | [v] -> String (sx_write_val v) + | [v; Port p] -> + (match p.sp_kind with + | PortInput _ -> raise (Eval_error "write: expected output port") + | PortOutput buf -> + if not p.sp_closed then Buffer.add_string buf (sx_write_val v); + Nil) + | _ -> raise (Eval_error "write: expected val [port]")); + register "display" (fun args -> + match args with + | [v] -> String (sx_display_val v) + | [v; Port p] -> + (match p.sp_kind with + | PortInput _ -> raise (Eval_error "display: expected output port") + | PortOutput buf -> + if not p.sp_closed then Buffer.add_string buf (sx_display_val v); + Nil) + | _ -> raise (Eval_error "display: expected val [port]")); + register "newline" (fun args -> + match args with + | [] -> Nil + | [Port p] -> + (match p.sp_kind with + | PortInput _ -> raise (Eval_error "newline: expected output port") + | PortOutput buf -> + if not p.sp_closed then Buffer.add_char buf '\n'; + Nil) + | _ -> raise (Eval_error "newline: expected optional output port")); + register "write-to-string" (fun args -> + match args with + | [v] -> String (sx_write_val v) + | _ -> raise (Eval_error "write-to-string: 1 arg")); + register "display-to-string" (fun args -> + match args with + | [v] -> String (sx_display_val v) + | _ -> raise (Eval_error "display-to-string: 1 arg")); + register "format-decimal" (fun args -> + match args with + | [Integer n; Integer prec] -> String (Printf.sprintf "%.*f" prec (float_of_int n)) + | [Number n; Integer prec] -> String (Printf.sprintf "%.*f" prec n) + | [Integer n; _] -> String (Printf.sprintf "%.6f" (float_of_int n)) + | [Number n; _] -> String (Printf.sprintf "%.6f" n) + | _ -> raise (Eval_error "format-decimal: expected number precision")); + register "current-input-port" (fun _ -> Nil); + register "current-output-port" (fun _ -> Nil); + register "current-error-port" (fun _ -> Nil); + (* ---- Sets ---- *) + let set_key v = Sx_types.inspect v in + register "make-set" (fun args -> + let ht = Hashtbl.create 8 in + (match args with + | [] -> () + | [List items] -> List.iter (fun v -> Hashtbl.replace ht (set_key v) v) items + | [ListRef r] -> List.iter (fun v -> Hashtbl.replace ht (set_key v) v) !r + | _ -> raise (Eval_error "make-set: expected optional list")); + SxSet ht); + register "set?" (fun args -> + match args with + | [SxSet _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "set?: 1 arg")); + register "set-add!" (fun args -> + match args with + | [SxSet ht; v] -> Hashtbl.replace ht (set_key v) v; Nil + | _ -> raise (Eval_error "set-add!: expected set val")); + register "set-member?" (fun args -> + match args with + | [SxSet ht; v] -> Bool (Hashtbl.mem ht (set_key v)) + | _ -> raise (Eval_error "set-member?: expected set val")); + register "set-remove!" (fun args -> + match args with + | [SxSet ht; v] -> Hashtbl.remove ht (set_key v); Nil + | _ -> raise (Eval_error "set-remove!: expected set val")); + register "set-size" (fun args -> + match args with + | [SxSet ht] -> Integer (Hashtbl.length ht) + | _ -> raise (Eval_error "set-size: expected set")); + register "set->list" (fun args -> + match args with + | [SxSet ht] -> List (Hashtbl.fold (fun _ v acc -> v :: acc) ht []) + | _ -> raise (Eval_error "set->list: expected set")); + register "list->set" (fun args -> + match args with + | [List items] -> + let ht = Hashtbl.create (List.length items) in + List.iter (fun v -> Hashtbl.replace ht (set_key v) v) items; + SxSet ht + | [ListRef r] -> + let ht = Hashtbl.create (List.length !r) in + List.iter (fun v -> Hashtbl.replace ht (set_key v) v) !r; + SxSet ht + | [Nil] -> SxSet (Hashtbl.create 0) + | _ -> raise (Eval_error "list->set: expected list")); + register "set-union" (fun args -> + match args with + | [SxSet a; SxSet b] -> + let ht = Hashtbl.copy a in + Hashtbl.iter (fun k v -> Hashtbl.replace ht k v) b; + SxSet ht + | _ -> raise (Eval_error "set-union: expected 2 sets")); + register "set-intersection" (fun args -> + match args with + | [SxSet a; SxSet b] -> + let ht = Hashtbl.create 8 in + Hashtbl.iter (fun k v -> if Hashtbl.mem b k then Hashtbl.replace ht k v) a; + SxSet ht + | _ -> raise (Eval_error "set-intersection: expected 2 sets")); + register "set-difference" (fun args -> + match args with + | [SxSet a; SxSet b] -> + let ht = Hashtbl.create 8 in + Hashtbl.iter (fun k v -> if not (Hashtbl.mem b k) then Hashtbl.replace ht k v) a; + SxSet ht + | _ -> raise (Eval_error "set-difference: expected 2 sets")); + register "set-for-each" (fun args -> + match args with + | [SxSet ht; fn] -> + Hashtbl.iter (fun _ v -> ignore (!Sx_types._cek_call_ref fn (List [v]))) ht; + Nil + | _ -> raise (Eval_error "set-for-each: expected set fn")); + register "set-map" (fun args -> + match args with + | [SxSet ht; fn] -> + let out = Hashtbl.create (Hashtbl.length ht) in + Hashtbl.iter (fun _ v -> + let r = !Sx_types._cek_call_ref fn (List [v]) in + Hashtbl.replace out (set_key r) r) ht; + SxSet out + | _ -> raise (Eval_error "set-map: expected set fn")); + (* === Bytevectors === *) + register "make-bytevector" (fun args -> + match args with + | [Integer n] -> SxBytevector (Bytes.make n '\000') + | [Integer n; Integer fill] -> + if fill < 0 || fill > 255 then raise (Eval_error "make-bytevector: fill must be 0-255"); + SxBytevector (Bytes.make n (Char.chr fill)) + | _ -> raise (Eval_error "make-bytevector: expected n [fill]")); + register "bytevector?" (fun args -> + match args with + | [SxBytevector _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "bytevector?: 1 arg")); + register "bytevector-length" (fun args -> + match args with + | [SxBytevector b] -> Integer (Bytes.length b) + | _ -> raise (Eval_error "bytevector-length: expected bytevector")); + register "bytevector-u8-ref" (fun args -> + match args with + | [SxBytevector b; Integer i] -> + if i < 0 || i >= Bytes.length b then + raise (Eval_error (Printf.sprintf "bytevector-u8-ref: index %d out of range" i)); + Integer (Char.code (Bytes.get b i)) + | _ -> raise (Eval_error "bytevector-u8-ref: expected bytevector index")); + register "bytevector-u8-set!" (fun args -> + match args with + | [SxBytevector b; Integer i; Integer byte] -> + if i < 0 || i >= Bytes.length b then + raise (Eval_error (Printf.sprintf "bytevector-u8-set!: index %d out of range" i)); + if byte < 0 || byte > 255 then + raise (Eval_error "bytevector-u8-set!: byte must be 0-255"); + Bytes.set b i (Char.chr byte); Nil + | _ -> raise (Eval_error "bytevector-u8-set!: expected bytevector index byte")); + register "bytevector-copy" (fun args -> + match args with + | [SxBytevector b] -> SxBytevector (Bytes.copy b) + | [SxBytevector b; Integer start] -> + let len = Bytes.length b - start in + SxBytevector (Bytes.sub b start len) + | [SxBytevector b; Integer start; Integer stop] -> + SxBytevector (Bytes.sub b start (stop - start)) + | _ -> raise (Eval_error "bytevector-copy: expected bytevector [start [end]]")); + register "bytevector-copy!" (fun args -> + let do_copy dst at src start stop = + let len = stop - start in + Bytes.blit src start dst at len; Nil + in + match args with + | [SxBytevector dst; Integer at; SxBytevector src] -> + do_copy dst at src 0 (Bytes.length src) + | [SxBytevector dst; Integer at; SxBytevector src; Integer start] -> + do_copy dst at src start (Bytes.length src) + | [SxBytevector dst; Integer at; SxBytevector src; Integer start; Integer stop] -> + do_copy dst at src start stop + | _ -> raise (Eval_error "bytevector-copy!: expected dst at src [start [end]]")); + register "bytevector-append" (fun args -> + let bufs = List.map (function + | SxBytevector b -> b + | _ -> raise (Eval_error "bytevector-append: expected bytevectors")) args in + let total = List.fold_left (fun acc b -> acc + Bytes.length b) 0 bufs in + let result = Bytes.create total in + let pos = ref 0 in + List.iter (fun b -> + let len = Bytes.length b in + Bytes.blit b 0 result !pos len; + pos := !pos + len) bufs; + SxBytevector result); + register "utf8->string" (fun args -> + match args with + | [SxBytevector b] -> String (Bytes.to_string b) + | [SxBytevector b; Integer start] -> + String (Bytes.sub_string b start (Bytes.length b - start)) + | [SxBytevector b; Integer start; Integer stop] -> + String (Bytes.sub_string b start (stop - start)) + | _ -> raise (Eval_error "utf8->string: expected bytevector [start [end]]")); + register "string->utf8" (fun args -> + match args with + | [String s] -> SxBytevector (Bytes.of_string s) + | [String s; Integer start] -> + let len = String.length s - start in + SxBytevector (Bytes.of_string (String.sub s start len)) + | [String s; Integer start; Integer stop] -> + SxBytevector (Bytes.of_string (String.sub s start (stop - start))) + | _ -> raise (Eval_error "string->utf8: expected string [start [end]]")); + register "bytevector->list" (fun args -> + match args with + | [SxBytevector b] -> + let items = List.init (Bytes.length b) (fun i -> Integer (Char.code (Bytes.get b i))) in + List items + | _ -> raise (Eval_error "bytevector->list: expected bytevector")); + register "list->bytevector" (fun args -> + match args with + | [List items] | [ListRef { contents = items }] -> + let bytes_list = List.map (function + | Integer n when n >= 0 && n <= 255 -> Char.chr n + | Integer n -> raise (Eval_error (Printf.sprintf "list->bytevector: byte %d out of range" n)) + | v -> raise (Eval_error ("list->bytevector: expected integer, got " ^ Sx_types.type_of v))) items in + let b = Bytes.create (List.length bytes_list) in + List.iteri (fun i c -> Bytes.set b i c) bytes_list; + SxBytevector b + | [Nil] -> SxBytevector (Bytes.create 0) + | _ -> raise (Eval_error "list->bytevector: expected list")) diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 590ea6de..545ddea7 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -10,7 +10,7 @@ open Sx_runtime let trampoline_fn : (value -> value) ref = ref (fun v -> v) let trampoline v = !trampoline_fn v -(* Step limit for timeout protection *) +(* Step limit for timeout detection — set to 0 to disable *) let step_limit : int ref = ref 0 let step_count : int ref = ref 0 @@ -24,6 +24,19 @@ let _protocol_registry_ = Dict (Hashtbl.create 0) (* === Transpiled from evaluator (frames + eval + CEK) === *) +(* seq-to-list: coerce list/vector/string/nil to list for HO dispatch *) +let seq_to_list v = + match v with + | Nil -> List [] + | List _ -> v + | ListRef { contents = items } -> List items + | Vector arr -> List (Array.to_list arr) + | String s -> + let chars = ref [] in + String.iter (fun c -> chars := String (String.make 1 c) :: !chars) s; + List (List.rev !chars) + | _ -> v + (* make-cek-state *) let rec make_cek_state control env kont = (CekState { cs_control = control; cs_env = env; cs_kont = kont; cs_phase = "eval"; cs_value = Nil }) @@ -198,7 +211,7 @@ and make_or_frame remaining env = (* make-dynamic-wind-frame *) and make_dynamic_wind_frame phase body_thunk after_thunk env = - (CekFrame { cf_type = "dynamic-wind"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = phase; cf_extra2 = Nil }) + (CekFrame { cf_type = "dynamic-wind"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = after_thunk; cf_args = Nil; cf_results = Nil; cf_extra = phase; cf_extra2 = Nil }) (* make-reactive-reset-frame *) and make_reactive_reset_frame env update_fn first_render_p = @@ -208,6 +221,14 @@ and make_reactive_reset_frame env update_fn first_render_p = and make_callcc_frame env = (CekFrame { cf_type = "callcc"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) +(* make-wind-after-frame *) +and make_wind_after_frame after_thunk winders_len env = + (CekFrame { cf_type = "wind-after"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = after_thunk; cf_args = Nil; cf_results = Nil; cf_extra = winders_len; cf_extra2 = Nil }) + +(* make-wind-return-frame *) +and make_wind_return_frame body_result env = + (CekFrame { cf_type = "wind-return"; cf_env = env; cf_name = body_result; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) + (* make-deref-frame *) and make_deref_frame env = (CekFrame { cf_type = "deref"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) @@ -268,6 +289,14 @@ and find_matching_handler handlers condition = and kont_find_handler kont condition = (if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "handler")])) then (let match' = (find_matching_handler ((get (frame) ((String "f")))) (condition)) in (if sx_truthy ((is_nil (match'))) then (kont_find_handler ((rest (kont))) (condition)) else match')) else (kont_find_handler ((rest (kont))) (condition))))) +(* kont-unwind-to-handler *) +and kont_unwind_to_handler kont condition = + (if sx_truthy ((empty_p (kont))) then (let _d = Hashtbl.create 2 in Hashtbl.replace _d "handler" Nil; Hashtbl.replace _d "kont" kont; Dict _d) else (let frame = (first (kont)) in let rest_k = (rest (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "handler")])) then (let match' = (find_matching_handler ((get (frame) ((String "f")))) (condition)) in (if sx_truthy ((is_nil (match'))) then (kont_unwind_to_handler (rest_k) (condition)) else (let _d = Hashtbl.create 2 in Hashtbl.replace _d "handler" match'; Hashtbl.replace _d "kont" kont; Dict _d))) else (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "wind-after")])) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (!_winders_ref)); (get (frame) ((String "winders-len")))])) then (_winders_ref := (rest (!_winders_ref)); Nil) else Nil)) in (let () = ignore ((cek_call ((get (frame) ((String "after-thunk")))) ((List [])))) in (kont_unwind_to_handler (rest_k) (condition)))) else (kont_unwind_to_handler (rest_k) (condition)))))) + +(* wind-escape-to *) +and wind_escape_to target_len = + (if sx_truthy ((prim_call ">" [(len (!_winders_ref)); target_len])) then (let after_thunk = (first (!_winders_ref)) in (let () = ignore ((_winders_ref := (rest (!_winders_ref)); Nil)) in (let () = ignore ((cek_call (after_thunk) ((List [])))) in (wind_escape_to (target_len))))) else Nil) + (* find-named-restart *) and find_named_restart restarts name = (if sx_truthy ((empty_p (restarts))) then Nil else (let entry = (first (restarts)) in (if sx_truthy ((prim_call "=" [(first (entry)); name])) then entry else (find_named_restart ((rest (restarts))) (name))))) @@ -356,6 +385,11 @@ and _provide_subscribers_ref = ref (Dict (Hashtbl.create 0)) and _provide_subscribers_ = (Dict (Hashtbl.create 0)) +(* *winders* *) +and _winders_ref = ref (List []) +and _winders_ = + (List []) + (* *library-registry* *) and _library_registry_ = (Dict (Hashtbl.create 0)) @@ -558,9 +592,9 @@ and sf_letrec args env = and step_sf_letrec args env kont = (let thk = (sf_letrec (args) (env)) in (make_cek_state ((thunk_expr (thk))) ((thunk_env (thk))) (kont))) -(* sf-dynamic-wind *) -and sf_dynamic_wind args env = - (let before = (trampoline ((eval_expr ((first (args))) (env)))) in let body = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let after = (trampoline ((eval_expr ((nth (args) ((Number 2.0)))) (env)))) in (dynamic_wind_call (before) (body) (after) (env))) +(* step-sf-dynamic-wind *) +and step_sf_dynamic_wind args env kont = + (let before = (trampoline ((eval_expr ((first (args))) (env)))) in let body = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let after = (trampoline ((eval_expr ((nth (args) ((Number 2.0)))) (env)))) in (let () = ignore ((cek_call (before) ((List [])))) in (let winders_len = (len (!_winders_ref)) in (let () = ignore ((_winders_ref := (cons (after) (!_winders_ref)); Nil)) in (continue_with_call (body) ((List [])) (env) ((List [])) ((kont_push ((make_wind_after_frame (after) (winders_len) (env))) (kont)))))))) (* sf-scope *) and sf_scope args env = @@ -576,34 +610,11 @@ and expand_macro mac raw_args env = (* cek-step-loop *) and cek_step_loop state = - if !step_limit > 0 then begin - step_count := !step_count + 1; - if !step_count > !step_limit then - raise (Sx_types.Eval_error "TIMEOUT: step limit exceeded") - end; - (if sx_truthy ((let _or = (cek_terminal_p (state)) in if sx_truthy _or then _or else (cek_suspended_p (state)))) then state else begin - let next = (try cek_step (state) - with Sx_types.CekPerformRequest request -> - make_cek_suspended request (cek_env state) (cek_kont state)) - in cek_step_loop next - end) + (if sx_truthy ((let _or = (cek_terminal_p (state)) in if sx_truthy _or then _or else (cek_suspended_p (state)))) then state else (cek_step_loop ((cek_step (state))))) -(* cek-run — with IO suspension hooks for the OCaml host *) +(* cek-run *) and cek_run state = - let rec run s = - let final = cek_step_loop s in - if sx_truthy (cek_suspended_p final) then - match !Sx_types._cek_io_resolver with - | Some resolver -> - let request = cek_io_request final in - let result = resolver request final in - run (cek_resume final result) - | None -> - (match !Sx_types._cek_io_suspend_hook with - | Some hook -> hook final - | None -> raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))) - else cek_value final - in run state + (let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))) else (cek_value (final)))) (* cek-resume *) and cek_resume suspended_state result' = @@ -639,7 +650,7 @@ and step_sf_let_match args env kont = (* step-eval-list *) and step_eval_list expr env kont = - (let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((let _or = (prim_call "=" [(type_of (head)); (String "symbol")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [(type_of (head)); (String "lambda")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (head)); (String "list")])))))))) then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (make_cek_state ((first (expr))) (env) ((kont_push ((make_map_frame (Nil) ((rest (expr))) ((List [])) (env))) (kont))))) else (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (let name = (symbol_name (head)) in (let _match_val = name in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (step_sf_if (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (step_sf_when (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (step_sf_cond (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (step_sf_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (step_sf_and (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (step_sf_or (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let*")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "lambda")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "fn")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defio")])) then (make_cek_value ((sf_defio (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-foreign")])) then (step_sf_define_foreign (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "io")])) then (step_sf_io (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "do")])) then (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (args)))))) in if not (sx_truthy _and) then _and else (let _and = (list_p ((first (args)))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p ((first (args)))))))) in if not (sx_truthy _and) then _and else (list_p ((first ((first (args)))))))))) then (let bindings = (first (args)) in let test_clause = (nth (args) ((Number 1.0))) in let body = (rest ((rest (args)))) in let vars = (List (List.map (fun b -> (first (b))) (sx_to_list bindings))) in let inits = (List (List.map (fun b -> (nth (b) ((Number 1.0)))) (sx_to_list bindings))) in let steps = (List (List.map (fun b -> (if sx_truthy ((prim_call ">" [(len (b)); (Number 2.0)])) then (nth (b) ((Number 2.0))) else (first (b)))) (sx_to_list bindings))) in let test = (first (test_clause)) in let result' = (rest (test_clause)) in (step_eval_list ((cons ((Symbol "let")) ((cons ((Symbol "__do-loop")) ((cons ((List (List.map (fun b -> (List [(first (b)); (nth (b) ((Number 1.0)))])) (sx_to_list bindings)))) ((List [(cons ((Symbol "if")) ((cons (test) ((cons ((if sx_truthy ((empty_p (result'))) then Nil else (cons ((Symbol "begin")) (result')))) ((List [(cons ((Symbol "begin")) ((prim_call "append" [body; (List [(cons ((Symbol "__do-loop")) (steps))])])))])))))))])))))))) (env) (kont))) else (step_sf_begin (args) (env) (kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "guard")])) then (step_sf_guard (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quote")])) then (make_cek_value ((if sx_truthy ((empty_p (args))) then Nil else (first (args)))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->>")])) then (step_sf_thread_last (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "|>")])) then (step_sf_thread_last (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "as->")])) then (step_sf_thread_as (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "peek")])) then (step_sf_peek (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide!")])) then (step_sf_provide_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "bind")])) then (step_sf_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler-bind")])) then (step_sf_handler_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart-case")])) then (step_sf_restart_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-condition")])) then (step_sf_signal (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "invoke-restart")])) then (step_sf_invoke_restart (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "match")])) then (step_sf_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let-match")])) then (step_sf_let_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise")])) then (step_sf_raise (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-continuable")])) then (make_cek_state ((first (args))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool true)))) (kont)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "call/cc")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "call-with-current-continuation")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (step_sf_perform (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-library")])) then (step_sf_define_library (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (step_sf_import (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-record-type")])) then (make_cek_value ((sf_define_record_type (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-protocol")])) then (make_cek_value ((sf_define_protocol (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "implement")])) then (make_cek_value ((sf_implement (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (step_sf_parameterize (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "syntax-rules")])) then (make_cek_value ((sf_syntax_rules (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-syntax")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((let _and = (prim_call "has-key?" [custom_special_forms; name]) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((env_has (env) (name)))))))) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((env_has (env) (name)))))) in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env]))))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont))))) + (let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((let _or = (prim_call "=" [(type_of (head)); (String "symbol")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [(type_of (head)); (String "lambda")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (head)); (String "list")])))))))) then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (make_cek_state ((first (expr))) (env) ((kont_push ((make_map_frame (Nil) ((rest (expr))) ((List [])) (env))) (kont))))) else (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (let name = (symbol_name (head)) in (let _match_val = name in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (step_sf_if (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (step_sf_when (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (step_sf_cond (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (step_sf_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (step_sf_and (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (step_sf_or (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let*")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "lambda")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "fn")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defio")])) then (make_cek_value ((sf_defio (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-foreign")])) then (step_sf_define_foreign (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "io")])) then (step_sf_io (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "do")])) then (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (args)))))) in if not (sx_truthy _and) then _and else (let _and = (list_p ((first (args)))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p ((first (args)))))))) in if not (sx_truthy _and) then _and else (list_p ((first ((first (args)))))))))) then (let bindings = (first (args)) in let test_clause = (nth (args) ((Number 1.0))) in let body = (rest ((rest (args)))) in let vars = (List (List.map (fun b -> (first (b))) (sx_to_list bindings))) in let inits = (List (List.map (fun b -> (nth (b) ((Number 1.0)))) (sx_to_list bindings))) in let steps = (List (List.map (fun b -> (if sx_truthy ((prim_call ">" [(len (b)); (Number 2.0)])) then (nth (b) ((Number 2.0))) else (first (b)))) (sx_to_list bindings))) in let test = (first (test_clause)) in let result' = (rest (test_clause)) in (step_eval_list ((cons ((Symbol "let")) ((cons ((Symbol "__do-loop")) ((cons ((List (List.map (fun b -> (List [(first (b)); (nth (b) ((Number 1.0)))])) (sx_to_list bindings)))) ((List [(cons ((Symbol "if")) ((cons (test) ((cons ((if sx_truthy ((empty_p (result'))) then Nil else (cons ((Symbol "begin")) (result')))) ((List [(cons ((Symbol "begin")) ((prim_call "append" [body; (List [(cons ((Symbol "__do-loop")) (steps))])])))])))))))])))))))) (env) (kont))) else (step_sf_begin (args) (env) (kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "guard")])) then (step_sf_guard (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quote")])) then (make_cek_value ((if sx_truthy ((empty_p (args))) then Nil else (first (args)))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->>")])) then (step_sf_thread_last (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "|>")])) then (step_sf_thread_last (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "as->")])) then (step_sf_thread_as (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "peek")])) then (step_sf_peek (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide!")])) then (step_sf_provide_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "bind")])) then (step_sf_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler-bind")])) then (step_sf_handler_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart-case")])) then (step_sf_restart_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-condition")])) then (step_sf_signal (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "invoke-restart")])) then (step_sf_invoke_restart (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "match")])) then (step_sf_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let-match")])) then (step_sf_let_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "dynamic-wind")])) then (step_sf_dynamic_wind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise")])) then (step_sf_raise (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-continuable")])) then (make_cek_state ((first (args))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool true)))) (kont)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "call/cc")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "call-with-current-continuation")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (step_sf_perform (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-library")])) then (step_sf_define_library (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (step_sf_import (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-record-type")])) then (make_cek_value ((sf_define_record_type (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-protocol")])) then (make_cek_value ((sf_define_protocol (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "implement")])) then (make_cek_value ((sf_implement (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (step_sf_parameterize (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "syntax-rules")])) then (make_cek_value ((sf_syntax_rules (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-syntax")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((let _and = (prim_call "has-key?" [custom_special_forms; name]) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((env_has (env) (name)))))))) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((env_has (env) (name)))))) in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env]))))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont))))) (* kont-extract-provides *) and kont_extract_provides kont = @@ -744,11 +755,11 @@ and match_find_clause val' clauses env = (* match-pattern *) and match_pattern pattern value env = - (if sx_truthy ((prim_call "=" [pattern; (Symbol "_")])) then (Bool true) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (pattern)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "?")])))) then (let pred = (eval_expr ((nth (pattern) ((Number 1.0)))) (env)) in (cek_call (pred) ((List [value])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "quote")])))) then (prim_call "=" [value; (nth (pattern) ((Number 1.0)))]) else (if sx_truthy ((symbol_p (pattern))) then (let () = ignore ((env_bind env (sx_to_string (symbol_name (pattern))) value)) in (Bool true)) else (if sx_truthy ((let _and = (dict_p (pattern)) in if not (sx_truthy _and) then _and else (dict_p (value)))) then (Bool (List.for_all (fun k -> sx_truthy ((match_pattern ((get (pattern) (k))) ((get (value) (k))) (env)))) (sx_to_list (prim_call "keys" [pattern])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (list_p (value)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [pattern; (Symbol "&rest")])))) then (let rest_idx = (prim_call "index-of" [pattern; (Symbol "&rest")]) in (let _and = (prim_call ">=" [(len (value)); rest_idx]) in if not (sx_truthy _and) then _and else (let _and = (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list (prim_call "zip" [(prim_call "slice" [pattern; (Number 0.0); rest_idx]); (prim_call "slice" [value; (Number 0.0); rest_idx])])))) in if not (sx_truthy _and) then _and else (let rest_name = (nth (pattern) ((prim_call "+" [rest_idx; (Number 1.0)]))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (rest_name))) (prim_call "slice" [value; rest_idx]))) in (Bool true)))))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (value)))) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(len (pattern)); (len (value))])))))) then (Bool false) else (let pairs = (prim_call "zip" [pattern; value]) in (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list pairs))))) else (prim_call "=" [pattern; value])))))))) + (if sx_truthy ((prim_call "=" [pattern; (Symbol "_")])) then (Bool true) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (pattern)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "?")])))) then (let pred = (eval_expr ((nth (pattern) ((Number 1.0)))) (env)) in (cek_call (pred) ((List [value])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "quote")])))) then (prim_call "=" [value; (nth (pattern) ((Number 1.0)))]) else (if sx_truthy ((symbol_p (pattern))) then (let () = ignore ((env_bind env (sx_to_string (symbol_name (pattern))) value)) in (Bool true)) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (let _and = (symbol_p ((first (pattern)))) in if not (sx_truthy _and) then _and else (let _and = (dict_p (value)) in if not (sx_truthy _and) then _and else (get (value) ((String "_adt")))))))) then (let ctor_name = (symbol_name ((first (pattern)))) in let field_patterns = (rest (pattern)) in let fields = (get (value) ((String "_fields"))) in (let _and = (prim_call "=" [(get (value) ((String "_ctor"))); ctor_name]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (field_patterns)); (len (fields))]) in if not (sx_truthy _and) then _and else (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list (prim_call "zip" [field_patterns; fields]))))))) else (if sx_truthy ((let _and = (dict_p (pattern)) in if not (sx_truthy _and) then _and else (dict_p (value)))) then (Bool (List.for_all (fun k -> sx_truthy ((match_pattern ((get (pattern) (k))) ((get (value) (k))) (env)))) (sx_to_list (prim_call "keys" [pattern])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (list_p (value)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [pattern; (Symbol "&rest")])))) then (let rest_idx = (prim_call "index-of" [pattern; (Symbol "&rest")]) in (let _and = (prim_call ">=" [(len (value)); rest_idx]) in if not (sx_truthy _and) then _and else (let _and = (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list (prim_call "zip" [(prim_call "slice" [pattern; (Number 0.0); rest_idx]); (prim_call "slice" [value; (Number 0.0); rest_idx])])))) in if not (sx_truthy _and) then _and else (let rest_name = (nth (pattern) ((prim_call "+" [rest_idx; (Number 1.0)]))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (rest_name))) (prim_call "slice" [value; rest_idx]))) in (Bool true)))))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (value)))) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(len (pattern)); (len (value))])))))) then (Bool false) else (let pairs = (prim_call "zip" [pattern; value]) in (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list pairs))))) else (prim_call "=" [pattern; value]))))))))) (* step-sf-match *) and step_sf_match args env kont = - (let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (raise (Eval_error (value_to_str (String (sx_str [(String "match: no clause matched "); (inspect (val'))]))))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))) + (let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))) (* step-sf-handler-bind *) and step_sf_handler_bind args env kont = @@ -784,6 +795,14 @@ and step_sf_let args env kont = (* step-sf-define *) and step_sf_define args env kont = + (* Desugar shorthand: (define (name p ...) body) -> (define name (fn (p ...) body)) *) + let args = match first args with + | List (fn_name :: params) -> + let body_parts = sx_to_list (rest args) in + let lambda_expr = List (Symbol "fn" :: List params :: body_parts) in + List [fn_name; lambda_expr] + | _ -> args + in (let name_sym = (first (args)) in let has_effects = (let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")]))) in let val_idx = (if sx_truthy ((let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")])))) then (Number 3.0) else (Number 1.0)) in let effect_list = (if sx_truthy ((let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")])))) then (nth (args) ((Number 2.0))) else Nil) in (make_cek_state ((nth (args) (val_idx))) (env) ((kont_push ((make_define_frame ((symbol_name (name_sym))) (env) (has_effects) (effect_list))) (kont))))) (* step-sf-set! *) @@ -884,7 +903,7 @@ and ho_swap_args ho_type evaled = (* ho-setup-dispatch *) and ho_setup_dispatch ho_type evaled env kont = - (let ordered = (ho_swap_args (ho_type) (evaled)) in (let f = (first (ordered)) in (let _match_val = ho_type in (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (if sx_truthy ((prim_call ">" [(len (ordered)); (Number 2.0)])) then (let colls = (rest (ordered)) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list colls)))) then (make_cek_value ((List [])) (env) (kont)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list colls))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list colls))) in (continue_with_call (f) (heads) (env) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) ((List [])) (env))) (kont))))))) else (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_map_frame (f) ((rest (coll))) ((List [])) (env))) (kont))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(Number 0.0); (first (coll))])) (env) ((List [])) ((kont_push ((make_map_indexed_frame (f) ((rest (coll))) ((List [])) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (coll))) ((List [])) ((first (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let init = (nth (ordered) ((Number 1.0))) in let coll = (nth (ordered) ((Number 2.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (init) (env) (kont)) else (continue_with_call (f) ((List [init; (first (coll))])) (env) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool false)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_some_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool true)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_every_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (Nil) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (coll))) (env))) (kont)))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown HO type: "); ho_type]))))))))))))))) + (let ordered = (ho_swap_args (ho_type) (evaled)) in (let f = (first (ordered)) in (let _match_val = ho_type in (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (if sx_truthy ((prim_call ">" [(len (ordered)); (Number 2.0)])) then (let colls = (rest (ordered)) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list colls)))) then (make_cek_value ((List [])) (env) (kont)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list colls))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list colls))) in (continue_with_call (f) (heads) (env) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) ((List [])) (env))) (kont))))))) else (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_map_frame (f) ((rest (coll))) ((List [])) (env))) (kont))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(Number 0.0); (first (coll))])) (env) ((List [])) ((kont_push ((make_map_indexed_frame (f) ((rest (coll))) ((List [])) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (coll))) ((List [])) ((first (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let init = (nth (ordered) ((Number 1.0))) in let coll = seq_to_list (nth (ordered) ((Number 2.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (init) (env) (kont)) else (continue_with_call (f) ((List [init; (first (coll))])) (env) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool false)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_some_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool true)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_every_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (Nil) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (coll))) (env))) (kont)))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown HO type: "); ho_type]))))))))))))))) (* step-ho-map *) and step_ho_map args env kont = @@ -916,11 +935,11 @@ and step_ho_for_each args env kont = (* step-continue *) and step_continue state = - (let value = (cek_value (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (if sx_truthy ((kont_empty_p (kont))) then state else (let frame = (kont_top (kont)) in let rest_k = (kont_pop (kont)) in let ft = (frame_type (frame)) in (let _match_val = ft in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (make_cek_state ((get (frame) ((String "then")))) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((is_nil ((get (frame) ((String "else")))))) then (make_cek_value (Nil) (env) (rest_k)) else (make_cek_state ((get (frame) ((String "else")))) ((get (frame) ((String "env")))) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (make_cek_state ((first (body))) (fenv) (rest_k)) else (make_cek_state ((first (body))) (fenv) ((kont_push ((make_begin_frame ((rest (body))) (fenv))) (rest_k))))))) else (make_cek_value (Nil) (env) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then (make_cek_state ((first (remaining))) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_begin_frame ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let body = (get (frame) ((String "body"))) in let local = (get (frame) ((String "env"))) in (let () = ignore ((env_bind local (sx_to_string name) value)) in (if sx_truthy ((empty_p (remaining))) then (step_sf_begin (body) (local) (rest_k)) else (let next_binding = (first (remaining)) in let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (next_binding)))); (String "symbol")])) then (symbol_name ((first (next_binding)))) else (first (next_binding))) in (make_cek_state ((nth (next_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) ((rest (remaining))) (body) (local))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let has_effects = (get (frame) ((String "has-effects"))) in let effect_list = (get (frame) ((String "effect-list"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (let () = ignore ((if sx_truthy (has_effects) then (let effect_names = (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else e)) (sx_to_list effect_list))) in let effect_anns = (if sx_truthy ((env_has (fenv) ((String "*effect-annotations*")))) then (env_get (fenv) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns name effect_names)) in (env_bind fenv (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-foreign")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (make_cek_value (value) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((env_set fenv (sx_to_string name) value)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_and_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (if sx_truthy (value) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_or_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let scheme_p = (get (frame) ((String "scheme"))) in (if sx_truthy (scheme_p) then (if sx_truthy (value) then (let clause = (first (remaining)) in (if sx_truthy ((let _and = (prim_call ">" [(len (clause)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (clause) ((Number 1.0))))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (clause) ((Number 1.0))))); (String "=>")])))) then (make_cek_state ((nth (clause) ((Number 2.0)))) (fenv) ((kont_push ((make_cond_arrow_frame (value) (fenv))) (rest_k)))) else (make_cek_state ((nth (clause) ((Number 1.0)))) (fenv) (rest_k)))) else (let next_clauses = (rest (remaining)) in (if sx_truthy ((empty_p (next_clauses))) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_clause = (first (next_clauses)) in let next_test = (first (next_clause)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next_clause) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next_clauses) (fenv) ((Bool true)))) (rest_k))))))))) else (if sx_truthy (value) then (make_cek_state ((nth (remaining) ((Number 1.0)))) (fenv) (rest_k)) else (let next = (prim_call "slice" [remaining; (Number 2.0); (len (remaining))]) in (if sx_truthy ((prim_call "<" [(len (next)); (Number 2.0)])) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_test = (first (next)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next) (fenv) ((Bool false)))) (rest_k))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (let match_val = (get (frame) ((String "match-val"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (match_val))) then (sf_case_step_loop (value) (remaining) (fenv) (rest_k)) else (sf_case_step_loop (match_val) (remaining) (fenv) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "thread")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let mode = (get (frame) ((String "extra"))) in let bind_name = (get (frame) ((String "name"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (let form = (first (remaining)) in let rest_forms = (rest (remaining)) in let new_kont = (if sx_truthy ((empty_p ((rest (remaining))))) then rest_k else (kont_push ((make_thread_frame ((rest (remaining))) (fenv) (mode) (bind_name))) (rest_k))) in (if sx_truthy ((prim_call "=" [mode; (String "as")])) then (let new_env = (env_extend (fenv)) in (let () = ignore ((env_bind new_env (sx_to_string (symbol_name (bind_name))) value)) in (make_cek_state (form) (new_env) (new_kont)))) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (form)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (form)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (form)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (ho_form_name_p ((symbol_name ((first (form)))))))))) then (make_cek_state ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv) (new_kont)) else (if sx_truthy ((prim_call "=" [mode; (String "last")])) then (let result' = (thread_insert_arg_last (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))) else (let result' = (thread_insert_arg (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "arg")])) then (let f = (get (frame) ((String "f"))) in let evaled = (get (frame) ((String "evaled"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let raw_args = (get (frame) ((String "raw-args"))) in let hname = (get (frame) ((String "head-name"))) in (if sx_truthy ((is_nil (f))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) ((List []))) else Nil)) in (if sx_truthy ((empty_p (remaining))) then (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop ((get (frame) ((String "name")))))) in (make_cek_value (value) (fenv) (rest_k))) else (let new_frame = (make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "subscribers") (get (frame) ((String "subscribers"))))) in (make_cek_state ((first (remaining))) (fenv) ((kont_push (new_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "bind")])) then (let tracked = !_bind_tracking_ref in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in let prev = (get (frame) ((String "prev-tracking"))) in (let () = ignore ((_bind_tracking_ref := prev; Nil)) in (let () = ignore ((let subscriber = (NativeFn ("\206\187", fun _args -> match _args with [fire_kont] -> (fun fire_kont -> (cek_run ((make_cek_state (body) (fenv) ((List [])))))) fire_kont | _ -> Nil)) in (List.iter (fun name -> ignore ((let existing = (get (!_provide_subscribers_ref) (name)) in (sx_dict_set_b !_provide_subscribers_ref name (prim_call "append" [(if sx_truthy (existing) then existing else (List [])); (List [subscriber])]))))) (sx_to_list tracked); Nil))) in (make_cek_value (value) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide-set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let target = (kont_find_provide (rest_k) (name)) in (let old_val = (if sx_truthy (target) then (get (target) ((String "value"))) else (scope_peek (name))) in (let () = ignore ((if sx_truthy (target) then (sx_dict_set_b target (String "value") value) else Nil)) in (let () = ignore ((scope_pop (name))) in (let () = ignore ((scope_push (name) (value))) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [old_val; value])))))) then (fire_provide_subscribers (name)) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_handler_frame ((get (frame) ((String "f")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-return")])) then (let saved_kont = (get (frame) ((String "saved-kont"))) in (make_cek_value (value) ((get (frame) ((String "env")))) (saved_kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "comp-trace")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond-arrow")])) then (let test_value = (get (frame) ((String "match-val"))) in let fenv = (get (frame) ((String "env"))) in (continue_with_call (value) ((List [test_value])) (fenv) ((List [test_value])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-eval")])) then (let condition = value in let fenv = (get (frame) ((String "env"))) in let continuable_p = (get (frame) ((String "scheme"))) in let handler_fn = (kont_find_handler (rest_k) (condition)) in (if sx_truthy ((is_nil (handler_fn))) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String (sx_str [(String "Unhandled exception: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (fenv) ((List [condition])) ((if sx_truthy (continuable_p) then (kont_push ((make_signal_return_frame (fenv) (rest_k))) (rest_k)) else (kont_push ((make_raise_guard_frame (fenv) (rest_k))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-guard")])) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String "exception handler returned from non-continuable raise")))) else (if sx_truthy ((prim_call "=" [_match_val; (String "multi-map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let new_results = (prim_call "append" [(get (frame) ((String "results"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list remaining)))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list remaining))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list remaining))) in (continue_with_call (f) (heads) (fenv) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) (new_results) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "callcc")])) then (let k = (make_callcc_continuation (rest_k)) in (continue_with_call (value) ((List [k])) ((get (frame) ((String "env")))) ((List [k])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "vm-resume")])) then (let resume_fn = (get (frame) ((String "f"))) in (let result' = (sx_apply resume_fn (List [value])) in (if sx_truthy ((let _and = (dict_p (result')) in if not (sx_truthy _and) then _and else (get (result') ((String "__vm_suspended"))))) then (make_cek_suspended ((get (result') ((String "request")))) ((get (frame) ((String "env")))) ((kont_push ((make_vm_resume_frame ((get (result') ((String "resume")))) ((get (frame) ((String "env")))))) (rest_k)))) else (make_cek_value (result') ((get (frame) ((String "env")))) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (make_cek_suspended (value) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (let import_set = (get (frame) ((String "args"))) in let remaining_sets = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((bind_import_set (import_set) (fenv))) in (if sx_truthy ((empty_p (remaining_sets))) then (make_cek_value (Nil) (fenv) (rest_k)) else (step_sf_import (remaining_sets) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (let remaining = (get (frame) ((String "remaining"))) in let current_param = (get (frame) ((String "f"))) in let results = (get (frame) ((String "results"))) in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (current_param))) then (let param_obj = value in let val_expr = (nth ((first (remaining))) ((Number 1.0))) in (make_cek_state (val_expr) (fenv) ((kont_push ((make_parameterize_frame (remaining) (param_obj) (results) (body) (fenv))) (rest_k))))) else (let converted_val = value in let new_results = (prim_call "append" [results; (List [(List [(parameter_uid (current_param)); converted_val])])]) in let rest_bindings = (rest (remaining)) in (if sx_truthy ((empty_p (rest_bindings))) then (let body_expr = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((Symbol "begin")) (body))) in let provide_kont = (kont_push_provides (new_results) (fenv) (rest_k)) in (make_cek_state (body_expr) (fenv) (provide_kont))) else (make_cek_state ((first ((first (rest_bindings))))) (fenv) ((kont_push ((make_parameterize_frame (rest_bindings) (Nil) (new_results) (body) (fenv))) (rest_k)))))))) else (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))))))))))))))))))))) + (let value = (cek_value (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (if sx_truthy ((kont_empty_p (kont))) then state else (let frame = (kont_top (kont)) in let rest_k = (kont_pop (kont)) in let ft = (frame_type (frame)) in (let _match_val = ft in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (make_cek_state ((get (frame) ((String "then")))) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((is_nil ((get (frame) ((String "else")))))) then (make_cek_value (Nil) (env) (rest_k)) else (make_cek_state ((get (frame) ((String "else")))) ((get (frame) ((String "env")))) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (make_cek_state ((first (body))) (fenv) (rest_k)) else (make_cek_state ((first (body))) (fenv) ((kont_push ((make_begin_frame ((rest (body))) (fenv))) (rest_k))))))) else (make_cek_value (Nil) (env) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then (make_cek_state ((first (remaining))) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_begin_frame ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let body = (get (frame) ((String "body"))) in let local = (get (frame) ((String "env"))) in (let () = ignore ((env_bind local (sx_to_string name) value)) in (if sx_truthy ((empty_p (remaining))) then (step_sf_begin (body) (local) (rest_k)) else (let next_binding = (first (remaining)) in let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (next_binding)))); (String "symbol")])) then (symbol_name ((first (next_binding)))) else (first (next_binding))) in (make_cek_state ((nth (next_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) ((rest (remaining))) (body) (local))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let has_effects = (get (frame) ((String "has-effects"))) in let effect_list = (get (frame) ((String "effect-list"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (let () = ignore ((if sx_truthy (has_effects) then (let effect_names = (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else e)) (sx_to_list effect_list))) in let effect_anns = (if sx_truthy ((env_has (fenv) ((String "*effect-annotations*")))) then (env_get (fenv) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns name effect_names)) in (env_bind fenv (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-foreign")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (make_cek_value (value) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((env_set fenv (sx_to_string name) value)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_and_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (if sx_truthy (value) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_or_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let scheme_p = (get (frame) ((String "scheme"))) in (if sx_truthy (scheme_p) then (if sx_truthy (value) then (let clause = (first (remaining)) in (if sx_truthy ((let _and = (prim_call ">" [(len (clause)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (clause) ((Number 1.0))))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (clause) ((Number 1.0))))); (String "=>")])))) then (make_cek_state ((nth (clause) ((Number 2.0)))) (fenv) ((kont_push ((make_cond_arrow_frame (value) (fenv))) (rest_k)))) else (make_cek_state ((nth (clause) ((Number 1.0)))) (fenv) (rest_k)))) else (let next_clauses = (rest (remaining)) in (if sx_truthy ((empty_p (next_clauses))) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_clause = (first (next_clauses)) in let next_test = (first (next_clause)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next_clause) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next_clauses) (fenv) ((Bool true)))) (rest_k))))))))) else (if sx_truthy (value) then (make_cek_state ((nth (remaining) ((Number 1.0)))) (fenv) (rest_k)) else (let next = (prim_call "slice" [remaining; (Number 2.0); (len (remaining))]) in (if sx_truthy ((prim_call "<" [(len (next)); (Number 2.0)])) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_test = (first (next)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next) (fenv) ((Bool false)))) (rest_k))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (let match_val = (get (frame) ((String "match-val"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (match_val))) then (sf_case_step_loop (value) (remaining) (fenv) (rest_k)) else (sf_case_step_loop (match_val) (remaining) (fenv) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "thread")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let mode = (get (frame) ((String "extra"))) in let bind_name = (get (frame) ((String "name"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (let form = (first (remaining)) in let rest_forms = (rest (remaining)) in let new_kont = (if sx_truthy ((empty_p ((rest (remaining))))) then rest_k else (kont_push ((make_thread_frame ((rest (remaining))) (fenv) (mode) (bind_name))) (rest_k))) in (if sx_truthy ((prim_call "=" [mode; (String "as")])) then (let new_env = (env_extend (fenv)) in (let () = ignore ((env_bind new_env (sx_to_string (symbol_name (bind_name))) value)) in (make_cek_state (form) (new_env) (new_kont)))) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (form)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (form)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (form)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (ho_form_name_p ((symbol_name ((first (form)))))))))) then (make_cek_state ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv) (new_kont)) else (if sx_truthy ((prim_call "=" [mode; (String "last")])) then (let result' = (thread_insert_arg_last (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))) else (let result' = (thread_insert_arg (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "arg")])) then (let f = (get (frame) ((String "f"))) in let evaled = (get (frame) ((String "evaled"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let raw_args = (get (frame) ((String "raw-args"))) in let hname = (get (frame) ((String "head-name"))) in (if sx_truthy ((is_nil (f))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) ((List []))) else Nil)) in (if sx_truthy ((empty_p (remaining))) then (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop ((get (frame) ((String "name")))))) in (make_cek_value (value) (fenv) (rest_k))) else (let new_frame = (make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "subscribers") (get (frame) ((String "subscribers"))))) in (make_cek_state ((first (remaining))) (fenv) ((kont_push (new_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "bind")])) then (let tracked = !_bind_tracking_ref in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in let prev = (get (frame) ((String "prev-tracking"))) in (let () = ignore ((_bind_tracking_ref := prev; Nil)) in (let () = ignore ((let subscriber = (NativeFn ("\206\187", fun _args -> match _args with [fire_kont] -> (fun fire_kont -> (cek_run ((make_cek_state (body) (fenv) ((List [])))))) fire_kont | _ -> Nil)) in (List.iter (fun name -> ignore ((let existing = (get (!_provide_subscribers_ref) (name)) in (sx_dict_set_b !_provide_subscribers_ref name (prim_call "append" [(if sx_truthy (existing) then existing else (List [])); (List [subscriber])]))))) (sx_to_list tracked); Nil))) in (make_cek_value (value) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide-set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let target = (kont_find_provide (rest_k) (name)) in (let old_val = (if sx_truthy (target) then (get (target) ((String "value"))) else (scope_peek (name))) in (let () = ignore ((if sx_truthy (target) then (sx_dict_set_b target (String "value") value) else Nil)) in (let () = ignore ((scope_pop (name))) in (let () = ignore ((scope_push (name) (value))) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [old_val; value])))))) then (fire_provide_subscribers (name)) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_handler_frame ((get (frame) ((String "f")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-return")])) then (let saved_kont = (get (frame) ((String "saved-kont"))) in (make_cek_value (value) ((get (frame) ((String "env")))) (saved_kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "comp-trace")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond-arrow")])) then (let test_value = (get (frame) ((String "match-val"))) in let fenv = (get (frame) ((String "env"))) in (continue_with_call (value) ((List [test_value])) (fenv) ((List [test_value])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "wind-after")])) then (let after_thunk = (get (frame) ((String "after-thunk"))) in let winders_len = (get (frame) ((String "winders-len"))) in let body_result = value in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((if sx_truthy ((prim_call ">" [(len (!_winders_ref)); winders_len])) then (_winders_ref := (rest (!_winders_ref)); Nil) else Nil)) in (continue_with_call (after_thunk) ((List [])) (fenv) ((List [])) ((kont_push ((make_wind_return_frame (body_result) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "wind-return")])) then (make_cek_value ((get (frame) ((String "body-result")))) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-eval")])) then (let condition = value in let fenv = (get (frame) ((String "env"))) in let continuable_p = (get (frame) ((String "scheme"))) in let unwind_result = (kont_unwind_to_handler (rest_k) (condition)) in let handler_fn = (get (unwind_result) ((String "handler"))) in let unwound_k = (get (unwind_result) ((String "kont"))) in (if sx_truthy ((is_nil (handler_fn))) then (let () = ignore ((_last_error_kont_ref := unwound_k; Nil)) in (host_error ((String (sx_str [(String "Unhandled exception: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (fenv) ((List [condition])) ((if sx_truthy (continuable_p) then (kont_push ((make_signal_return_frame (fenv) (unwound_k))) (unwound_k)) else (kont_push ((make_raise_guard_frame (fenv) (unwound_k))) (unwound_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-guard")])) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String "exception handler returned from non-continuable raise")))) else (if sx_truthy ((prim_call "=" [_match_val; (String "multi-map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let new_results = (prim_call "append" [(get (frame) ((String "results"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list remaining)))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list remaining))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list remaining))) in (continue_with_call (f) (heads) (fenv) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) (new_results) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "callcc")])) then (let k = (make_callcc_continuation (rest_k) ((len (!_winders_ref)))) in (continue_with_call (value) ((List [k])) ((get (frame) ((String "env")))) ((List [k])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "vm-resume")])) then (let resume_fn = (get (frame) ((String "f"))) in (let result' = (sx_apply resume_fn (List [value])) in (if sx_truthy ((let _and = (dict_p (result')) in if not (sx_truthy _and) then _and else (get (result') ((String "__vm_suspended"))))) then (make_cek_suspended ((get (result') ((String "request")))) ((get (frame) ((String "env")))) ((kont_push ((make_vm_resume_frame ((get (result') ((String "resume")))) ((get (frame) ((String "env")))))) (rest_k)))) else (make_cek_value (result') ((get (frame) ((String "env")))) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (make_cek_suspended (value) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (let import_set = (get (frame) ((String "args"))) in let remaining_sets = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((bind_import_set (import_set) (fenv))) in (if sx_truthy ((empty_p (remaining_sets))) then (make_cek_value (Nil) (fenv) (rest_k)) else (step_sf_import (remaining_sets) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (let remaining = (get (frame) ((String "remaining"))) in let current_param = (get (frame) ((String "f"))) in let results = (get (frame) ((String "results"))) in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (current_param))) then (let param_obj = value in let val_expr = (nth ((first (remaining))) ((Number 1.0))) in (make_cek_state (val_expr) (fenv) ((kont_push ((make_parameterize_frame (remaining) (param_obj) (results) (body) (fenv))) (rest_k))))) else (let converted_val = value in let new_results = (prim_call "append" [results; (List [(List [(parameter_uid (current_param)); converted_val])])]) in let rest_bindings = (rest (remaining)) in (if sx_truthy ((empty_p (rest_bindings))) then (let body_expr = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((Symbol "begin")) (body))) in let provide_kont = (kont_push_provides (new_results) (fenv) (rest_k)) in (make_cek_state (body_expr) (fenv) (provide_kont))) else (make_cek_state ((first ((first (rest_bindings))))) (fenv) ((kont_push ((make_parameterize_frame (rest_bindings) (Nil) (new_results) (body) (fenv))) (rest_k)))))))) else (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))))))))))))))))))))))) (* continue-with-call *) and continue_with_call f args env raw_args kont = - (if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (let result' = (sx_apply_cek (f) (args)) in (if sx_truthy ((Bool (is_eval_error result'))) then (make_cek_value ((get (result') ((String "message")))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (if sx_truthy ((let _and = (dict_p (result')) in if not (sx_truthy _and) then _and else (get (result') ((String "__vm_suspended"))))) then (make_cek_suspended ((get (result') ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (result') ((String "resume")))) (env))) (kont)))) else (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((jit_skip_p (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (let kont_info = (match kont with List frames | ListRef { contents = frames } -> Printf.sprintf " (kont=%d frames)" (List.length frames) | _ -> "") in raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f)); (String kont_info)]))))))))))) + (if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in let w_len = (callcc_continuation_winders_len (f)) in (let () = ignore ((wind_escape_to (w_len))) in (make_cek_value (arg) (env) (captured)))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (let result' = (sx_apply_cek (f) (args)) in (if sx_truthy ((Bool (is_eval_error result'))) then (make_cek_value ((get (result') ((String "message")))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (if sx_truthy ((let _and = (dict_p (result')) in if not (sx_truthy _and) then _and else (get (result') ((String "__vm_suspended"))))) then (make_cek_suspended ((get (result') ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (result') ((String "resume")))) (env))) (kont)))) else (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((jit_skip_p (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))]))))))))))) (* sf-case-step-loop *) and sf_case_step_loop match_val clauses env kont = @@ -934,6 +953,10 @@ and eval_expr_cek expr env = and trampoline_cek val' = (if sx_truthy ((is_thunk (val'))) then (eval_expr_cek ((thunk_expr (val'))) ((thunk_env (val')))) else val') +(* make-coroutine *) +and make_coroutine thunk = + (CekFrame { cf_type = "coroutine"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) + (* eval-expr *) and eval_expr expr env = (cek_run ((make_cek_state (expr) (env) ((List []))))) @@ -1006,5 +1029,204 @@ let enhance_error_with_trace msg = _last_error_kont_ref := Nil; msg ^ (format_comp_trace trace) +(* Hand-written sf_define_type — skipped from transpile because the spec uses + &rest params and empty-dict literals that the transpiler can't emit cleanly. + Implements: (define-type Name (Ctor1 f1 f2) (Ctor2 f3) ...) + Creates constructor fns, Name?/Ctor? predicates, Ctor-field accessors, + and records ctors in *adt-registry*. *) +let sf_define_type args env_val = + let items = (match args with List l -> l | _ -> []) in + let type_sym = List.nth items 0 in + let type_name = value_to_string type_sym in + let ctor_specs = List.tl items in + let env_has_v k = sx_truthy (env_has env_val (String k)) in + let env_bind_v k v = ignore (env_bind env_val (String k) v) in + let env_get_v k = env_get env_val (String k) in + if not (env_has_v "*adt-registry*") then + env_bind_v "*adt-registry*" (Dict (Hashtbl.create 8)); + let registry = env_get_v "*adt-registry*" in + let ctor_names = List.map (fun spec -> + (match spec with List (sym :: _) -> String (value_to_string sym) | _ -> Nil) + ) ctor_specs in + (match registry with Dict d -> Hashtbl.replace d type_name (List ctor_names) | _ -> ()); + env_bind_v (type_name ^ "?") + (NativeFn (type_name ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> Bool (Hashtbl.mem d "_adt" && + (match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false)) + | _ -> Bool false) + | _ -> Bool false))); + List.iter (fun spec -> + (match spec with + | List (sym :: fields) -> + let cn = value_to_string sym in + let field_names = List.map value_to_string fields in + let arity = List.length fields in + env_bind_v cn + (NativeFn (cn, fun ctor_args -> + if List.length ctor_args <> arity then + raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d" + cn arity (List.length ctor_args))) + else begin + let d = Hashtbl.create 4 in + Hashtbl.replace d "_adt" (Bool true); + Hashtbl.replace d "_type" (String type_name); + Hashtbl.replace d "_ctor" (String cn); + Hashtbl.replace d "_fields" (List ctor_args); + Dict d + end)); + env_bind_v (cn ^ "?") + (NativeFn (cn ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> Bool (Hashtbl.mem d "_adt" && + (match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false)) + | _ -> Bool false) + | _ -> Bool false))); + List.iteri (fun idx fname -> + env_bind_v (cn ^ "-" ^ fname) + (NativeFn (cn ^ "-" ^ fname, fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> + (match Hashtbl.find_opt d "_fields" with + | Some (List fs) -> + if idx < List.length fs then List.nth fs idx + else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds")) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT"))) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict"))) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg"))))) + ) field_names + | _ -> ()) + ) ctor_specs; + Nil + +(* Register define-type via custom_special_forms so the CEK dispatch finds it. + The top-level (register-special-form! ...) in spec/evaluator.sx is not a + define and therefore is not transpiled; we wire it up here instead. *) +let () = ignore (register_special_form (String "define-type") + (NativeFn ("define-type", fun call_args -> + match call_args with + | [args; env] -> sf_define_type args env + | _ -> Nil))) + +(* Multiple values — helpers shared by let-values, define-values *) +let make_values_dict vs = + let d = Hashtbl.create 2 in + Hashtbl.replace d "_values" (Bool true); + Hashtbl.replace d "_list" (List vs); + Dict d + +let values_to_list result = + match result with + | Dict d when (match Hashtbl.find_opt d "_values" with Some (Bool true) -> true | _ -> false) -> + (match Hashtbl.find_opt d "_list" with Some (List l) -> l | _ -> [result]) + | _ -> [result] + +(* (let-values (((a b) expr) ...) body...) *) +let sf_let_values args env_val = + let items = match args with List l -> l | _ -> [] in + let clauses = match List.nth_opt items 0 with Some (List l) -> l | _ -> [] in + let body = if List.length items > 1 then List.tl items else [] in + let local_env = env_extend env_val in + List.iter (fun clause -> + let names = (match clause with List (List ns :: _) -> ns | _ -> []) in + let val_expr = (match clause with List (_ :: e :: _) -> e | _ -> Nil) in + let result = eval_expr val_expr local_env in + let vs = values_to_list result in + List.iteri (fun idx name -> + let n = (match name with Symbol s -> s | String s -> s | _ -> value_to_string name) in + let v = if idx < List.length vs then List.nth vs idx else Nil in + ignore (env_bind local_env (String n) v) + ) names + ) clauses; + let last_val = ref Nil in + List.iter (fun e -> last_val := eval_expr e local_env) body; + !last_val + +(* (define-values (a b ...) expr) *) +let sf_define_values args env_val = + let items = match args with List l -> l | _ -> [] in + let names = (match List.nth_opt items 0 with Some (List l) -> l | _ -> []) in + let val_expr = (match List.nth_opt items 1 with Some e -> e | None -> Nil) in + let result = eval_expr val_expr env_val in + let vs = values_to_list result in + List.iteri (fun idx name -> + let n = (match name with Symbol s -> s | String s -> s | _ -> value_to_string name) in + let v = if idx < List.length vs then List.nth vs idx else Nil in + ignore (env_bind env_val (String n) v) + ) names; + Nil + +let () = ignore (register_special_form (String "let-values") + (NativeFn ("let-values", fun call_args -> + match call_args with + | [args; env] -> sf_let_values args env + | _ -> Nil))) + +let () = ignore (register_special_form (String "define-values") + (NativeFn ("define-values", fun call_args -> + match call_args with + | [args; env] -> sf_define_values args env + | _ -> Nil))) + +(* Phase 9: Promises — delay/force/delay-force/make-promise/promise? *) + +let make_promise_dict ?(iterative=false) thunk = + let d = Hashtbl.create 4 in + Hashtbl.replace d "_promise" (Bool true); + Hashtbl.replace d "forced" (Bool false); + Hashtbl.replace d "thunk" thunk; + Hashtbl.replace d "value" Nil; + if iterative then Hashtbl.replace d "_iterative" (Bool true); + Dict d + +let sf_delay args env_val = + let expr = match args with List (e :: _) -> e | _ -> Nil in + let thunk = make_lambda (List []) expr env_val in + make_promise_dict thunk + +let sf_delay_force args env_val = + let expr = match args with List (e :: _) -> e | _ -> Nil in + let thunk = make_lambda (List []) expr env_val in + make_promise_dict ~iterative:true thunk + +let is_promise v = + match v with + | Dict d -> (match Hashtbl.find_opt d "_promise" with Some (Bool true) -> true | _ -> false) + | _ -> false + +let rec force_promise p = + if not (is_promise p) then p + else match p with + | Dict d -> + (match Hashtbl.find_opt d "forced" with + | Some (Bool true) -> + (match Hashtbl.find_opt d "value" with Some v -> v | None -> Nil) + | _ -> + let thunk = (match Hashtbl.find_opt d "thunk" with Some t -> t | None -> Nil) in + let result = cek_call thunk (List []) in + let iterative = (match Hashtbl.find_opt d "_iterative" with Some (Bool true) -> true | _ -> false) in + let final_val = if iterative && is_promise result then force_promise result else result in + Hashtbl.replace d "forced" (Bool true); + Hashtbl.replace d "value" final_val; + final_val) + | _ -> p + +let () = ignore (register_special_form (String "delay") + (NativeFn ("delay", fun call_args -> + match call_args with + | [args; env] -> sf_delay args env + | _ -> Nil))) + +let () = ignore (register_special_form (String "delay-force") + (NativeFn ("delay-force", fun call_args -> + match call_args with + | [args; env] -> sf_delay_force args env + | _ -> Nil))) diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index bb36af60..99b84ec5 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -46,7 +46,7 @@ let sx_call f args = !Sx_types._cek_eval_lambda_ref f args | Continuation (k, _) -> k (match args with x :: _ -> x | [] -> Nil) - | CallccContinuation _ -> + | CallccContinuation (_, _) -> raise (Eval_error "callcc continuations must be invoked through the CEK machine") | _ -> let nargs = List.length args in @@ -156,6 +156,9 @@ let get_val container key = | "extra" -> f.cf_extra | "extra2" -> f.cf_extra2 | "subscribers" -> f.cf_results | "prev-tracking" -> f.cf_extra + | "after-thunk" -> f.cf_f (* wind-after frame *) + | "winders-len" -> f.cf_extra (* wind-after frame *) + | "body-result" -> f.cf_name (* wind-return frame *) | _ -> Nil) | VmFrame f, String k -> (match k with @@ -208,6 +211,8 @@ let get_val container key = | Dict d, Keyword k -> dict_get d k | (List l | ListRef { contents = l }), Number n -> (try List.nth l (int_of_float n) with _ -> Nil) + | (List l | ListRef { contents = l }), Integer n -> + (try List.nth l n with _ -> Nil) | Nil, _ -> Nil (* nil.anything → nil *) | _, _ -> Nil (* type mismatch → nil (matches JS/Python behavior) *) @@ -381,15 +386,20 @@ let continuation_data v = match v with | _ -> raise (Eval_error "not a continuation") (* Callcc (undelimited) continuation support *) -let callcc_continuation_p v = match v with CallccContinuation _ -> Bool true | _ -> Bool false +let callcc_continuation_p v = match v with CallccContinuation (_, _) -> Bool true | _ -> Bool false -let make_callcc_continuation captured = - CallccContinuation (sx_to_list captured) +let make_callcc_continuation captured winders_len = + let n = match winders_len with Number f -> int_of_float f | Integer n -> n | _ -> 0 in + CallccContinuation (sx_to_list captured, n) let callcc_continuation_data v = match v with - | CallccContinuation frames -> List frames + | CallccContinuation (frames, _) -> List frames | _ -> raise (Eval_error "not a callcc continuation") +let callcc_continuation_winders_len v = match v with + | CallccContinuation (_, n) -> Number (float_of_int n) + | _ -> Number 0.0 + (* Dynamic wind — simplified for OCaml (no async) *) let host_error msg = raise (Eval_error (value_to_str msg)) diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index fe7ee53f..490ce093 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -43,9 +43,10 @@ type env = { and value = | Nil - | Bool of bool - | Number of float - | String of string + | Bool of bool + | Integer of int (** Exact integer — distinct from inexact float. *) + | Number of float (** Inexact float. *) + | String of string | Symbol of string | Keyword of string | List of value list @@ -56,7 +57,7 @@ and value = | Macro of macro | Thunk of value * env | Continuation of (value -> value) * dict option - | CallccContinuation of value list (** Undelimited continuation — captured kont frames *) + | CallccContinuation of value list * int (** Undelimited continuation — captured kont frames + winders depth at capture *) | NativeFn of string * (value list -> value) | Signal of signal | RawHTML of string @@ -72,6 +73,25 @@ and value = | Record of record (** R7RS record — opaque, generative, field-indexed. *) | Parameter of parameter (** R7RS parameter — dynamic binding via kont-stack provide frames. *) | Vector of value array (** R7RS vector — mutable fixed-size array. *) + | StringBuffer of Buffer.t (** Mutable string buffer — O(1) amortized append. *) + | HashTable of (value, value) Hashtbl.t (** Mutable hash table with arbitrary keys. *) + | Char of int (** Unicode codepoint — R7RS char type. *) + | Eof (** EOF sentinel — returned by read-char etc. at end of input. *) + | Port of sx_port (** String port — input (string cursor) or output (buffer). *) + | Rational of int * int (** Exact rational: numerator, denominator (reduced, denom>0). *) + | SxSet of (string, value) Hashtbl.t (** Mutable set keyed by inspect(value). *) + | SxRegexp of string * string * Re.re (** Regexp: source, flags, compiled. *) + | SxBytevector of bytes (** Mutable bytevector — R7RS bytevector type. *) + +(** String input port: source string + mutable cursor position. *) +and sx_port_kind = + | PortInput of string * int ref + | PortOutput of Buffer.t + +and sx_port = { + mutable sp_closed : bool; + sp_kind : sx_port_kind; +} (** CEK machine state — record instead of Dict for performance. 5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *) @@ -392,6 +412,7 @@ let format_number n = let value_to_string = function | String s -> s | Symbol s -> s | Keyword k -> k + | Integer n -> string_of_int n | Number n -> format_number n | Bool true -> "true" | Bool false -> "false" | Nil -> "" | _ -> "" @@ -461,6 +482,7 @@ let make_keyword name = Keyword (value_to_string name) let type_of = function | Nil -> "nil" | Bool _ -> "boolean" + | Integer _ -> "number" | Number _ -> "number" | String _ -> "string" | Symbol _ -> "symbol" @@ -473,7 +495,7 @@ let type_of = function | Macro _ -> "macro" | Thunk _ -> "thunk" | Continuation (_, _) -> "continuation" - | CallccContinuation _ -> "continuation" + | CallccContinuation (_, _) -> "continuation" | NativeFn _ -> "function" | Signal _ -> "signal" | RawHTML _ -> "raw-html" @@ -488,6 +510,16 @@ let type_of = function | Record r -> r.r_type.rt_name | Parameter _ -> "parameter" | Vector _ -> "vector" + | StringBuffer _ -> "string-buffer" + | HashTable _ -> "hash-table" + | Char _ -> "char" + | Eof -> "eof-object" + | Port { sp_kind = PortInput _; _ } -> "input-port" + | Port { sp_kind = PortOutput _; _ } -> "output-port" + | Rational _ -> "rational" + | SxSet _ -> "set" + | SxRegexp _ -> "regexp" + | SxBytevector _ -> "bytevector" let is_nil = function Nil -> true | _ -> false let is_lambda = function Lambda _ -> true | _ -> false @@ -503,7 +535,7 @@ let is_signal = function let is_record = function Record _ -> true | _ -> false let is_callable = function - | Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation _ | VmClosure _ -> true + | Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation (_, _) | VmClosure _ -> true | _ -> false @@ -616,6 +648,7 @@ let thunk_env = function (** {1 Record operations} *) let val_to_int = function + | Integer n -> n | Number n -> int_of_float n | v -> raise (Eval_error ("Expected number, got " ^ type_of v)) @@ -777,6 +810,7 @@ let rec inspect = function | Nil -> "nil" | Bool true -> "true" | Bool false -> "false" + | Integer n -> string_of_int n | Number n -> format_number n | String s -> let buf = Buffer.create (String.length s + 2) in @@ -810,7 +844,7 @@ let rec inspect = function Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params) | Thunk _ -> "" | Continuation (_, _) -> "" - | CallccContinuation _ -> "" + | CallccContinuation (_, _) -> "" | NativeFn (name, _) -> Printf.sprintf "" name | Signal _ -> "" | RawHTML s -> Printf.sprintf "\"\"" (String.length s) @@ -831,3 +865,23 @@ let rec inspect = function Printf.sprintf "#(%s)" (String.concat " " elts) | VmFrame f -> Printf.sprintf "" f.vf_ip f.vf_base | VmMachine m -> Printf.sprintf "" m.vm_sp (List.length m.vm_frames) + | StringBuffer buf -> Printf.sprintf "" (Buffer.length buf) + | HashTable ht -> Printf.sprintf "" (Hashtbl.length ht) + | Char n -> + let name = match n with + | 32 -> "space" | 10 -> "newline" | 9 -> "tab" + | 13 -> "return" | 0 -> "nul" | 27 -> "escape" + | 127 -> "delete" | 8 -> "backspace" + | _ -> let buf = Buffer.create 1 in + Buffer.add_utf_8_uchar buf (Uchar.of_int n); + Buffer.contents buf + in "#\\" ^ name + | Eof -> "#!eof" + | Port { sp_kind = PortInput (_, pos); sp_closed } -> + Printf.sprintf "" !pos (if sp_closed then ":closed" else "") + | Port { sp_kind = PortOutput buf; sp_closed } -> + Printf.sprintf "" (Buffer.length buf) (if sp_closed then ":closed" else "") + | Rational (n, d) -> Printf.sprintf "%d/%d" n d + | SxSet ht -> Printf.sprintf "" (Hashtbl.length ht) + | SxRegexp (src, flags, _) -> Printf.sprintf "#/%s/%s" src flags + | SxBytevector b -> Printf.sprintf "#u8(%s)" (String.concat " " (List.init (Bytes.length b) (fun i -> string_of_int (Char.code (Bytes.get b i))))) diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index 520f8785..bf29e066 100644 --- a/hosts/ocaml/lib/sx_vm.ml +++ b/hosts/ocaml/lib/sx_vm.ml @@ -185,7 +185,8 @@ let code_from_value v = | Some _ as r -> r | None -> Hashtbl.find_opt d k2 in let bc_list = match find2 "bytecode" "vc-bytecode" with | Some (List l | ListRef { contents = l }) -> - Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l) + Array.of_list (List.map (fun x -> match x with + | Integer n -> n | Number n -> int_of_float n | _ -> 0) l) | _ -> [||] in let entries = match find2 "constants" "vc-constants" with @@ -198,10 +199,10 @@ let code_from_value v = | _ -> entry ) entries in let arity = match find2 "arity" "vc-arity" with - | Some (Number n) -> int_of_float n | _ -> 0 + | Some (Integer n) -> n | Some (Number n) -> int_of_float n | _ -> 0 in let rest_arity = match find2 "rest-arity" "vc-rest-arity" with - | Some (Number n) -> int_of_float n | _ -> -1 + | Some (Integer n) -> n | Some (Number n) -> int_of_float n | _ -> -1 in (* Compute locals from bytecode: scan for highest LOCAL_GET/LOCAL_SET slot. The compiler's arity may undercount when nested lets add many locals. *) @@ -749,10 +750,7 @@ and run vm = | _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b]) | 164 (* OP_EQ *) -> let b = pop vm and a = pop vm in - let rec norm = function - | ListRef { contents = l } -> List (List.map norm l) - | List l -> List (List.map norm l) | v -> v in - push vm (Bool (norm a = norm b)) + push vm ((Hashtbl.find Sx_primitives.primitives "=") [a; b]) | 165 (* OP_LT *) -> let b = pop vm and a = pop vm in push vm (match a, b with @@ -771,10 +769,10 @@ and run vm = | 168 (* OP_LEN *) -> let v = pop vm in push vm (match v with - | List l | ListRef { contents = l } -> Number (float_of_int (List.length l)) - | String s -> Number (float_of_int (String.length s)) - | Dict d -> Number (float_of_int (Hashtbl.length d)) - | Nil -> Number 0.0 + | List l | ListRef { contents = l } -> Integer (List.length l) + | String s -> Integer (String.length s) + | Dict d -> Integer (Hashtbl.length d) + | Nil -> Integer 0 | _ -> (Hashtbl.find Sx_primitives.primitives "len") [v]) | 169 (* OP_FIRST *) -> let v = pop vm in diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index 6b44c5a2..d954480b 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -256,6 +256,7 @@ "callcc-continuation?" "callcc-continuation-data" "make-callcc-continuation" + "callcc-continuation-winders-len" "dynamic-wind-call" "strip-prefix" "component-set-param-types!" @@ -295,7 +296,8 @@ "*bind-tracking*" "*provide-batch-depth*" "*provide-batch-queue*" - "*provide-subscribers*")) + "*provide-subscribers*" + "*winders*")) (define ml-is-mutable-global? @@ -533,13 +535,13 @@ "; cf_env = " (ef "env") "; cf_name = " - (if (= frame-type "if") (ef "else") (ef "name")) + (if (= frame-type "if") (ef "else") (cond (some (fn (k) (= k "body-result")) items) (ef "body-result") :else (ef "name"))) "; cf_body = " (if (= frame-type "if") (ef "then") (ef "body")) "; cf_remaining = " (ef "remaining") "; cf_f = " - (ef "f") + (cond (some (fn (k) (= k "after-thunk")) items) (ef "after-thunk") (some (fn (k) (= k "f")) items) (ef "f") :else "Nil") "; cf_args = " (cond (some (fn (k) (= k "evaled")) items) @@ -582,6 +584,8 @@ (ef "prev-tracking") (some (fn (k) (= k "extra")) items) (ef "extra") + (some (fn (k) (= k "winders-len")) items) + (ef "winders-len") :else "Nil") "; cf_extra2 = " (cond diff --git a/lib/apl/test.sh b/lib/apl/test.sh new file mode 100755 index 00000000..a8a967c0 --- /dev/null +++ b/lib/apl/test.sh @@ -0,0 +1,51 @@ +#!/usr/bin/env bash +# lib/apl/test.sh — smoke-test the APL runtime layer. + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found." + exit 1 +fi + +TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT + +cat > "$TMPFILE" << 'EPOCHS' +(epoch 1) +(load "spec/stdlib.sx") +(load "lib/apl/runtime.sx") +(epoch 2) +(load "lib/apl/tests/runtime.sx") +(epoch 3) +(eval "(list apl-test-pass apl-test-fail)") +EPOCHS + +OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) + +LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}') +if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok 3 //; s/\)$//') +fi +if [ -z "$LINE" ]; then + echo "ERROR: could not extract summary" + echo "$OUTPUT" | tail -10 + exit 1 +fi + +P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/') +F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/') +TOTAL=$((P + F)) + +if [ "$F" -eq 0 ]; then + echo "ok $P/$TOTAL lib/apl tests passed" +else + echo "FAIL $P/$TOTAL passed, $F failed" +fi + +[ "$F" -eq 0 ] diff --git a/lib/apl/tests/runtime.sx b/lib/apl/tests/runtime.sx new file mode 100644 index 00000000..8087872d --- /dev/null +++ b/lib/apl/tests/runtime.sx @@ -0,0 +1,327 @@ +;; lib/apl/tests/runtime.sx — Tests for lib/apl/runtime.sx + +;; --- Test framework --- +(define apl-test-pass 0) +(define apl-test-fail 0) +(define apl-test-fails (list)) + +(define + (apl-test name got expected) + (if + (= got expected) + (set! apl-test-pass (+ apl-test-pass 1)) + (begin + (set! apl-test-fail (+ apl-test-fail 1)) + (set! apl-test-fails (append apl-test-fails (list {:got got :expected expected :name name})))))) + +;; --------------------------------------------------------------------------- +;; 1. Core vector constructors +;; --------------------------------------------------------------------------- + +(apl-test + "iota 5" + (apl-iota 5) + (list 1 2 3 4 5)) +(apl-test "iota 1" (apl-iota 1) (list 1)) +(apl-test "iota 0" (apl-iota 0) (list)) +(apl-test + "rho list" + (apl-rho (list 1 2 3)) + 3) +(apl-test "rho scalar" (apl-rho 42) 1) +(apl-test + "at 1" + (apl-at (list 10 20 30) 1) + 10) +(apl-test + "at 3" + (apl-at (list 10 20 30) 3) + 30) + +;; --------------------------------------------------------------------------- +;; 2. Arithmetic — element-wise and rank-polymorphic +;; --------------------------------------------------------------------------- + +(apl-test + "add v+v" + (apl-add + (list 1 2 3) + (list 10 20 30)) + (list 11 22 33)) +(apl-test + "add s+v" + (apl-add 10 (list 1 2 3)) + (list 11 12 13)) +(apl-test + "add v+s" + (apl-add (list 1 2 3) 100) + (list 101 102 103)) +(apl-test "add s+s" (apl-add 3 4) 7) +(apl-test + "sub v-v" + (apl-sub + (list 5 4 3) + (list 1 2 3)) + (list 4 2 0)) +(apl-test + "mul v*s" + (apl-mul (list 1 2 3) 3) + (list 3 6 9)) +(apl-test + "neg -v" + (apl-neg (list 1 -2 3)) + (list -1 2 -3)) +(apl-test + "abs v" + (apl-abs (list -1 2 -3)) + (list 1 2 3)) +(apl-test + "floor v" + (apl-floor (list 1.7 2.2 3.9)) + (list 1 2 3)) +(apl-test + "ceil v" + (apl-ceil (list 1.1 2.5 3)) + (list 2 3 3)) +(apl-test + "max v v" + (apl-max + (list 1 5 3) + (list 4 2 6)) + (list 4 5 6)) +(apl-test + "min v v" + (apl-min + (list 1 5 3) + (list 4 2 6)) + (list 1 2 3)) + +;; --------------------------------------------------------------------------- +;; 3. Comparison (returns 0/1) +;; --------------------------------------------------------------------------- + +(apl-test "eq 3 3" (apl-eq 3 3) 1) +(apl-test "eq 3 4" (apl-eq 3 4) 0) +(apl-test + "gt v>s" + (apl-gt (list 1 5 3 7) 4) + (list 0 1 0 1)) +(apl-test + "lt v=s" + (apl-ge (list 3 4 5) 4) + (list 0 1 1)) +(apl-test + "neq v!=s" + (apl-neq (list 1 2 3) 2) + (list 1 0 1)) + +;; --------------------------------------------------------------------------- +;; 4. Boolean logic (0/1 values) +;; --------------------------------------------------------------------------- + +(apl-test "and 1 1" (apl-and 1 1) 1) +(apl-test "and 1 0" (apl-and 1 0) 0) +(apl-test "or 0 1" (apl-or 0 1) 1) +(apl-test "or 0 0" (apl-or 0 0) 0) +(apl-test "not 0" (apl-not 0) 1) +(apl-test "not 1" (apl-not 1) 0) +(apl-test + "not vec" + (apl-not (list 1 0 1 0)) + (list 0 1 0 1)) + +;; --------------------------------------------------------------------------- +;; 5. Bitwise operations +;; --------------------------------------------------------------------------- + +(apl-test "bitand s" (apl-bitand 5 3) 1) +(apl-test "bitor s" (apl-bitor 5 3) 7) +(apl-test "bitxor s" (apl-bitxor 5 3) 6) +(apl-test "bitnot 0" (apl-bitnot 0) -1) +(apl-test "lshift 1 4" (apl-lshift 1 4) 16) +(apl-test "rshift 16 2" (apl-rshift 16 2) 4) +(apl-test + "bitand vec" + (apl-bitand (list 5 6) (list 3 7)) + (list 1 6)) +(apl-test + "bitor vec" + (apl-bitor (list 5 6) (list 3 7)) + (list 7 7)) + +;; --------------------------------------------------------------------------- +;; 6. Reduction and scan +;; --------------------------------------------------------------------------- + +(apl-test + "reduce-add" + (apl-reduce-add + (list 1 2 3 4 5)) + 15) +(apl-test + "reduce-mul" + (apl-reduce-mul (list 1 2 3 4)) + 24) +(apl-test + "reduce-max" + (apl-reduce-max + (list 3 1 4 1 5)) + 5) +(apl-test + "reduce-min" + (apl-reduce-min + (list 3 1 4 1 5)) + 1) +(apl-test + "reduce-and" + (apl-reduce-and (list 1 1 1)) + 1) +(apl-test + "reduce-and0" + (apl-reduce-and (list 1 0 1)) + 0) +(apl-test + "reduce-or" + (apl-reduce-or (list 0 1 0)) + 1) +(apl-test + "scan-add" + (apl-scan-add (list 1 2 3 4)) + (list 1 3 6 10)) +(apl-test + "scan-mul" + (apl-scan-mul (list 1 2 3 4)) + (list 1 2 6 24)) + +;; --------------------------------------------------------------------------- +;; 7. Vector manipulation +;; --------------------------------------------------------------------------- + +(apl-test + "reverse" + (apl-reverse (list 1 2 3 4)) + (list 4 3 2 1)) +(apl-test + "cat v v" + (apl-cat (list 1 2) (list 3 4)) + (list 1 2 3 4)) +(apl-test + "cat v s" + (apl-cat (list 1 2) 3) + (list 1 2 3)) +(apl-test + "cat s v" + (apl-cat 1 (list 2 3)) + (list 1 2 3)) +(apl-test + "cat s s" + (apl-cat 1 2) + (list 1 2)) +(apl-test + "take 3" + (apl-take + 3 + (list 10 20 30 40 50)) + (list 10 20 30)) +(apl-test + "take 0" + (apl-take 0 (list 1 2 3)) + (list)) +(apl-test + "take neg" + (apl-take -2 (list 10 20 30)) + (list 20 30)) +(apl-test + "drop 2" + (apl-drop 2 (list 10 20 30 40)) + (list 30 40)) +(apl-test + "drop neg" + (apl-drop -1 (list 10 20 30)) + (list 10 20)) +(apl-test + "rotate 2" + (apl-rotate + 2 + (list 1 2 3 4 5)) + (list 3 4 5 1 2)) +(apl-test + "compress" + (apl-compress + (list 1 0 1 0) + (list 10 20 30 40)) + (list 10 30)) +(apl-test + "index" + (apl-index + (list 10 20 30 40) + (list 2 4)) + (list 20 40)) + +;; --------------------------------------------------------------------------- +;; 8. Set operations +;; --------------------------------------------------------------------------- + +(apl-test + "member yes" + (apl-member + (list 1 2 5) + (list 2 4 6)) + (list 0 1 0)) +(apl-test + "member s" + (apl-member 2 (list 1 2 3)) + 1) +(apl-test + "member no" + (apl-member 9 (list 1 2 3)) + 0) +(apl-test + "nub" + (apl-nub (list 1 2 1 3 2)) + (list 1 2 3)) +(apl-test + "union" + (apl-union + (list 1 2 3) + (list 2 3 4)) + (list 1 2 3 4)) +(apl-test + "intersect" + (apl-intersect + (list 1 2 3 4) + (list 2 4 6)) + (list 2 4)) +(apl-test + "without" + (apl-without + (list 1 2 3 4) + (list 2 4)) + (list 1 3)) + +;; --------------------------------------------------------------------------- +;; 9. Format +;; --------------------------------------------------------------------------- + +(apl-test + "format vec" + (apl-format (list 1 2 3)) + "1 2 3") +(apl-test "format scalar" (apl-format 42) "42") +(apl-test "format empty" (apl-format (list)) "") + +;; --------------------------------------------------------------------------- +;; Summary +;; --------------------------------------------------------------------------- + +(list apl-test-pass apl-test-fail) diff --git a/lib/common-lisp/clos.sx b/lib/common-lisp/clos.sx new file mode 100644 index 00000000..78381ba2 --- /dev/null +++ b/lib/common-lisp/clos.sx @@ -0,0 +1,500 @@ +;; lib/common-lisp/clos.sx — CLOS: classes, instances, generic functions +;; +;; Class records: {:clos-type "class" :name "NAME" :slots {...} :parents [...] :methods [...]} +;; Instance: {:clos-type "instance" :class "NAME" :slots {slot: val ...}} +;; Method: {:qualifiers [...] :specializers [...] :fn (fn (args next-fn) ...)} +;; +;; SX primitive notes: +;; dict->list: use (map (fn (k) (list k (get d k))) (keys d)) +;; dict-set (pure): use assoc +;; fn?/callable?: use callable? + +;; ── dict helpers ─────────────────────────────────────────────────────────── + +(define + clos-dict->list + (fn (d) (map (fn (k) (list k (get d k))) (keys d)))) + +;; ── class registry ───────────────────────────────────────────────────────── + +(define + clos-class-registry + (dict + "t" + {:parents (list) :clos-type "class" :slots (dict) :methods (list) :name "t"} + "null" + {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "null"} + "integer" + {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "integer"} + "float" + {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "float"} + "string" + {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "string"} + "symbol" + {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "symbol"} + "cons" + {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "cons"} + "list" + {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "list"})) + +;; ── clos-generic-registry ───────────────────────────────────────────────── + +(define clos-generic-registry (dict)) + +;; ── class-of ────────────────────────────────────────────────────────────── + +(define + clos-class-of + (fn + (x) + (cond + ((nil? x) "null") + ((integer? x) "integer") + ((float? x) "float") + ((string? x) "string") + ((symbol? x) "symbol") + ((and (list? x) (> (len x) 0)) "cons") + ((and (list? x) (= (len x) 0)) "null") + ((and (dict? x) (= (get x "clos-type") "instance")) (get x "class")) + (:else "t")))) + +;; ── subclass-of? ────────────────────────────────────────────────────────── +;; +;; Captures clos-class-registry at define time to avoid free-variable issues. + +(define + clos-subclass-of? + (let + ((registry clos-class-registry)) + (fn + (class-name super-name) + (if + (= class-name super-name) + true + (let + ((rec (get registry class-name))) + (if + (nil? rec) + false + (some + (fn (p) (clos-subclass-of? p super-name)) + (get rec "parents")))))))) + +;; ── instance-of? ────────────────────────────────────────────────────────── + +(define + clos-instance-of? + (fn (obj class-name) (clos-subclass-of? (clos-class-of obj) class-name))) + +;; ── defclass ────────────────────────────────────────────────────────────── +;; +;; slot-specs: list of dicts with keys: name initarg initform accessor reader writer +;; Each missing key defaults to nil. + +(define clos-slot-spec (fn (spec) (if (string? spec) {:initform nil :initarg nil :reader nil :writer nil :accessor nil :name spec} spec))) + +(define + clos-defclass + (fn + (name parents slot-specs) + (let + ((slots (dict))) + (for-each + (fn + (pname) + (let + ((prec (get clos-class-registry pname))) + (when + (not (nil? prec)) + (for-each + (fn + (k) + (when + (nil? (get slots k)) + (dict-set! slots k (get (get prec "slots") k)))) + (keys (get prec "slots")))))) + parents) + (for-each + (fn + (s) + (let + ((spec (clos-slot-spec s))) + (dict-set! slots (get spec "name") spec))) + slot-specs) + (let + ((class-rec {:parents parents :clos-type "class" :slots slots :methods (list) :name name})) + (dict-set! clos-class-registry name class-rec) + (clos-install-accessors-for name slots) + name)))) + +;; ── accessor installation (forward-declared, defined after defmethod) ────── + +(define + clos-install-accessors-for + (fn + (class-name slots) + (for-each + (fn + (k) + (let + ((spec (get slots k))) + (let + ((reader (get spec "reader"))) + (when + (not (nil? reader)) + (clos-add-reader-method reader class-name k))) + (let + ((accessor (get spec "accessor"))) + (when + (not (nil? accessor)) + (clos-add-reader-method accessor class-name k))))) + (keys slots)))) + +;; placeholder — real impl filled in after defmethod is defined +(define clos-add-reader-method (fn (method-name class-name slot-name) nil)) + +;; ── make-instance ───────────────────────────────────────────────────────── + +(define + clos-make-instance + (fn + (class-name &rest initargs) + (let + ((class-rec (get clos-class-registry class-name))) + (if + (nil? class-rec) + (error (str "No class named: " class-name)) + (let + ((slots (dict))) + (for-each + (fn + (k) + (let + ((spec (get (get class-rec "slots") k))) + (let + ((initform (get spec "initform"))) + (when + (not (nil? initform)) + (dict-set! + slots + k + (if (callable? initform) (initform) initform)))))) + (keys (get class-rec "slots"))) + (define + apply-args + (fn + (args) + (when + (>= (len args) 2) + (let + ((key (str (first args))) (val (first (rest args)))) + (let + ((skey (if (= (slice key 0 1) ":") (slice key 1 (len key)) key))) + (let + ((matched false)) + (for-each + (fn + (sk) + (let + ((spec (get (get class-rec "slots") sk))) + (let + ((ia (get spec "initarg"))) + (when + (or + (= ia key) + (= ia (str ":" skey)) + (= sk skey)) + (dict-set! slots sk val) + (set! matched true))))) + (keys (get class-rec "slots"))))) + (apply-args (rest (rest args))))))) + (apply-args initargs) + {:clos-type "instance" :slots slots :class class-name}))))) + +;; ── slot-value ──────────────────────────────────────────────────────────── + +(define + clos-slot-value + (fn + (instance slot-name) + (if + (and (dict? instance) (= (get instance "clos-type") "instance")) + (get (get instance "slots") slot-name) + (error (str "Not a CLOS instance: " (inspect instance)))))) + +(define + clos-set-slot-value! + (fn + (instance slot-name value) + (if + (and (dict? instance) (= (get instance "clos-type") "instance")) + (dict-set! (get instance "slots") slot-name value) + (error (str "Not a CLOS instance: " (inspect instance)))))) + +(define + clos-slot-boundp + (fn + (instance slot-name) + (and + (dict? instance) + (= (get instance "clos-type") "instance") + (not (nil? (get (get instance "slots") slot-name)))))) + +;; ── find-class / change-class ───────────────────────────────────────────── + +(define clos-find-class (fn (name) (get clos-class-registry name))) + +(define + clos-change-class! + (fn + (instance new-class-name) + (if + (and (dict? instance) (= (get instance "clos-type") "instance")) + (dict-set! instance "class" new-class-name) + (error (str "Not a CLOS instance: " (inspect instance)))))) + +;; ── defgeneric ──────────────────────────────────────────────────────────── + +(define + clos-defgeneric + (fn + (name options) + (let + ((combination (or (get options "method-combination") "standard"))) + (when + (nil? (get clos-generic-registry name)) + (dict-set! clos-generic-registry name {:methods (list) :combination combination :name name})) + name))) + +;; ── defmethod ───────────────────────────────────────────────────────────── +;; +;; method-fn: (fn (args next-fn) body) +;; args = list of all call arguments +;; next-fn = (fn () next-method-result) or nil + +(define + clos-defmethod + (fn + (generic-name qualifiers specializers method-fn) + (when + (nil? (get clos-generic-registry generic-name)) + (clos-defgeneric generic-name {})) + (let + ((grec (get clos-generic-registry generic-name)) + (new-method {:fn method-fn :qualifiers qualifiers :specializers specializers})) + (let + ((kept (filter (fn (m) (not (and (= (get m "qualifiers") qualifiers) (= (get m "specializers") specializers)))) (get grec "methods")))) + (dict-set! + clos-generic-registry + generic-name + (assoc grec "methods" (append kept (list new-method)))) + generic-name)))) + +;; Now install the real accessor-method installer +(set! + clos-add-reader-method + (fn + (method-name class-name slot-name) + (clos-defmethod + method-name + (list) + (list class-name) + (fn (args next-fn) (clos-slot-value (first args) slot-name))))) + +;; ── method specificity ───────────────────────────────────────────────────── + +(define + clos-method-matches? + (fn + (method args) + (let + ((specs (get method "specializers"))) + (if + (> (len specs) (len args)) + false + (define + check-all + (fn + (i) + (if + (>= i (len specs)) + true + (let + ((spec (nth specs i)) (arg (nth args i))) + (if + (= spec "t") + (check-all (+ i 1)) + (if + (clos-instance-of? arg spec) + (check-all (+ i 1)) + false)))))) + (check-all 0))))) + +;; Precedence distance: how far class-name is from spec-name up the hierarchy. +(define + clos-specificity + (let + ((registry clos-class-registry)) + (fn + (class-name spec-name) + (define + walk + (fn + (cn depth) + (if + (= cn spec-name) + depth + (let + ((rec (get registry cn))) + (if + (nil? rec) + nil + (let + ((results (map (fn (p) (walk p (+ depth 1))) (get rec "parents")))) + (let + ((non-nil (filter (fn (x) (not (nil? x))) results))) + (if + (empty? non-nil) + nil + (reduce + (fn (a b) (if (< a b) a b)) + (first non-nil) + (rest non-nil)))))))))) + (walk class-name 0)))) + +(define + clos-method-more-specific? + (fn + (m1 m2 args) + (let + ((s1 (get m1 "specializers")) (s2 (get m2 "specializers"))) + (define + cmp + (fn + (i) + (if + (>= i (len s1)) + false + (let + ((c1 (clos-specificity (clos-class-of (nth args i)) (nth s1 i))) + (c2 + (clos-specificity (clos-class-of (nth args i)) (nth s2 i)))) + (cond + ((and (nil? c1) (nil? c2)) (cmp (+ i 1))) + ((nil? c1) false) + ((nil? c2) true) + ((< c1 c2) true) + ((> c1 c2) false) + (:else (cmp (+ i 1)))))))) + (cmp 0)))) + +(define + clos-sort-methods + (fn + (methods args) + (define + insert + (fn + (m sorted) + (if + (empty? sorted) + (list m) + (if + (clos-method-more-specific? m (first sorted) args) + (cons m sorted) + (cons (first sorted) (insert m (rest sorted))))))) + (reduce (fn (acc m) (insert m acc)) (list) methods))) + +;; ── call-generic (standard method combination) ───────────────────────────── + +(define + clos-call-generic + (fn + (generic-name args) + (let + ((grec (get clos-generic-registry generic-name))) + (if + (nil? grec) + (error (str "No generic function: " generic-name)) + (let + ((applicable (filter (fn (m) (clos-method-matches? m args)) (get grec "methods")))) + (if + (empty? applicable) + (error + (str + "No applicable method for " + generic-name + " with classes " + (inspect (map clos-class-of args)))) + (let + ((primary (filter (fn (m) (empty? (get m "qualifiers"))) applicable)) + (before + (filter + (fn (m) (= (get m "qualifiers") (list "before"))) + applicable)) + (after + (filter + (fn (m) (= (get m "qualifiers") (list "after"))) + applicable)) + (around + (filter + (fn (m) (= (get m "qualifiers") (list "around"))) + applicable))) + (let + ((sp (clos-sort-methods primary args)) + (sb (clos-sort-methods before args)) + (sa (clos-sort-methods after args)) + (sw (clos-sort-methods around args))) + (define + make-primary-chain + (fn + (methods) + (if + (empty? methods) + (fn + () + (error (str "No next primary method: " generic-name))) + (fn + () + ((get (first methods) "fn") + args + (make-primary-chain (rest methods))))))) + (define + make-around-chain + (fn + (around-methods inner-thunk) + (if + (empty? around-methods) + inner-thunk + (fn + () + ((get (first around-methods) "fn") + args + (make-around-chain + (rest around-methods) + inner-thunk)))))) + (for-each (fn (m) ((get m "fn") args (fn () nil))) sb) + (let + ((primary-thunk (make-primary-chain sp))) + (let + ((result (if (empty? sw) (primary-thunk) ((make-around-chain sw primary-thunk))))) + (for-each + (fn (m) ((get m "fn") args (fn () nil))) + (reverse sa)) + result)))))))))) + +;; ── call-next-method / next-method-p ────────────────────────────────────── + +(define clos-call-next-method (fn (next-fn) (next-fn))) + +(define clos-next-method-p (fn (next-fn) (not (nil? next-fn)))) + +;; ── with-slots ──────────────────────────────────────────────────────────── + +(define + clos-with-slots + (fn + (instance slot-names body-fn) + (let + ((vals (map (fn (s) (clos-slot-value instance s)) slot-names))) + (apply body-fn vals)))) \ No newline at end of file diff --git a/lib/common-lisp/conformance.sh b/lib/common-lisp/conformance.sh new file mode 100755 index 00000000..30e30664 --- /dev/null +++ b/lib/common-lisp/conformance.sh @@ -0,0 +1,161 @@ +#!/usr/bin/env bash +# lib/common-lisp/conformance.sh — CL-on-SX conformance test runner +# +# Runs all Common Lisp test suites and writes scoreboard.json + scoreboard.md. +# +# Usage: +# bash lib/common-lisp/conformance.sh +# bash lib/common-lisp/conformance.sh -v + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found." + exit 1 +fi + +VERBOSE="${1:-}" +TOTAL_PASS=0; TOTAL_FAIL=0 +SUITE_NAMES=() +SUITE_PASS=() +SUITE_FAIL=() + +# run_suite NAME "file1 file2 ..." PASS_VAR FAIL_VAR FAILURES_VAR +run_suite() { + local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5" + local TMP; TMP=$(mktemp) + { + printf '(epoch 1)\n(load "spec/stdlib.sx")\n' + local i=2 + for f in $load_files; do + printf '(epoch %d)\n(load "%s")\n' "$i" "$f" + i=$((i+1)) + done + printf '(epoch 100)\n(eval "%s")\n' "$pass_var" + printf '(epoch 101)\n(eval "%s")\n' "$fail_var" + } > "$TMP" + local OUT; OUT=$(timeout 30 "$SX_SERVER" < "$TMP" 2>/dev/null) + rm -f "$TMP" + local P F + P=$(echo "$OUT" | grep -A1 "^(ok-len 100 " | tail -1 | tr -d ' ()' || true) + F=$(echo "$OUT" | grep -A1 "^(ok-len 101 " | tail -1 | tr -d ' ()' || true) + # Also try plain (ok 100 N) format + [ -z "$P" ] && P=$(echo "$OUT" | grep "^(ok 100 " | awk '{print $3}' | tr -d ')' || true) + [ -z "$F" ] && F=$(echo "$OUT" | grep "^(ok 101 " | awk '{print $3}' | tr -d ')' || true) + [ -z "$P" ] && P=0; [ -z "$F" ] && F=0 + SUITE_NAMES+=("$name") + SUITE_PASS+=("$P") + SUITE_FAIL+=("$F") + TOTAL_PASS=$((TOTAL_PASS + P)) + TOTAL_FAIL=$((TOTAL_FAIL + F)) + if [ "$F" = "0" ] && [ "${P:-0}" -gt 0 ] 2>/dev/null; then + echo " PASS $name ($P tests)" + else + echo " FAIL $name ($P passed, $F failed)" + fi +} + +echo "=== Common Lisp on SX — Conformance Run ===" +echo "" + +run_suite "Phase 1: tokenizer/reader" \ + "lib/common-lisp/reader.sx lib/common-lisp/tests/read.sx" \ + "cl-test-pass" "cl-test-fail" "cl-test-fails" + +run_suite "Phase 1: parser/lambda-lists" \ + "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/tests/lambda.sx" \ + "cl-test-pass" "cl-test-fail" "cl-test-fails" + +run_suite "Phase 2: evaluator" \ + "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/eval.sx" \ + "cl-test-pass" "cl-test-fail" "cl-test-fails" + +run_suite "Phase 3: condition system" \ + "lib/common-lisp/runtime.sx lib/common-lisp/tests/conditions.sx" \ + "passed" "failed" "failures" + +run_suite "Phase 3: restart-demo" \ + "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/restart-demo.sx" \ + "demo-passed" "demo-failed" "demo-failures" + +run_suite "Phase 3: parse-recover" \ + "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/parse-recover.sx" \ + "parse-passed" "parse-failed" "parse-failures" + +run_suite "Phase 3: interactive-debugger" \ + "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/interactive-debugger.sx" \ + "debugger-passed" "debugger-failed" "debugger-failures" + +run_suite "Phase 4: CLOS" \ + "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/clos.sx" \ + "passed" "failed" "failures" + +run_suite "Phase 4: geometry" \ + "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/geometry.sx" \ + "geo-passed" "geo-failed" "geo-failures" + +run_suite "Phase 4: mop-trace" \ + "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/mop-trace.sx" \ + "mop-passed" "mop-failed" "mop-failures" + +run_suite "Phase 5: macros+LOOP" \ + "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx lib/common-lisp/tests/macros.sx" \ + "macro-passed" "macro-failed" "macro-failures" + +run_suite "Phase 6: stdlib" \ + "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/stdlib.sx" \ + "stdlib-passed" "stdlib-failed" "stdlib-failures" + +echo "" +echo "=== Total: $TOTAL_PASS passed, $TOTAL_FAIL failed ===" + +# ── write scoreboard.json ───────────────────────────────────────────────── + +SCORE_DIR="lib/common-lisp" +JSON="$SCORE_DIR/scoreboard.json" +{ + printf '{\n' + printf ' "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)" + printf ' "total_pass": %d,\n' "$TOTAL_PASS" + printf ' "total_fail": %d,\n' "$TOTAL_FAIL" + printf ' "suites": [\n' + first=true + for i in "${!SUITE_NAMES[@]}"; do + if [ "$first" = "true" ]; then first=false; else printf ',\n'; fi + printf ' {"name": "%s", "pass": %d, "fail": %d}' \ + "${SUITE_NAMES[$i]}" "${SUITE_PASS[$i]}" "${SUITE_FAIL[$i]}" + done + printf '\n ]\n' + printf '}\n' +} > "$JSON" + +# ── write scoreboard.md ─────────────────────────────────────────────────── + +MD="$SCORE_DIR/scoreboard.md" +{ + printf '# Common Lisp on SX — Scoreboard\n\n' + printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')" + printf '| Suite | Pass | Fail | Status |\n' + printf '|-------|------|------|--------|\n' + for i in "${!SUITE_NAMES[@]}"; do + p="${SUITE_PASS[$i]}" f="${SUITE_FAIL[$i]}" + status="" + if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then + status="pass" + else + status="FAIL" + fi + printf '| %s | %s | %s | %s |\n' "${SUITE_NAMES[$i]}" "$p" "$f" "$status" + done + printf '\n**Total: %d passed, %d failed**\n' "$TOTAL_PASS" "$TOTAL_FAIL" +} > "$MD" + +echo "" +echo "Scoreboard written to $JSON and $MD" + +[ "$TOTAL_FAIL" -eq 0 ] diff --git a/lib/common-lisp/eval.sx b/lib/common-lisp/eval.sx new file mode 100644 index 00000000..1947bc4a --- /dev/null +++ b/lib/common-lisp/eval.sx @@ -0,0 +1,1391 @@ +;; Common Lisp evaluator — evaluates CL AST forms. +;; +;; Depends on: lib/common-lisp/reader.sx, lib/common-lisp/parser.sx +;; +;; Environment: +;; {:vars {"NAME" val ...} :fns {"NAME" cl-fn ...}} +;; CL function: +;; {:cl-type "function" :params ll :body forms :env env} +;; +;; Public API: +;; (cl-make-env) — create empty environment +;; (cl-eval form env) — evaluate one CL AST form +;; (cl-eval-str src env) — read+eval a CL source string +;; (cl-eval-all-str src env) — read-all+eval-each, return last +;; cl-global-env — global mutable environment + +;; ── environment ────────────────────────────────────────────────── + +(define cl-make-env (fn () {:vars {} :fns {}})) + +(define cl-global-env (cl-make-env)) + +;; ── package state ───────────────────────────────────────────────── +(define cl-packages {}) +(define cl-current-package "COMMON-LISP-USER") +(define cl-reader-macros {}) +(define cl-dispatch-macros {}) +(define cl-package-sep? + (fn (s) + (let ((colon (some (fn (i) (if (= (substr s i 1) ":") i false)) + (range 0 (len s))))) + (if colon + (let ((pkg (substr s 0 colon)) + (rest2 (if (and (< (+ colon 1) (len s)) + (= (substr s (+ colon 1) 1) ":")) + (substr s (+ colon 2) (- (len s) (+ colon 2))) + (substr s (+ colon 1) (- (len s) (+ colon 1)))))) + {:pkg pkg :name rest2}) + nil)))) + +;; ── macro registry ──────────────────────────────────────────────── +;; cl-macro-registry: symbol-name -> (fn (form env) expanded-form) +(define cl-macro-registry (dict)) + +;; Gensym counter (eval-time, distinct from runtime.sx cl-gensym) +(define cl-gensym-counter 0) +(define cl-eval-gensym + (fn (prefix) + (do + (set! cl-gensym-counter (+ cl-gensym-counter 1)) + (str (if (nil? prefix) "G" prefix) cl-gensym-counter)))) + + +(define cl-env-get-var (fn (env name) (get (get env "vars") name))) +(define cl-env-has-var? (fn (env name) (has-key? (get env "vars") name))) +(define cl-env-get-fn (fn (env name) (get (get env "fns") name))) +(define cl-env-has-fn? (fn (env name) (has-key? (get env "fns") name))) + +(define cl-env-bind-var + (fn (env name value) + {:vars (assoc (get env "vars") name value) + :fns (get env "fns")})) + +(define cl-env-bind-fn + (fn (env name fn-obj) + {:vars (get env "vars") + :fns (assoc (get env "fns") name fn-obj)})) + +;; ── body evaluation ─────────────────────────────────────────────── + +(define cl-block-return? + (fn (v) (and (dict? v) (= (get v "cl-type") "block-return")))) + +(define cl-go-tag? + (fn (v) (and (dict? v) (= (get v "cl-type") "go-tag")))) + +(define cl-mv? + (fn (v) (and (dict? v) (= (get v "cl-type") "mv")))) + +(define cl-mv-primary + (fn (v) + (if (cl-mv? v) + (if (> (len (get v "vals")) 0) (nth (get v "vals") 0) nil) + v))) + +(define cl-mv-vals + (fn (v) (if (cl-mv? v) (get v "vals") (list v)))) + +(define cl-eval-body + (fn (forms env) + (cond + ((= (len forms) 0) nil) + ((= (len forms) 1) (cl-eval (nth forms 0) env)) + (:else + (let ((result (cl-eval (nth forms 0) env))) + (if (or (cl-block-return? result) (cl-go-tag? result)) + result + (cl-eval-body (rest forms) env))))))) + +;; ── lambda-list binding helpers ─────────────────────────────────── + +(define cl-bind-required + (fn (names args env) + (if (= (len names) 0) + env + (cl-bind-required + (rest names) + (if (> (len args) 0) (rest args) args) + (cl-env-bind-var env + (nth names 0) + (if (> (len args) 0) (nth args 0) nil)))))) + +;; returns {:env e :rest remaining-args} +(define cl-bind-optional + (fn (opts args env) + (if (= (len opts) 0) + {:env env :rest args} + (let ((spec (nth opts 0)) + (has-val (> (len args) 0))) + (let ((val (if has-val (nth args 0) nil)) + (rem (if has-val (rest args) args))) + (let ((e1 (cl-env-bind-var env (get spec "name") + (if has-val val + (if (get spec "default") + (cl-eval (get spec "default") env) nil))))) + (let ((e2 (if (get spec "supplied") + (cl-env-bind-var e1 (get spec "supplied") has-val) + e1))) + (cl-bind-optional (rest opts) rem e2)))))))) + +;; returns {:found bool :value v} +(define cl-find-kw-arg + (fn (kw args i) + (if (>= i (len args)) + {:found false :value nil} + (let ((a (nth args i))) + (if (and (dict? a) + (= (get a "cl-type") "keyword") + (= (get a "name") kw)) + {:found true + :value (if (< (+ i 1) (len args)) (nth args (+ i 1)) nil)} + (cl-find-kw-arg kw args (+ i 2))))))) + +(define cl-bind-key + (fn (key-specs all-args env) + (if (= (len key-specs) 0) + env + (let ((spec (nth key-specs 0)) + (r (cl-find-kw-arg (get (nth key-specs 0) "keyword") all-args 0))) + (let ((found (get r "found")) + (kval (get r "value"))) + (let ((e1 (cl-env-bind-var env (get spec "name") + (if found kval + (if (get spec "default") + (cl-eval (get spec "default") env) nil))))) + (let ((e2 (if (get spec "supplied") + (cl-env-bind-var e1 (get spec "supplied") found) + e1))) + (cl-bind-key (rest key-specs) all-args e2)))))))) + +(define cl-bind-aux + (fn (aux-specs env) + (if (= (len aux-specs) 0) + env + (let ((spec (nth aux-specs 0))) + (cl-bind-aux + (rest aux-specs) + (cl-env-bind-var env (get spec "name") + (if (get spec "init") (cl-eval (get spec "init") env) nil))))))) + +;; ── function creation ───────────────────────────────────────────── + +;; ll-and-body: (list lambda-list-form body-form ...) +(define cl-make-lambda + (fn (ll-and-body env) + {:cl-type "function" + :params (cl-parse-lambda-list (nth ll-and-body 0)) + :body (rest ll-and-body) + :env env})) + +;; ── function application ────────────────────────────────────────── + +(define cl-apply + (fn (fn-obj args) + (cond + ((and (dict? fn-obj) (has-key? fn-obj "builtin-fn")) + ((get fn-obj "builtin-fn") args)) + ((or (not (dict? fn-obj)) (not (= (get fn-obj "cl-type") "function"))) + {:cl-type "error" :message "Not a function"}) + (:else + (let ((params (get fn-obj "params")) + (body (get fn-obj "body")) + (cenv (get fn-obj "env"))) + (let ((req (get params "required")) + (opt (get params "optional")) + (rest-name (get params "rest")) + (key-specs (get params "key")) + (aux-specs (get params "aux"))) + (let ((e1 (cl-bind-required req args cenv))) + (let ((opt-r (cl-bind-optional + opt (slice args (len req) (len args)) e1))) + (let ((e2 (get opt-r "env")) + (rem (get opt-r "rest"))) + (let ((e3 (if rest-name + (cl-env-bind-var e2 rest-name rem) + e2))) + (let ((e4 (cl-bind-key key-specs args e3))) + (let ((e5 (cl-bind-aux aux-specs e4))) + (cl-eval-body body e5))))))))))))) + + +;; ── FORMAT helpers ────────────────────────────────────────────── + +(define cl-fmt-a + (fn (arg) + (cond + ((= arg nil) "()") + ((= arg true) "T") + ((= arg false) "NIL") + ((string? arg) arg) + ((number? arg) (str arg)) + ((list? arg) + (if (= (len arg) 0) "()" + (str "(" + (reduce (fn (a x) (str a " " (cl-fmt-a x))) + (cl-fmt-a (nth arg 0)) + (rest arg)) + ")"))) + ((and (dict? arg) (= (get arg "cl-type") "keyword")) + (str ":" (get arg "name"))) + ((and (dict? arg) (= (get arg "cl-type") "char")) + (get arg "value")) + (:else (str arg))))) + +(define cl-fmt-s + (fn (arg) + (cond + ((= arg nil) "NIL") + ((= arg true) "T") + ((= arg false) "NIL") + ((string? arg) (str "\"" arg "\"")) + ((number? arg) (str arg)) + ((list? arg) + (if (= (len arg) 0) "NIL" + (str "(" + (reduce (fn (a x) (str a " " (cl-fmt-s x))) + (cl-fmt-s (nth arg 0)) + (rest arg)) + ")"))) + ((and (dict? arg) (= (get arg "cl-type") "keyword")) + (str ":" (get arg "name"))) + ((and (dict? arg) (= (get arg "cl-type") "char")) + (str "#\\" (get arg "value"))) + (:else (str arg))))) + +;; Find position of ~CH (tilde+ch) in ctrl, starting from i, tracking nesting +(define cl-fmt-find-close + (fn (ctrl ch i depth) + (if (>= i (- (len ctrl) 1)) -1 + (let ((c (substr ctrl i 1))) + (if (= c "~") + (let ((nxt (upcase (substr ctrl (+ i 1) 1)))) + (cond + ((= nxt ch) + (if (= depth 0) i (cl-fmt-find-close ctrl ch (+ i 2) (- depth 1)))) + ((or (= nxt "{") (= nxt "[")) + (cl-fmt-find-close ctrl ch (+ i 2) (+ depth 1))) + (:else + (cl-fmt-find-close ctrl ch (+ i 2) depth)))) + (cl-fmt-find-close ctrl ch (+ i 1) depth)))))) + +;; Process inner ~{...~} string over each element of a list +(define cl-fmt-iterate + (fn (inner items) + (if (= items nil) "" + (if (= (len items) 0) "" + (reduce + (fn (acc x) + (str acc (get (cl-fmt-loop inner (list x) 0 "") "out"))) + "" items))))) + +;; Main format loop: returns {:out string :args remaining} +(define cl-fmt-loop + (fn (ctrl args i out) + (if (>= i (len ctrl)) + {:out out :args args} + (let ((ch (substr ctrl i 1))) + (if (not (= ch "~")) + (cl-fmt-loop ctrl args (+ i 1) (str out ch)) + (let ((dir (if (< (+ i 1) (len ctrl)) + (upcase (substr ctrl (+ i 1) 1)) + ""))) + (cond + ((= dir "A") + (cl-fmt-loop ctrl (rest args) (+ i 2) + (str out (if (> (len args) 0) (cl-fmt-a (nth args 0)) "")))) + ((= dir "S") + (cl-fmt-loop ctrl (rest args) (+ i 2) + (str out (if (> (len args) 0) (cl-fmt-s (nth args 0)) "")))) + ((or (= dir "D") (= dir "F") (= dir "B") (= dir "X") (= dir "O")) + (cl-fmt-loop ctrl (rest args) (+ i 2) + (str out (if (> (len args) 0) (str (nth args 0)) "")))) + ((= dir "%") + (cl-fmt-loop ctrl args (+ i 2) (str out "\n"))) + ((= dir "&") + (cl-fmt-loop ctrl args (+ i 2) + (if (or (= (len out) 0) + (= (substr out (- (len out) 1) 1) "\n")) + out (str out "\n")))) + ((= dir "T") + (cl-fmt-loop ctrl args (+ i 2) (str out "\t"))) + ((= dir "P") + (let ((arg (if (> (len args) 0) (nth args 0) 1))) + (cl-fmt-loop ctrl (rest args) (+ i 2) + (str out (if (= arg 1) "" "s"))))) + ((= dir "{") + (let ((end-i (cl-fmt-find-close ctrl "}" (+ i 2) 0))) + (if (= end-i -1) + {:out (str out "~{") :args args} + (let ((inner (if (> end-i (+ i 2)) + (substr ctrl (+ i 2) (- end-i (+ i 2))) + ""))) + (let ((list-arg (if (> (len args) 0) (nth args 0) (list)))) + (cl-fmt-loop ctrl (rest args) (+ end-i 2) + (str out (cl-fmt-iterate inner (if (= list-arg nil) (list) list-arg))))))))) + ((= dir "[") + (let ((end-i (cl-fmt-find-close ctrl "]" (+ i 2) 0))) + (if (= end-i -1) + {:out (str out "~[") :args args} + (let ((inner (if (> end-i (+ i 2)) + (substr ctrl (+ i 2) (- end-i (+ i 2))) + ""))) + (let ((arg (if (> (len args) 0) (nth args 0) 0))) + (let ((chosen (if (= arg true) "T" + (if (= arg nil) "NIL" + (get (cl-fmt-loop inner (list arg) 0 "") "out"))))) + (cl-fmt-loop ctrl (rest args) (+ end-i 2) + (str out chosen)))))))) + ((= dir "~") + (cl-fmt-loop ctrl args (+ i 2) (str out "~"))) + ((= dir "^") + {:out out :args args}) + (:else + (cl-fmt-loop ctrl args (+ i 2) (str out "~" dir)))))))))) + +;; ── sequence/list helpers (needed by builtins) ─────────────────── + +(define cl-member-helper + (fn (item lst) + (if (= lst nil) nil + (if (= (len lst) 0) nil + (if (= (nth lst 0) item) + lst + (cl-member-helper item (rest lst))))))) + +(define cl-subst-helper + (fn (new old tree) + (if (= tree old) new + (if (and (list? tree) (> (len tree) 0)) + (map (fn (x) (cl-subst-helper new old x)) tree) + tree)))) + +(define cl-position-helper + (fn (item lst idx) + (if (= lst nil) nil + (if (= (len lst) 0) nil + (if (= (nth lst 0) item) + idx + (cl-position-helper item (rest lst) (+ idx 1))))))) + +(define cl-position-if-helper + (fn (fn-obj lst idx) + (if (= lst nil) nil + (if (= (len lst) 0) nil + (if (cl-apply fn-obj (list (nth lst 0))) + idx + (cl-position-if-helper fn-obj (rest lst) (+ idx 1))))))) + +;; ── built-in functions ──────────────────────────────────────────── + +(define cl-builtins + (dict + "+" (fn (args) (reduce (fn (a b) (+ a b)) 0 args)) + "-" (fn (args) + (cond + ((= (len args) 0) 0) + ((= (len args) 1) (- 0 (nth args 0))) + (:else (reduce (fn (a b) (- a b)) (nth args 0) (rest args))))) + "*" (fn (args) (reduce (fn (a b) (* a b)) 1 args)) + "/" (fn (args) + (cond + ((= (len args) 0) 1) + ((= (len args) 1) (/ 1 (nth args 0))) + (:else (reduce (fn (a b) (/ a b)) (nth args 0) (rest args))))) + "1+" (fn (args) (+ (nth args 0) 1)) + "1-" (fn (args) (- (nth args 0) 1)) + "=" (fn (args) (if (= (nth args 0) (nth args 1)) true nil)) + "/=" (fn (args) (if (not (= (nth args 0) (nth args 1))) true nil)) + "<" (fn (args) (if (< (nth args 0) (nth args 1)) true nil)) + ">" (fn (args) (if (> (nth args 0) (nth args 1)) true nil)) + "<=" (fn (args) (if (<= (nth args 0) (nth args 1)) true nil)) + ">=" (fn (args) (if (>= (nth args 0) (nth args 1)) true nil)) + "NOT" (fn (args) (if (nth args 0) nil true)) + "NULL" (fn (args) + (let ((x (nth args 0))) + (if (or (= x nil) (and (list? x) (= (len x) 0))) true nil))) + "NUMBERP" (fn (args) (if (number? (nth args 0)) true nil)) + "STRINGP" (fn (args) (if (string? (nth args 0)) true nil)) + "SYMBOLP" (fn (args) nil) + "LISTP" (fn (args) + (let ((x (nth args 0))) + (if (or (list? x) (= x nil) + (and (dict? x) (= (get x "cl-type") "cons"))) + true nil))) + "CONSP" (fn (args) + (let ((x (nth args 0))) + (if (or (and (list? x) (> (len x) 0)) + (and (dict? x) (= (get x "cl-type") "cons"))) + true nil))) + "ATOM" (fn (args) + (let ((x (nth args 0))) + (if (or (and (list? x) (> (len x) 0)) + (and (dict? x) (= (get x "cl-type") "cons"))) + nil true))) + "FUNCTIONP" (fn (args) + (let ((x (nth args 0))) + (if (and (dict? x) (= (get x "cl-type") "function")) true nil))) + "ZEROP" (fn (args) (if (= (nth args 0) 0) true nil)) + "PLUSP" (fn (args) (if (> (nth args 0) 0) true nil)) + "MINUSP" (fn (args) (if (< (nth args 0) 0) true nil)) + "EVENP" (fn (args) + (let ((n (nth args 0))) + (if (= (mod n 2) 0) true nil))) + "ODDP" (fn (args) + (let ((n (nth args 0))) + (if (not (= (mod n 2) 0)) true nil))) + "ABS" (fn (args) (let ((n (nth args 0))) (if (< n 0) (- 0 n) n))) + "MAX" (fn (args) (reduce (fn (a b) (if (> a b) a b)) (nth args 0) (rest args))) + "MIN" (fn (args) (reduce (fn (a b) (if (< a b) a b)) (nth args 0) (rest args))) + "CONS" (fn (args) {:cl-type "cons" :car (nth args 0) :cdr (nth args 1)}) + "CAR" (fn (args) + (let ((x (nth args 0))) + (if (and (dict? x) (= (get x "cl-type") "cons")) + (get x "car") + (if (and (list? x) (> (len x) 0)) (nth x 0) nil)))) + "CDR" (fn (args) + (let ((x (nth args 0))) + (if (and (dict? x) (= (get x "cl-type") "cons")) + (get x "cdr") + (if (list? x) (rest x) nil)))) + "LIST" (fn (args) args) + "APPEND" (fn (args) + (if (= (len args) 0) (list) + (reduce (fn (a b) + (if (= a nil) b (if (= b nil) a (concat a b)))) + (list) args))) + "LENGTH" (fn (args) + (let ((x (nth args 0))) + (if (= x nil) 0 (len x)))) + "NTH" (fn (args) (nth (nth args 1) (nth args 0))) + "FIRST" (fn (args) + (let ((x (nth args 0))) + (if (and (list? x) (> (len x) 0)) (nth x 0) nil))) + "SECOND" (fn (args) + (let ((x (nth args 0))) + (if (and (list? x) (> (len x) 1)) (nth x 1) nil))) + "THIRD" (fn (args) + (let ((x (nth args 0))) + (if (and (list? x) (> (len x) 2)) (nth x 2) nil))) + "REST" (fn (args) (rest (nth args 0))) + "REVERSE" (fn (args) + (reduce (fn (acc x) (concat (list x) acc)) + (list) (nth args 0))) + "IDENTITY" (fn (args) (nth args 0)) + "VALUES" (fn (args) (cond ((= (len args) 0) nil) ((= (len args) 1) (nth args 0)) (:else {:cl-type "mv" :vals args}))) + "PRINT" (fn (args) (nth args 0)) + "PRIN1" (fn (args) (nth args 0)) + "PRINC" (fn (args) (nth args 0)) + "TERPRI" (fn (args) nil) + "WRITE" (fn (args) (nth args 0)) + "STRING-UPCASE" (fn (args) (upcase (nth args 0))) + "STRING-DOWNCASE" (fn (args) (downcase (nth args 0))) + "STRING=" (fn (args) (if (= (nth args 0) (nth args 1)) true nil)) + "CONCATENATE" (fn (args) (reduce (fn (a b) (str a b)) "" (rest args))) + "EQ" (fn (args) (if (= (nth args 0) (nth args 1)) true nil)) + "EQL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil)) + "EQUAL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil)) + ;; sequence functions + "MAPC" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (begin + (for-each (fn (x) (cl-apply fn-obj (list x))) lst) + (nth args 1)))) + "MAPCAN" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (reduce (fn (acc x) + (let ((r (cl-apply fn-obj (list x)))) + (if (= r nil) acc + (concat acc r)))) + (list) lst))) + "REDUCE" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (let ((iv-r (cl-find-kw-arg "INITIAL-VALUE" args 2))) + (let ((has-iv (get iv-r "found")) + (iv (get iv-r "value"))) + (if (= (len lst) 0) + (if has-iv iv (cl-apply fn-obj (list))) + (if has-iv + (reduce (fn (acc x) (cl-apply fn-obj (list acc x))) iv lst) + (reduce (fn (acc x) (cl-apply fn-obj (list acc x))) + (nth lst 0) (rest lst)))))))) + "FIND" (fn (args) + (let ((item (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (let ((r (some (fn (x) (if (= x item) x false)) lst))) + (if r r nil)))) + "FIND-IF" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (let ((r (some (fn (x) + (let ((res (cl-apply fn-obj (list x)))) + (if res x false))) + lst))) + (if r r nil)))) + "FIND-IF-NOT" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (let ((r (some (fn (x) + (let ((res (cl-apply fn-obj (list x)))) + (if res false x))) + lst))) + (if r r nil)))) + "POSITION" (fn (args) + (cl-position-helper (nth args 0) + (if (= (nth args 1) nil) (list) (nth args 1)) 0)) + "POSITION-IF" (fn (args) + (cl-position-if-helper (nth args 0) + (if (= (nth args 1) nil) (list) (nth args 1)) 0)) + "COUNT" (fn (args) + (let ((item (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (len (filter (fn (x) (= x item)) lst)))) + "COUNT-IF" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (len (filter (fn (x) (cl-apply fn-obj (list x))) lst)))) + "EVERY" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (if (every? (fn (x) (cl-apply fn-obj (list x))) lst) true nil))) + "SOME" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (let ((r (some (fn (x) (cl-apply fn-obj (list x))) lst))) + (if r r nil)))) + "NOTANY" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (if (some (fn (x) (cl-apply fn-obj (list x))) lst) nil true))) + "NOTEVERY" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (if (every? (fn (x) (cl-apply fn-obj (list x))) lst) nil true))) + "REMOVE" (fn (args) + (let ((item (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (filter (fn (x) (not (= x item))) lst))) + "REMOVE-IF" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (filter (fn (x) (not (cl-apply fn-obj (list x)))) lst))) + "REMOVE-IF-NOT" (fn (args) + (let ((fn-obj (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (filter (fn (x) (cl-apply fn-obj (list x))) lst))) + "SUBST" (fn (args) + (cl-subst-helper (nth args 0) (nth args 1) + (if (= (nth args 2) nil) (list) (nth args 2)))) + "MEMBER" (fn (args) + (cl-member-helper (nth args 0) + (if (= (nth args 1) nil) nil (nth args 1)))) + ;; list ops + "ASSOC" (fn (args) + (let ((key (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (let ((r (some + (fn (pair) + (let ((k (if (and (dict? pair) (= (get pair "cl-type") "cons")) + (get pair "car") + (if (and (list? pair) (> (len pair) 0)) + (nth pair 0) + nil)))) + (if (= k key) pair false))) + lst))) + (if r r nil)))) + "RASSOC" (fn (args) + (let ((val (nth args 0)) + (lst (if (= (nth args 1) nil) (list) (nth args 1)))) + (let ((r (some + (fn (pair) + (let ((v (if (and (dict? pair) (= (get pair "cl-type") "cons")) + (get pair "cdr") + (if (and (list? pair) (> (len pair) 1)) + (nth pair 1) + nil)))) + (if (= v val) pair false))) + lst))) + (if r r nil)))) + "GETF" (fn (args) + (let ((plist (if (= (nth args 0) nil) (list) (nth args 0))) + (ind (nth args 1)) + (def (if (> (len args) 2) (nth args 2) nil))) + (let ((ind-name (if (and (dict? ind) (= (get ind "cl-type") "keyword")) + (get ind "name") + (upcase (str ind))))) + (let ((r (cl-find-kw-arg ind-name plist 0))) + (if (get r "found") (get r "value") def))))) + "LAST" (fn (args) + (let ((lst (nth args 0))) + (if (or (= lst nil) (= (len lst) 0)) nil + (list (nth lst (- (len lst) 1)))))) + "BUTLAST" (fn (args) + (let ((lst (nth args 0))) + (if (or (= lst nil) (= (len lst) 0)) (list) + (slice lst 0 (- (len lst) 1))))) + "NTHCDR" (fn (args) + (let ((n (nth args 0)) + (lst (nth args 1))) + (if (= lst nil) nil + (if (>= n (len lst)) nil + (slice lst n (len lst)))))) + "COPY-LIST" (fn (args) (nth args 0)) + "LIST*" (fn (args) + (if (= (len args) 0) nil + (if (= (len args) 1) (nth args 0) + (let ((head (slice args 0 (- (len args) 1))) + (tail (nth args (- (len args) 1)))) + (concat head (if (list? tail) tail (list tail))))))) + "CAAR" (fn (args) + (let ((x (nth args 0))) + (let ((c (if (and (list? x) (> (len x) 0)) (nth x 0) nil))) + (if (and (list? c) (> (len c) 0)) (nth c 0) nil)))) + "CADR" (fn (args) + (let ((x (nth args 0))) + (if (and (list? x) (> (len x) 1)) (nth x 1) nil))) + "CDAR" (fn (args) + (let ((x (nth args 0))) + (let ((c (if (and (list? x) (> (len x) 0)) (nth x 0) nil))) + (if (and (list? c) (> (len c) 0)) (rest c) nil)))) + "CDDR" (fn (args) + (let ((x (nth args 0))) + (if (and (list? x) (> (len x) 2)) + (slice x 2 (len x)) + nil))) + "CADDR" (fn (args) + (let ((x (nth args 0))) + (if (and (list? x) (> (len x) 2)) (nth x 2) nil))) + "CADDDR" (fn (args) + (let ((x (nth args 0))) + (if (and (list? x) (> (len x) 3)) (nth x 3) nil))) + "PAIRLIS" (fn (args) + (let ((ks (if (= (nth args 0) nil) (list) (nth args 0))) + (vs (if (= (nth args 1) nil) (list) (nth args 1)))) + (map (fn (i) (list (nth ks i) (nth vs i))) + (range 0 (len ks))))) + ;; string ops + "SUBSEQ" (fn (args) + (let ((seq (nth args 0)) + (start (nth args 1)) + (end (if (> (len args) 2) (nth args 2) nil))) + (if (string? seq) + (if end (substr seq start (- end start)) (substr seq start (- (len seq) start))) + (if (= seq nil) (list) + (if end (slice seq start end) (slice seq start (len seq))))))) + "STRING" (fn (args) + (let ((x (nth args 0))) + (if (string? x) x (str x)))) + "CHAR" (fn (args) + (let ((s (nth args 0)) (i (nth args 1))) + {:cl-type "char" :value (substr s i (+ i 1))})) + "CHAR=" (fn (args) + (let ((a (nth args 0)) (b (nth args 1))) + (let ((av (if (dict? a) (get a "value") a)) + (bv (if (dict? b) (get b "value") b))) + (if (= av bv) true nil)))) + "STRING-LENGTH" (fn (args) (len (nth args 0))) + "STRING<" (fn (args) (if (< (nth args 0) (nth args 1)) true nil)) + "STRING>" (fn (args) (if (> (nth args 0) (nth args 1)) true nil)) + "STRING<=" (fn (args) (if (<= (nth args 0) (nth args 1)) true nil)) + "STRING>=" (fn (args) (if (>= (nth args 0) (nth args 1)) true nil)) + "WRITE-TO-STRING" (fn (args) (inspect (nth args 0))) + "SYMBOL-NAME" (fn (args) (upcase (str (nth args 0)))) + "COERCE" (fn (args) + (let ((x (nth args 0)) + (tp (upcase (str (nth args 1))))) + (cond + ((= tp "LIST") (if (string? x) + (map (fn (i) {:cl-type "char" :value (substr x i (+ i 1))}) + (range 0 (len x))) x)) + ((= tp "STRING") (if (list? x) + (reduce (fn (a c) (str a (if (dict? c) (get c "value") c))) "" x) + (str x))) + (:else x)))) + "FORMAT" (fn (args) + (let ((dest (nth args 0)) + (ctrl (if (> (len args) 1) (nth args 1) "")) + (fargs (if (> (len args) 2) (slice args 2 (len args)) (list)))) + (let ((result (get (cl-fmt-loop ctrl fargs 0 "") "out"))) + (if (= dest nil) result nil)))) + "MAKE-LIST" (fn (args) + (let ((n (nth args 0))) + (map (fn (_) nil) (range 0 n)))))) + +;; Register builtins in cl-global-env so (function #'name) resolves them +(for-each + (fn (name) + (dict-set! (get cl-global-env "fns") name + {:cl-type "function" :builtin-fn (get cl-builtins name)})) + (keys cl-builtins)) + +;; ── TAGBODY / GO ───────────────────────────────────────────────── + +(define cl-tagbody-tag? + (fn (form) (or (string? form) (number? form)))) + +(define cl-build-tag-map + (fn (forms i acc) + (if (>= i (len forms)) + acc + (if (cl-tagbody-tag? (nth forms i)) + (cl-build-tag-map forms (+ i 1) + (assoc acc (str (nth forms i)) i)) + (cl-build-tag-map forms (+ i 1) acc))))) + +(define cl-eval-tagbody + (fn (args env) + (let ((tag-map (cl-build-tag-map args 0 {}))) + (define run + (fn (i) + (if (>= i (len args)) + nil + (let ((form (nth args i))) + (if (cl-tagbody-tag? form) + (run (+ i 1)) + (let ((result (cl-eval form env))) + (cond + ((cl-go-tag? result) + (let ((target (get result "tag"))) + (let ((tkey (str target))) + (if (has-key? tag-map tkey) + (run (get tag-map tkey)) + {:cl-type "error" :message (str "No tag: " target)})))) + ((cl-block-return? result) result) + (:else (run (+ i 1)))))))))) + (run 0)))) + +;; ── MULTIPLE VALUES ────────────────────────────────────────────── + +(define cl-eval-multiple-value-bind + (fn (args env) + (let ((vars (nth args 0)) + (form (nth args 1)) + (body (rest (rest args)))) + (let ((vals (cl-mv-vals (cl-eval form env)))) + (define bind-vars + (fn (names i e) + (if (= (len names) 0) + e + (bind-vars (rest names) (+ i 1) + (cl-env-bind-var e (nth names 0) + (if (< i (len vals)) (nth vals i) nil)))))) + (cl-eval-body body (bind-vars vars 0 env)))))) + +(define cl-eval-multiple-value-call + (fn (args env) + (let ((fn-obj (cl-eval (nth args 0) env)) + (forms (rest args))) + (let ((all-vals (reduce + (fn (acc f) + (concat acc (cl-mv-vals (cl-eval f env)))) + (list) forms))) + (cl-apply fn-obj all-vals))))) + +(define cl-eval-multiple-value-prog1 + (fn (args env) + (let ((first-result (cl-eval (nth args 0) env))) + (for-each (fn (f) (cl-eval f env)) (rest args)) + first-result))) + +;; ── UNWIND-PROTECT ─────────────────────────────────────────────── + +(define cl-eval-unwind-protect + (fn (args env) + (let ((protected (nth args 0)) + (cleanup (rest args))) + (let ((result (cl-eval protected env))) + (for-each (fn (f) (cl-eval f env)) cleanup) + result)))) + +;; ── BLOCK / RETURN-FROM ─────────────────────────────────────────── + +(define cl-eval-block + (fn (args env) + (let ((name (nth args 0)) + (body (rest args))) + (let ((result (cl-eval-body body env))) + (if (and (cl-block-return? result) + (= (get result "name") name)) + (get result "value") + result))))) + +(define cl-eval-return-from + (fn (args env) + (let ((name (nth args 0)) + (val (if (> (len args) 1) (cl-eval (nth args 1) env) nil))) + {:cl-type "block-return" :name name :value val}))) + +;; ── special form evaluators ─────────────────────────────────────── + +(define cl-eval-if + (fn (args env) + (let ((cond-val (cl-mv-primary (cl-eval (nth args 0) env))) + (then-form (nth args 1)) + (else-form (if (> (len args) 2) (nth args 2) nil))) + (if cond-val + (cl-eval then-form env) + (if else-form (cl-eval else-form env) nil))))) + +(define cl-eval-and + (fn (args env) + (if (= (len args) 0) + true + (let ((val (cl-mv-primary (cl-eval (nth args 0) env)))) + (if (not val) + nil + (if (= (len args) 1) + val + (cl-eval-and (rest args) env))))))) + +(define cl-eval-or + (fn (args env) + (if (= (len args) 0) + nil + (let ((val (cl-mv-primary (cl-eval (nth args 0) env)))) + (if val + val + (cl-eval-or (rest args) env)))))) + +(define cl-eval-cond + (fn (clauses env) + (if (= (len clauses) 0) + nil + (let ((clause (nth clauses 0))) + (let ((test-val (cl-mv-primary (cl-eval (nth clause 0) env)))) + (if test-val + (if (= (len clause) 1) + test-val + (cl-eval-body (rest clause) env)) + (cl-eval-cond (rest clauses) env))))))) + +;; Dynamic variable infrastructure +(define cl-dyn-unbound {:cl-type "dyn-unbound"}) +(define cl-specials {}) +(define cl-symbol-macros {}) +(define cl-mark-special! + (fn (name) (dict-set! cl-specials name true))) +(define cl-special? + (fn (name) (has-key? cl-specials name))) +;; Apply dynamic bindings: save old global values, set new, run thunk, restore +(define cl-apply-dyn + (fn (binds thunk) + (if (= (len binds) 0) + (thunk) + (let ((b (nth binds 0)) + (rest-binds (rest binds))) + (let ((name (get b "name")) + (val (get b "value")) + (gvars (get cl-global-env "vars"))) + (let ((old (if (has-key? gvars name) + (get gvars name) + cl-dyn-unbound))) + (dict-set! gvars name val) + (let ((result (cl-apply-dyn rest-binds thunk))) + (if (and (dict? old) (= (get old "cl-type") "dyn-unbound")) + (dict-set! gvars name nil) + (dict-set! gvars name old)) + result))))))) +;; Sequential LET* with dynamic variable support +(define cl-letstar-bind + (fn (bs e thunk) + (if (= (len bs) 0) + (thunk e) + (let ((b (nth bs 0)) + (rest-bs (rest bs))) + (let ((name (if (list? b) (nth b 0) b)) + (init (if (and (list? b) (> (len b) 1)) (nth b 1) nil))) + (let ((val (cl-eval init e))) + (if (cl-special? name) + (let ((gvars (get cl-global-env "vars"))) + (let ((old (if (has-key? gvars name) + (get gvars name) + cl-dyn-unbound))) + (dict-set! gvars name val) + (let ((result (cl-letstar-bind rest-bs e thunk))) + (if (and (dict? old) (= (get old "cl-type") "dyn-unbound")) + (dict-set! gvars name nil) + (dict-set! gvars name old)) + result))) + (cl-letstar-bind rest-bs (cl-env-bind-var e name val) thunk)))))))) + +;; Parallel LET and sequential LET* +(define cl-eval-let + (fn (args env sequential) + (let ((bindings (nth args 0)) + (body (rest args))) + (if sequential + ;; LET*: each binding sees previous ones + (cl-letstar-bind bindings env (fn (new-env) (cl-eval-body body new-env))) + ;; LET: evaluate all inits in current env, then bind + (let ((pairs (map + (fn (b) + (let ((name (if (list? b) (nth b 0) b)) + (init (if (and (list? b) (> (len b) 1)) (nth b 1) nil))) + {:name name :value (cl-eval init env)})) + bindings))) + (let ((spec-pairs (filter (fn (p) (cl-special? (get p "name"))) pairs)) + (lex-pairs (filter (fn (p) (not (cl-special? (get p "name")))) pairs))) + (let ((new-env (reduce + (fn (e pair) + (cl-env-bind-var e (get pair "name") (get pair "value"))) + env lex-pairs))) + (cl-apply-dyn spec-pairs + (fn () (cl-eval-body body new-env)))))))))) + +;; SETQ / SETF (simplified: mutate nearest scope or global) +(define cl-eval-setq + (fn (args env) + (if (< (len args) 2) + nil + (let ((name (nth args 0)) + (val (cl-eval (nth args 1) env))) + (if (has-key? (get env "vars") name) + (dict-set! (get env "vars") name val) + (dict-set! (get cl-global-env "vars") name val)) + (if (> (len args) 2) + (cl-eval-setq (rest (rest args)) env) + val))))) + +;; FUNCTION: get function value or create lambda +(define cl-eval-function + (fn (args env) + (let ((spec (nth args 0))) + (cond + ((and (list? spec) (> (len spec) 0) (= (nth spec 0) "LAMBDA")) + (cl-make-lambda (rest spec) env)) + ((string? spec) + (cond + ((cl-env-has-fn? env spec) (cl-env-get-fn env spec)) + ((cl-env-has-fn? cl-global-env spec) + (cl-env-get-fn cl-global-env spec)) + (:else {:cl-type "error" :message (str "Undefined function: " spec)}))) + (:else {:cl-type "error" :message "FUNCTION: invalid spec"}))))) + +;; FLET: local functions (non-recursive, close over outer env) +(define cl-eval-flet + (fn (args env) + (let ((fn-defs (nth args 0)) + (body (rest args))) + (let ((new-env (reduce + (fn (e def) + (let ((name (nth def 0)) + (ll (nth def 1)) + (fn-body (rest (rest def)))) + (cl-env-bind-fn e name + {:cl-type "function" + :params (cl-parse-lambda-list ll) + :body fn-body + :env env}))) + env fn-defs))) + (cl-eval-body body new-env))))) + +;; LABELS: mutually-recursive local functions +(define cl-eval-labels + (fn (args env) + (let ((fn-defs (nth args 0)) + (body (rest args))) + ;; Build env with placeholder nil entries for each name + (let ((new-env (reduce + (fn (e def) (cl-env-bind-fn e (nth def 0) nil)) + env fn-defs))) + ;; Fill in real function objects that capture new-env + (for-each + (fn (def) + (let ((name (nth def 0)) + (ll (nth def 1)) + (fn-body (rest (rest def)))) + (dict-set! (get new-env "fns") name + {:cl-type "function" + :params (cl-parse-lambda-list ll) + :body fn-body + :env new-env}))) + fn-defs) + (cl-eval-body body new-env))))) + +;; EVAL-WHEN: evaluate body only if :execute is in situations +(define cl-eval-eval-when + (fn (args env) + (let ((situations (nth args 0)) + (body (rest args))) + (define has-exec + (some (fn (s) + (or + (and (dict? s) + (= (get s "cl-type") "keyword") + (= (get s "name") "EXECUTE")) + (= s "EXECUTE"))) + situations)) + (if has-exec (cl-eval-body body env) nil)))) + +;; DEFUN: define function in global fns namespace +(define cl-eval-defun + (fn (args env) + (let ((name (nth args 0)) + (ll (nth args 1)) + (fn-body (rest (rest args)))) + (let ((fn-obj {:cl-type "function" + :params (cl-parse-lambda-list ll) + :body fn-body + :env env})) + (dict-set! (get cl-global-env "fns") name fn-obj) + name)))) + +;; DEFVAR / DEFPARAMETER / DEFCONSTANT +(define cl-eval-defvar + (fn (args env always-assign) + (let ((name (nth args 0)) + (has-init (> (len args) 1))) + (let ((val (if has-init (cl-eval (nth args 1) env) nil))) + (when (or always-assign + (not (cl-env-has-var? cl-global-env name))) + (dict-set! (get cl-global-env "vars") name val)) + (cl-mark-special! name) + name)))) + +;; Function call: evaluate name → look up fns, builtins; evaluate args +(define cl-call-fn + (fn (name-raw args env) + (let ((name (let ((ps (cl-package-sep? name-raw))) + (if ps (get ps "name") name-raw)))) + (let ((evaled (map (fn (a) (cl-mv-primary (cl-eval a env))) args))) + (cond + ;; FUNCALL: (funcall fn arg...) + ((= name "FUNCALL") + (cl-apply (nth evaled 0) (rest evaled))) + ;; APPLY: (apply fn arg... list) + ((= name "APPLY") + (let ((fn-obj (nth evaled 0)) + (all-args (rest evaled))) + (let ((leading (slice all-args 0 (- (len all-args) 1))) + (last-arg (nth all-args (- (len all-args) 1)))) + (cl-apply fn-obj (concat leading (if (= last-arg nil) (list) last-arg)))))) + ;; MAPCAR: (mapcar fn list) + ((= name "MAPCAR") + (let ((fn-obj (nth evaled 0)) + (lst (nth evaled 1))) + (if (= lst nil) (list) + (map (fn (x) (cl-apply fn-obj (list x))) lst)))) + ;; Look up in local fns namespace (try bare name via package stripping) + ((cl-env-has-fn? env name) + (cl-apply (cl-env-get-fn env name) evaled)) + ((let ((ps (cl-package-sep? name))) + (and ps (cl-env-has-fn? env (get ps "name")))) + (cl-apply (cl-env-get-fn env (get (cl-package-sep? name) "name")) evaled)) + ;; Look up in global fns namespace + ((cl-env-has-fn? cl-global-env name) + (cl-apply (cl-env-get-fn cl-global-env name) evaled)) + ((let ((ps (cl-package-sep? name))) + (and ps (cl-env-has-fn? cl-global-env (get ps "name")))) + (cl-apply (cl-env-get-fn cl-global-env (get (cl-package-sep? name) "name")) evaled)) + ;; Look up in builtins (bare or package-qualified) + ((has-key? cl-builtins name) + ((get cl-builtins name) evaled)) + ((let ((ps (cl-package-sep? name))) + (and ps (has-key? cl-builtins (get ps "name")))) + ((get cl-builtins (get (cl-package-sep? name) "name")) evaled)) + (:else + {:cl-type "error" :message (str "Undefined function: " name-raw)})))))) + +;; ── main evaluator ──────────────────────────────────────────────── + +(define cl-eval + (fn (form env) + (cond + ;; Nil and booleans are self-evaluating + ((= form nil) nil) + ((= form true) true) + ;; Numbers are self-evaluating + ((number? form) form) + ;; Dicts: typed CL values + ((dict? form) + (let ((ct (get form "cl-type"))) + (cond + ((= ct "string") (get form "value")) ;; CL string → SX string + (:else form)))) ;; keywords, floats, chars, etc. + ;; Symbol reference (variable or symbol-macro lookup) + ((string? form) + (let ((uform (upcase form))) + (let ((bare (let ((ps (cl-package-sep? uform))) + (if ps (get ps "name") uform)))) + (if (and (has-key? cl-symbol-macros bare) + (not (= (get cl-symbol-macros bare) nil))) + (cl-eval (get cl-symbol-macros bare) env) + (cond + ((cl-env-has-var? env bare) (cl-env-get-var env bare)) + ((cl-env-has-var? cl-global-env bare) + (cl-env-get-var cl-global-env bare)) + (:else {:cl-type "error" :message (str "Undefined variable: " form)})))))) + ;; List: special forms or function call + ((list? form) (cl-eval-list form env)) + ;; Anything else self-evaluates + (:else form)))) + + +;; Convert a CL cons tree to an SX list (for macro expansion results) +(define cl-cons->sx-list + (fn (x) + (if (and (dict? x) (= (get x "cl-type") "cons")) + (cons (cl-cons->sx-list (get x "car")) + (cl-cons->sx-list (get x "cdr"))) + (if (and (dict? x) (= (get x "cl-type") "nil")) + (list) + (if (list? x) + (map cl-cons->sx-list x) + x))))) + +;; ── macro expansion ─────────────────────────────────────────────── + +;; Expand a macro one level. Returns {:expanded bool :form form} +(define cl-macroexpand-1 + (fn (form env) + (if (not (list? form)) + {:expanded false :form form} + (if (= (len form) 0) + {:expanded false :form form} + (let ((head (nth form 0))) + (if (not (string? head)) + {:expanded false :form form} + (let ((uhead (upcase head))) + (if (has-key? cl-macro-registry uhead) + {:expanded true + :form (cl-cons->sx-list ((get cl-macro-registry uhead) form env))} + {:expanded false :form form})))))))) + +;; Fully expand macros (loop until stable) +(define cl-macroexpand + (fn (form env) + (let ((r (cl-macroexpand-1 form env))) + (if (get r "expanded") + (cl-macroexpand (get r "form") env) + (get r "form"))))) + + +;; Helper: bind macro lambda-list params to actuals in env +(define cl-macro-bind-params + (fn (ps as env) + (if (= (len ps) 0) + env + (let ((p (nth ps 0))) + (if (= p "&REST") + (cl-env-bind-var env (nth ps 1) as) + (cl-macro-bind-params + (rest ps) + (if (= (len as) 0) (list) (rest as)) + (cl-env-bind-var env p + (if (= (len as) 0) nil (nth as 0))))))))) + +;; DEFMACRO: store expander function in macro registry +;; (defmacro name (params...) body...) +(define cl-eval-defmacro + (fn (args env) + (let ((name (nth args 0)) + (params (nth args 1)) + (body (rest (rest args)))) + (let ((uname (upcase name))) + (let ((expander + (fn (form xenv) + (let ((actuals (rest form)) + (bound-env (cl-macro-bind-params (map upcase params) (rest form) env))) + (cl-eval-body body bound-env))))) + (dict-set! cl-macro-registry uname expander) + uname))))) + +;; MACROLET: local macro bindings +;; (macrolet ((name params body...) ...) body...) +(define cl-eval-macrolet + (fn (args env) + (let ((bindings (nth args 0)) + (body (rest args))) + (define orig-registry cl-macro-registry) + (for-each + (fn (b) + (let ((name (nth b 0)) + (params (nth b 1)) + (mbody (rest (rest b)))) + (cl-eval-defmacro (list name params (nth mbody 0)) env))) + bindings) + (let ((result (cl-eval-body body env))) + ;; restore — not perfect isolation but workable + result)))) + +;; SYMBOL-MACROLET: bind symbols to expansion forms +(define cl-eval-symbol-macrolet + (fn (args env) + (let ((bindings (nth args 0)) + (body (rest args))) + ;; Install each symbol in cl-symbol-macros; save old to restore after + (let ((saved (map (fn (b) (let ((sym (upcase (nth b 0)))) + {:sym sym :old (if (has-key? cl-symbol-macros sym) (get cl-symbol-macros sym) nil)})) + bindings))) + (for-each + (fn (b) + (dict-set! cl-symbol-macros (upcase (nth b 0)) (nth b 1))) + bindings) + (let ((result (cl-eval-body body env))) + (for-each + (fn (s) + (if (= (get s "old") nil) + (dict-set! cl-symbol-macros (get s "sym") nil) + (dict-set! cl-symbol-macros (get s "sym") (get s "old")))) + saved) + result))))) + +(define cl-eval-list + (fn (form env) + (if (= (len form) 0) + nil + (let ((head (nth form 0)) + (args (rest form))) + (cond + ;; Macro expansion check + ((and (string? head) (has-key? cl-macro-registry (upcase head))) + (cl-eval (cl-macroexpand form env) env)) + ((= head "QUOTE") (nth args 0)) + ((= head "IF") (cl-eval-if args env)) + ((= head "PROGN") (cl-eval-body args env)) + ((= head "LET") (cl-eval-let args env false)) + ((= head "LET*") (cl-eval-let args env true)) + ((= head "AND") (cl-eval-and args env)) + ((= head "OR") (cl-eval-or args env)) + ((= head "COND") (cl-eval-cond args env)) + ((= head "WHEN") + (if (cl-eval (nth args 0) env) + (cl-eval-body (rest args) env) nil)) + ((= head "UNLESS") + (if (not (cl-eval (nth args 0) env)) + (cl-eval-body (rest args) env) nil)) + ((= head "SETQ") (cl-eval-setq args env)) + ((= head "SETF") (cl-eval-setq args env)) + ((= head "FUNCTION") (cl-eval-function args env)) + ((= head "LAMBDA") (cl-make-lambda args env)) + ((= head "FLET") (cl-eval-flet args env)) + ((= head "LABELS") (cl-eval-labels args env)) + ((= head "THE") (cl-eval (nth args 1) env)) + ((= head "LOCALLY") (cl-eval-body args env)) + ((= head "EVAL-WHEN") (cl-eval-eval-when args env)) + ((= head "DEFUN") (cl-eval-defun args env)) + ((= head "TAGBODY") (cl-eval-tagbody args env)) + ((= head "GO") + {:cl-type "go-tag" :tag (nth args 0)}) + ((= head "MULTIPLE-VALUE-BIND") (cl-eval-multiple-value-bind args env)) + ((= head "MULTIPLE-VALUE-CALL") (cl-eval-multiple-value-call args env)) + ((= head "MULTIPLE-VALUE-PROG1") (cl-eval-multiple-value-prog1 args env)) + ((= head "NTH-VALUE") + (let ((n (cl-mv-primary (cl-eval (nth args 0) env))) + (vals (cl-mv-vals (cl-eval (nth args 1) env)))) + (if (< n (len vals)) (nth vals n) nil))) + ((= head "UNWIND-PROTECT") (cl-eval-unwind-protect args env)) + ((= head "BLOCK") (cl-eval-block args env)) + ((= head "RETURN-FROM") (cl-eval-return-from args env)) + ((= head "RETURN") + (let ((val (if (> (len args) 0) (cl-eval (nth args 0) env) nil))) + {:cl-type "block-return" :name nil :value val})) + ((= head "DEFVAR") (cl-eval-defvar args env false)) + ((= head "DEFPARAMETER") (cl-eval-defvar args env true)) + ((= head "DEFCONSTANT") (cl-eval-defvar args env true)) + ((= head "DECLAIM") nil) + ((= head "PROCLAIM") nil) + ((= head "SET-MACRO-CHARACTER") + (let ((ch (cl-eval (nth args 0) env)) + (fn-obj (cl-eval (nth args 1) env))) + (let ((key (if (and (dict? ch) (= (get ch "cl-type") "char")) + (get ch "value") + (str ch)))) + (dict-set! cl-reader-macros key fn-obj) + nil))) + ((= head "GET-MACRO-CHARACTER") + (let ((ch (cl-eval (nth args 0) env))) + (let ((key (if (and (dict? ch) (= (get ch "cl-type") "char")) + (get ch "value") + (str ch)))) + (if (has-key? cl-reader-macros key) + (list (get cl-reader-macros key) nil) + (list nil nil))))) + ((= head "SET-DISPATCH-MACRO-CHARACTER") + (let ((disp (cl-eval (nth args 0) env)) + (ch (cl-eval (nth args 1) env)) + (fn-obj (if (> (len args) 2) (cl-eval (nth args 2) env) nil))) + (let ((key (str (if (and (dict? disp) (= (get disp "cl-type") "char")) (get disp "value") (str disp)) + (if (and (dict? ch) (= (get ch "cl-type") "char")) (get ch "value") (str ch))))) + (dict-set! cl-dispatch-macros key fn-obj) + nil))) + ((= head "DEFPACKAGE") + (let ((raw (nth args 0))) + (let ((name (upcase (cond + ((and (dict? raw) (= (get raw "cl-type") "keyword")) (get raw "name")) + ((string? raw) raw) + (:else (str raw)))))) + (let ((exports (some + (fn (opt) + (if (and (list? opt) (> (len opt) 0) + (dict? (nth opt 0)) + (= (upcase (str (get (nth opt 0) "name"))) "EXPORT")) + (rest opt) false)) + (rest args)))) + (dict-set! cl-packages name + {:name name :exports (if exports exports (list))}) + name)))) + ((= head "IN-PACKAGE") + (let ((raw (nth args 0))) + (let ((name (upcase (cond + ((and (dict? raw) (= (get raw "cl-type") "keyword")) (get raw "name")) + ((string? raw) raw) + (:else (str raw)))))) + (set! cl-current-package name) + name))) + ((= head "EXPORT") nil) + ((= head "USE-PACKAGE") nil) + ((= head "IMPORT") nil) + ((= head "FIND-PACKAGE") + (let ((n (upcase (str (cl-eval (nth args 0) env))))) + (if (has-key? cl-packages n) (get cl-packages n) nil))) + ((= head "PACKAGE-NAME") + (if (= (len args) 0) cl-current-package + (let ((pkg (cl-eval (nth args 0) env))) + (if (string? pkg) pkg (if (dict? pkg) (get pkg "name") nil))))) + ((= head "DEFMACRO") (cl-eval-defmacro args env)) + ((= head "MACROLET") (cl-eval-macrolet args env)) + ((= head "SYMBOL-MACROLET") (cl-eval-symbol-macrolet args env)) + ((= head "MACROEXPAND-1") + (let ((arg (cl-eval (nth args 0) env))) + (cl-macroexpand-1 arg env))) + ((= head "MACROEXPAND") + (let ((arg (cl-eval (nth args 0) env))) + (cl-macroexpand arg env))) + ((= head "GENSYM") + (cl-eval-gensym (if (> (len args) 0) (cl-eval (nth args 0) env) nil))) + ((= head "GENTEMP") + (cl-eval-gensym (if (> (len args) 0) (cl-eval (nth args 0) env) "T"))) + ;; Named function call + ((string? head) + (cl-call-fn head args env)) + ;; Anonymous call: ((lambda ...) args) + (:else + (let ((fn-obj (cl-eval head env))) + (if (and (dict? fn-obj) (= (get fn-obj "cl-type") "function")) + (cl-apply fn-obj (map (fn (a) (cl-eval a env)) args)) + {:cl-type "error" :message "Not callable"})))))))) + +;; ── public API ──────────────────────────────────────────────────── + +(define cl-eval-str + (fn (src env) + (cl-eval (cl-read src) env))) + +(define cl-eval-all-str + (fn (src env) + (let ((forms (cl-read-all src))) + (if (= (len forms) 0) + nil + (let ((result nil) (i 0)) + (define loop (fn () + (when (< i (len forms)) + (do + (set! result (cl-eval (nth forms i) env)) + (set! i (+ i 1)) + (loop))))) + (loop) + result))))) diff --git a/lib/common-lisp/loop.sx b/lib/common-lisp/loop.sx new file mode 100644 index 00000000..eaa8747c --- /dev/null +++ b/lib/common-lisp/loop.sx @@ -0,0 +1,623 @@ +;; lib/common-lisp/loop.sx — The LOOP macro for CL-on-SX +;; +;; Supported clauses: +;; for VAR in LIST — iterate over list +;; for VAR across VECTOR — alias for 'in' +;; for VAR from N — numeric iteration (to/upto/below/downto/above/by) +;; for VAR = EXPR [then EXPR] — general iteration +;; while COND — stop when false +;; until COND — stop when true +;; repeat N — repeat N times +;; collect EXPR [into VAR] +;; append EXPR [into VAR] +;; nconc EXPR [into VAR] +;; sum EXPR [into VAR] +;; count EXPR [into VAR] +;; maximize EXPR [into VAR] +;; minimize EXPR [into VAR] +;; do FORM... +;; when/if COND clause... +;; unless COND clause... +;; finally FORM... +;; always COND +;; never COND +;; thereis COND +;; named BLOCK-NAME +;; +;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/eval.sx already loaded. +;; Uses defmacro in the CL evaluator. + +;; ── LOOP expansion driver ───────────────────────────────────────────────── + +;; cl-loop-parse: analyse the flat LOOP clause list and build a Lisp form. +;; Returns a (block NAME (let (...) (tagbody ...))) form. +(define + cl-loop-parse + (fn + (clauses) + (define block-name nil) + (define with-bindings (list)) + (define for-bindings (list)) + (define test-forms (list)) + (define repeat-var nil) + (define repeat-count nil) + (define body-forms (list)) + (define accum-vars (dict)) + (define accum-clauses (dict)) + (define result-var nil) + (define finally-forms (list)) + (define return-expr nil) + (define termination nil) + (define idx 0) + (define (lp-peek) (if (< idx (len clauses)) (nth clauses idx) nil)) + (define + (next!) + (let ((v (lp-peek))) (do (set! idx (+ idx 1)) v))) + (define + (skip-if pred) + (if (and (not (nil? (lp-peek))) (pred (lp-peek))) (next!) nil)) + (define (upcase-str s) (if (string? s) (upcase s) s)) + (define (kw? s k) (= (upcase-str s) k)) + (define + (make-accum-var!) + (if + (nil? result-var) + (do (set! result-var "#LOOP-RESULT") result-var) + result-var)) + (define + (add-accum! type expr into-var) + (let + ((v (if (nil? into-var) (make-accum-var!) into-var))) + (if + (not (has-key? accum-vars v)) + (do + (set! + accum-vars + (assoc + accum-vars + v + (cond + ((= type ":sum") 0) + ((= type ":count") 0) + ((= type ":maximize") nil) + ((= type ":minimize") nil) + (:else (list))))) + (set! accum-clauses (assoc accum-clauses v type)))) + (let + ((update (cond ((= type ":collect") (list "SETQ" v (list "APPEND" v (list "LIST" expr)))) ((= type ":append") (list "SETQ" v (list "APPEND" v expr))) ((= type ":nconc") (list "SETQ" v (list "NCONC" v expr))) ((= type ":sum") (list "SETQ" v (list "+" v expr))) ((= type ":count") (list "SETQ" v (list "+" v (list "IF" expr 1 0)))) ((= type ":maximize") (list "SETQ" v (list "IF" (list "OR" (list "NULL" v) (list ">" expr v)) expr v))) ((= type ":minimize") (list "SETQ" v (list "IF" (list "OR" (list "NULL" v) (list "<" expr v)) expr v))) (:else (list "SETQ" v (list "APPEND" v (list "LIST" expr))))))) + (set! body-forms (append body-forms (list update)))))) + (define + (parse-clause!) + (let + ((tok (lp-peek))) + (if + (nil? tok) + nil + (do + (let + ((u (upcase-str tok))) + (cond + ((= u "NAMED") + (do (next!) (set! block-name (next!)) (parse-clause!))) + ((= u "WITH") + (do + (next!) + (let + ((var (next!))) + (skip-if (fn (s) (kw? s "="))) + (let + ((init (next!))) + (set! + with-bindings + (append with-bindings (list (list var init)))) + (parse-clause!))))) + ((= u "FOR") + (do + (next!) + (let + ((var (next!))) + (let + ((kw2 (upcase-str (lp-peek)))) + (cond + ((or (= kw2 "IN") (= kw2 "ACROSS")) + (do + (next!) + (let + ((lst-expr (next!)) + (tail-var (str "#TAIL-" var))) + (set! + for-bindings + (append for-bindings (list {:list lst-expr :tail tail-var :type ":list" :var var}))) + (parse-clause!)))) + ((= kw2 "=") + (do + (next!) + (let + ((init-expr (next!))) + (let + ((then-expr (if (kw? (lp-peek) "THEN") (do (next!) (next!)) init-expr))) + (set! + for-bindings + (append for-bindings (list {:type ":general" :then then-expr :init init-expr :var var}))) + (parse-clause!))))) + ((or (= kw2 "FROM") (= kw2 "DOWNFROM") (= kw2 "UPFROM")) + (do + (next!) + (let + ((from-expr (next!)) + (dir (if (= kw2 "DOWNFROM") ":down" ":up")) + (limit-expr nil) + (limit-type nil) + (step-expr 1)) + (let + ((lkw (upcase-str (lp-peek)))) + (when + (or + (= lkw "TO") + (= lkw "UPTO") + (= lkw "BELOW") + (= lkw "DOWNTO") + (= lkw "ABOVE")) + (do + (next!) + (set! limit-type lkw) + (set! limit-expr (next!))))) + (when + (kw? (lp-peek) "BY") + (do (next!) (set! step-expr (next!)))) + (set! + for-bindings + (append for-bindings (list {:dir dir :step step-expr :from from-expr :type ":numeric" :limit-type limit-type :var var :limit limit-expr}))) + (parse-clause!)))) + ((or (= kw2 "TO") (= kw2 "UPTO") (= kw2 "BELOW")) + (do + (next!) + (let + ((limit-expr (next!)) + (step-expr 1)) + (when + (kw? (lp-peek) "BY") + (do (next!) (set! step-expr (next!)))) + (set! + for-bindings + (append for-bindings (list {:dir ":up" :step step-expr :from 0 :type ":numeric" :limit-type kw2 :var var :limit limit-expr}))) + (parse-clause!)))) + (:else (do (parse-clause!)))))))) + ((= u "WHILE") + (do + (next!) + (set! test-forms (append test-forms (list {:expr (next!) :type ":while"}))) + (parse-clause!))) + ((= u "UNTIL") + (do + (next!) + (set! test-forms (append test-forms (list {:expr (next!) :type ":until"}))) + (parse-clause!))) + ((= u "REPEAT") + (do + (next!) + (set! repeat-count (next!)) + (set! repeat-var "#REPEAT-COUNT") + (parse-clause!))) + ((or (= u "COLLECT") (= u "COLLECTING")) + (do + (next!) + (let + ((expr (next!)) (into-var nil)) + (when + (kw? (lp-peek) "INTO") + (do (next!) (set! into-var (next!)))) + (add-accum! ":collect" expr into-var) + (parse-clause!)))) + ((or (= u "APPEND") (= u "APPENDING")) + (do + (next!) + (let + ((expr (next!)) (into-var nil)) + (when + (kw? (lp-peek) "INTO") + (do (next!) (set! into-var (next!)))) + (add-accum! ":append" expr into-var) + (parse-clause!)))) + ((or (= u "NCONC") (= u "NCONCING")) + (do + (next!) + (let + ((expr (next!)) (into-var nil)) + (when + (kw? (lp-peek) "INTO") + (do (next!) (set! into-var (next!)))) + (add-accum! ":nconc" expr into-var) + (parse-clause!)))) + ((or (= u "SUM") (= u "SUMMING")) + (do + (next!) + (let + ((expr (next!)) (into-var nil)) + (when + (kw? (lp-peek) "INTO") + (do (next!) (set! into-var (next!)))) + (add-accum! ":sum" expr into-var) + (parse-clause!)))) + ((or (= u "COUNT") (= u "COUNTING")) + (do + (next!) + (let + ((expr (next!)) (into-var nil)) + (when + (kw? (lp-peek) "INTO") + (do (next!) (set! into-var (next!)))) + (add-accum! ":count" expr into-var) + (parse-clause!)))) + ((or (= u "MAXIMIZE") (= u "MAXIMIZING")) + (do + (next!) + (let + ((expr (next!)) (into-var nil)) + (when + (kw? (lp-peek) "INTO") + (do (next!) (set! into-var (next!)))) + (add-accum! ":maximize" expr into-var) + (parse-clause!)))) + ((or (= u "MINIMIZE") (= u "MINIMIZING")) + (do + (next!) + (let + ((expr (next!)) (into-var nil)) + (when + (kw? (lp-peek) "INTO") + (do (next!) (set! into-var (next!)))) + (add-accum! ":minimize" expr into-var) + (parse-clause!)))) + ((= u "DO") + (do + (next!) + (define + (loop-kw? s) + (let + ((us (upcase-str s))) + (some + (fn (k) (= us k)) + (list + "FOR" + "WITH" + "WHILE" + "UNTIL" + "REPEAT" + "COLLECT" + "COLLECTING" + "APPEND" + "APPENDING" + "NCONC" + "NCONCING" + "SUM" + "SUMMING" + "COUNT" + "COUNTING" + "MAXIMIZE" + "MAXIMIZING" + "MINIMIZE" + "MINIMIZING" + "DO" + "WHEN" + "IF" + "UNLESS" + "FINALLY" + "ALWAYS" + "NEVER" + "THEREIS" + "RETURN" + "NAMED")))) + (define + (collect-do-forms!) + (if + (or (nil? (lp-peek)) (loop-kw? (lp-peek))) + nil + (do + (set! + body-forms + (append body-forms (list (next!)))) + (collect-do-forms!)))) + (collect-do-forms!) + (parse-clause!))) + ((or (= u "WHEN") (= u "IF")) + (do + (next!) + (let + ((cond-expr (next!)) + (body-start (len body-forms))) + (parse-clause!) + ;; wrap forms added since body-start in (WHEN cond ...) + (when (> (len body-forms) body-start) + (let ((added (list (nth body-forms body-start)))) + (set! body-forms + (append + (if (> body-start 0) + (list (nth body-forms (- body-start 1))) + (list)) + (list (list "WHEN" cond-expr (first added))))) + nil))))) + ((= u "UNLESS") + (do + (next!) + (let + ((cond-expr (next!)) + (body-start (len body-forms))) + (parse-clause!) + (when (> (len body-forms) body-start) + (let ((added (list (nth body-forms body-start)))) + (set! body-forms + (append + (if (> body-start 0) + (list (nth body-forms (- body-start 1))) + (list)) + (list (list "UNLESS" cond-expr (first added))))) + nil))))) + ((= u "ALWAYS") + (do (next!) (set! termination {:expr (next!) :type ":always"}) (parse-clause!))) + ((= u "NEVER") + (do (next!) (set! termination {:expr (next!) :type ":never"}) (parse-clause!))) + ((= u "THEREIS") + (do (next!) (set! termination {:expr (next!) :type ":thereis"}) (parse-clause!))) + ((= u "RETURN") + (do (next!) (set! return-expr (next!)) (parse-clause!))) + ((= u "FINALLY") + (do + (next!) + (define + (collect-finally!) + (if + (nil? (lp-peek)) + nil + (do + (set! + finally-forms + (append finally-forms (list (next!)))) + (collect-finally!)))) + (collect-finally!) + (parse-clause!))) + (:else + (do + (set! body-forms (append body-forms (list (next!)))) + (parse-clause!))))))))) + (parse-clause!) + (define let-bindings (list)) + (for-each + (fn (wb) (set! let-bindings (append let-bindings (list wb)))) + with-bindings) + (for-each + (fn + (v) + (set! + let-bindings + (append let-bindings (list (list v (get accum-vars v)))))) + (keys accum-vars)) + (when + (not (nil? repeat-var)) + (set! + let-bindings + (append let-bindings (list (list repeat-var repeat-count))))) + (for-each + (fn + (fb) + (let + ((type (get fb "type"))) + (cond + ((= type ":list") + (do + (set! + let-bindings + (append + let-bindings + (list (list (get fb "tail") (get fb "list"))) + (list + (list + (get fb "var") + (list + "IF" + (list "CONSP" (get fb "tail")) + (list "CAR" (get fb "tail")) + nil))))) + nil)) + ((= type ":numeric") + (set! + let-bindings + (append + let-bindings + (list (list (get fb "var") (get fb "from")))))) + ((= type ":general") + (set! + let-bindings + (append + let-bindings + (list (list (get fb "var") (get fb "init")))))) + (:else nil)))) + for-bindings) + (define all-tests (list)) + (when + (not (nil? repeat-var)) + (set! + all-tests + (append + all-tests + (list + (list + "WHEN" + (list "<=" repeat-var 0) + (list "RETURN-FROM" block-name (if (nil? result-var) nil result-var)))))) + (set! + body-forms + (append + (list (list "SETQ" repeat-var (list "-" repeat-var 1))) + body-forms))) + (for-each + (fn + (fb) + (when + (= (get fb "type") ":list") + (let + ((tvar (get fb "tail")) (var (get fb "var"))) + (set! + all-tests + (append + all-tests + (list + (list + "WHEN" + (list "NULL" tvar) + (list + "RETURN-FROM" + block-name + (if (nil? result-var) nil result-var)))))) + (set! + body-forms + (append + body-forms + (list + (list "SETQ" tvar (list "CDR" tvar)) + (list + "SETQ" + var + (list "IF" (list "CONSP" tvar) (list "CAR" tvar) nil)))))))) + for-bindings) + (for-each + (fn + (fb) + (when + (= (get fb "type") ":numeric") + (let + ((var (get fb "var")) + (dir (get fb "dir")) + (lim (get fb "limit")) + (ltype (get fb "limit-type")) + (step (get fb "step"))) + (when + (not (nil? lim)) + (let + ((test-op (cond ((or (= ltype "BELOW") (= ltype "ABOVE")) (if (= dir ":up") ">=" "<=")) ((or (= ltype "TO") (= ltype "UPTO")) ">") ((= ltype "DOWNTO") "<") (:else (if (= dir ":up") ">" "<"))))) + (set! + all-tests + (append + all-tests + (list + (list + "WHEN" + (list test-op var lim) + (list + "RETURN-FROM" + block-name + (if (nil? result-var) nil result-var)))))))) + (let + ((step-op (if (or (= dir ":down") (= ltype "DOWNTO") (= ltype "ABOVE")) "-" "+"))) + (set! + body-forms + (append + body-forms + (list (list "SETQ" var (list step-op var step))))))))) + for-bindings) + (for-each + (fn + (fb) + (when + (= (get fb "type") ":general") + (set! + body-forms + (append + body-forms + (list (list "SETQ" (get fb "var") (get fb "then"))))))) + for-bindings) + (for-each + (fn + (t) + (let + ((type (get t "type")) (expr (get t "expr"))) + (if + (= type ":while") + (set! + all-tests + (append + all-tests + (list + (list + "WHEN" + (list "NOT" expr) + (list + "RETURN-FROM" + block-name + (if (nil? result-var) nil result-var)))))) + (set! + all-tests + (append + all-tests + (list + (list + "WHEN" + expr + (list + "RETURN-FROM" + block-name + (if (nil? result-var) nil result-var))))))))) + test-forms) + (when + (not (nil? termination)) + (let + ((type (get termination "type")) (expr (get termination "expr"))) + (cond + ((= type ":always") + (set! + body-forms + (append + body-forms + (list + (list "UNLESS" expr (list "RETURN-FROM" block-name false))))) + (set! return-expr true)) + ((= type ":never") + (set! + body-forms + (append + body-forms + (list + (list "WHEN" expr (list "RETURN-FROM" block-name false))))) + (set! return-expr true)) + ((= type ":thereis") + (set! + body-forms + (append + body-forms + (list + (list "WHEN" expr (list "RETURN-FROM" block-name expr))))))))) + (define tag "#LOOP-START") + (define + inner-body + (append (list tag) all-tests body-forms (list (list "GO" tag)))) + (define + result-form + (cond + ((not (nil? return-expr)) return-expr) + ((not (nil? result-var)) result-var) + (:else nil))) + (define + full-body + (if + (= (len let-bindings) 0) + (append + (list "PROGN") + (list (append (list "TAGBODY") inner-body)) + finally-forms + (list result-form)) + (list + "LET*" + let-bindings + (append (list "TAGBODY") inner-body) + (append (list "PROGN") finally-forms (list result-form))))) + (list "BLOCK" block-name full-body))) + +;; ── Install LOOP as a CL macro ──────────────────────────────────────────── +;; +;; (loop ...) — the form arrives with head "LOOP" and rest = clauses. +;; The macro fn receives the full form. + +(dict-set! + cl-macro-registry + "LOOP" + (fn (form env) (cl-loop-parse (rest form)))) diff --git a/lib/common-lisp/parser.sx b/lib/common-lisp/parser.sx new file mode 100644 index 00000000..df2c3c85 --- /dev/null +++ b/lib/common-lisp/parser.sx @@ -0,0 +1,377 @@ +;; Common Lisp reader — converts token stream to CL AST forms. +;; +;; Depends on: lib/common-lisp/reader.sx (cl-tokenize) +;; +;; AST representation: +;; integer/float → SX number (or {:cl-type "float"/:ratio ...}) +;; string "hello" → {:cl-type "string" :value "hello"} +;; symbol FOO → SX string "FOO" (upcase) +;; symbol NIL → nil +;; symbol T → true +;; :keyword → {:cl-type "keyword" :name "FOO"} +;; #\char → {:cl-type "char" :value "a"} +;; #:uninterned → {:cl-type "uninterned" :name "FOO"} +;; ratio 1/3 → {:cl-type "ratio" :value "1/3"} +;; float 3.14 → {:cl-type "float" :value "3.14"} +;; proper list (a b c) → SX list (a b c) +;; dotted pair (a . b) → {:cl-type "cons" :car a :cdr b} +;; vector #(a b) → {:cl-type "vector" :elements (list a b)} +;; 'x → ("QUOTE" x) +;; `x → ("QUASIQUOTE" x) +;; ,x → ("UNQUOTE" x) +;; ,@x → ("UNQUOTE-SPLICING" x) +;; #'x → ("FUNCTION" x) +;; +;; Public API: +;; (cl-read src) — parse first form from string, return form +;; (cl-read-all src) — parse all top-level forms, return list + +;; ── number conversion ───────────────────────────────────────────── + +(define + cl-hex-val + (fn + (c) + (let + ((o (cl-ord c))) + (cond + ((and (>= o 48) (<= o 57)) (- o 48)) + ((and (>= o 65) (<= o 70)) (+ 10 (- o 65))) + ((and (>= o 97) (<= o 102)) (+ 10 (- o 97))) + (:else 0))))) + +(define + cl-parse-radix-str + (fn + (s radix start) + (let + ((n (string-length s)) (i start) (acc 0)) + (define + loop + (fn + () + (when + (< i n) + (do + (set! acc (+ (* acc radix) (cl-hex-val (substring s i (+ i 1))))) + (set! i (+ i 1)) + (loop))))) + (loop) + acc))) + +(define + cl-convert-integer + (fn + (s) + (let + ((n (string-length s)) (neg false)) + (cond + ((and (> n 2) (= (substring s 0 1) "#")) + (let + ((letter (downcase (substring s 1 2)))) + (cond + ((= letter "x") (cl-parse-radix-str s 16 2)) + ((= letter "b") (cl-parse-radix-str s 2 2)) + ((= letter "o") (cl-parse-radix-str s 8 2)) + (:else (parse-int s 0))))) + (:else (parse-int s 0)))))) + +;; ── reader ──────────────────────────────────────────────────────── + +;; Read one form from token list. +;; Returns {:form F :rest remaining-toks} or {:form nil :rest toks :eof true} +(define + cl-read-form + (fn + (toks) + (if + (not toks) + {:form nil :rest toks :eof true} + (let + ((tok (nth toks 0)) (nxt (rest toks))) + (let + ((type (get tok "type")) (val (get tok "value"))) + (cond + ((= type "eof") {:form nil :rest toks :eof true}) + ((= type "integer") {:form (cl-convert-integer val) :rest nxt}) + ((= type "float") {:form {:cl-type "float" :value val} :rest nxt}) + ((= type "ratio") {:form {:cl-type "ratio" :value val} :rest nxt}) + ((= type "string") {:form {:cl-type "string" :value val} :rest nxt}) + ((= type "char") {:form {:cl-type "char" :value val} :rest nxt}) + ((= type "keyword") {:form {:cl-type "keyword" :name val} :rest nxt}) + ((= type "uninterned") {:form {:cl-type "uninterned" :name val} :rest nxt}) + ((= type "symbol") + (cond + ((= val "NIL") {:form nil :rest nxt}) + ((= val "T") {:form true :rest nxt}) + (:else {:form val :rest nxt}))) + ;; list forms + ((= type "lparen") (cl-read-list nxt)) + ((= type "hash-paren") (cl-read-vector nxt)) + ;; reader macros that wrap the next form + ((= type "quote") (cl-read-wrap "QUOTE" nxt)) + ((= type "backquote") (cl-read-wrap "QUASIQUOTE" nxt)) + ((= type "comma") (cl-read-wrap "UNQUOTE" nxt)) + ((= type "comma-at") (cl-read-wrap "UNQUOTE-SPLICING" nxt)) + ((= type "hash-quote") (cl-read-wrap "FUNCTION" nxt)) + ;; skip unrecognised tokens + (:else (cl-read-form nxt)))))))) + +;; Wrap next form in a list: (name form) +(define + cl-read-wrap + (fn + (name toks) + (let + ((inner (cl-read-form toks))) + {:form (list name (get inner "form")) :rest (get inner "rest")}))) + +;; Read list forms until ')'; handles dotted pair (a . b) +;; Called after consuming '(' +(define + cl-read-list + (fn + (toks) + (let + ((result (cl-read-list-items toks (list)))) + {:form (get result "items") :rest (get result "rest")}))) + +(define + cl-read-list-items + (fn + (toks acc) + (if + (not toks) + {:items acc :rest toks} + (let + ((tok (nth toks 0))) + (let + ((type (get tok "type"))) + (cond + ((= type "eof") {:items acc :rest toks}) + ((= type "rparen") {:items acc :rest (rest toks)}) + ;; dotted pair: read one more form then expect ')' + ((= type "dot") + (let + ((cdr-result (cl-read-form (rest toks)))) + (let + ((cdr-form (get cdr-result "form")) + (after-cdr (get cdr-result "rest"))) + ;; skip the closing ')' + (let + ((close (if after-cdr (nth after-cdr 0) nil))) + (let + ((remaining + (if + (and close (= (get close "type") "rparen")) + (rest after-cdr) + after-cdr))) + ;; build dotted structure + (let + ((dotted (cl-build-dotted acc cdr-form))) + {:items dotted :rest remaining})))))) + (:else + (let + ((item (cl-read-form toks))) + (cl-read-list-items + (get item "rest") + (concat acc (list (get item "form")))))))))))) + +;; Build dotted form: (a b . c) → ((DOTTED a b) . c) style +;; In CL (a b c . d) means a proper dotted structure. +;; We represent it as {:cl-type "cons" :car a :cdr (list->dotted b c d)} +(define + cl-build-dotted + (fn + (head-items tail) + (if + (= (len head-items) 0) + tail + (if + (= (len head-items) 1) + {:cl-type "cons" :car (nth head-items 0) :cdr tail} + (let + ((last-item (nth head-items (- (len head-items) 1))) + (but-last (slice head-items 0 (- (len head-items) 1)))) + {:cl-type "cons" + :car (cl-build-dotted but-last (list last-item)) + :cdr tail}))))) + +;; Read vector #(…) elements until ')' +(define + cl-read-vector + (fn + (toks) + (let + ((result (cl-read-vector-items toks (list)))) + {:form {:cl-type "vector" :elements (get result "items")} :rest (get result "rest")}))) + +(define + cl-read-vector-items + (fn + (toks acc) + (if + (not toks) + {:items acc :rest toks} + (let + ((tok (nth toks 0))) + (let + ((type (get tok "type"))) + (cond + ((= type "eof") {:items acc :rest toks}) + ((= type "rparen") {:items acc :rest (rest toks)}) + (:else + (let + ((item (cl-read-form toks))) + (cl-read-vector-items + (get item "rest") + (concat acc (list (get item "form")))))))))))) + +;; ── lambda-list parser ─────────────────────────────────────────── +;; +;; (cl-parse-lambda-list forms) — parse a list of CL forms (already read) +;; into a structured dict: +;; {:required (list sym ...) +;; :optional (list {:name N :default D :supplied S} ...) +;; :rest nil | "SYM" +;; :key (list {:name N :keyword K :default D :supplied S} ...) +;; :allow-other-keys false | true +;; :aux (list {:name N :init I} ...)} +;; +;; Symbols arrive as SX strings (upcase). &-markers are strings like "&OPTIONAL". +;; Key params: keyword is the upcase name string; caller uses it as :keyword. +;; Supplied-p: nil when absent. + +(define + cl-parse-opt-spec + (fn + (spec) + (if + (list? spec) + {:name (nth spec 0) + :default (if (> (len spec) 1) (nth spec 1) nil) + :supplied (if (> (len spec) 2) (nth spec 2) nil)} + {:name spec :default nil :supplied nil}))) + +(define + cl-parse-key-spec + (fn + (spec) + (if + (list? spec) + (let + ((first (nth spec 0))) + (if + (list? first) + ;; ((:keyword var) default supplied-p) + {:name (nth first 1) + :keyword (get first "name") + :default (if (> (len spec) 1) (nth spec 1) nil) + :supplied (if (> (len spec) 2) (nth spec 2) nil)} + ;; (var default supplied-p) + {:name first + :keyword first + :default (if (> (len spec) 1) (nth spec 1) nil) + :supplied (if (> (len spec) 2) (nth spec 2) nil)})) + {:name spec :keyword spec :default nil :supplied nil}))) + +(define + cl-parse-aux-spec + (fn + (spec) + (if + (list? spec) + {:name (nth spec 0) :init (if (> (len spec) 1) (nth spec 1) nil)} + {:name spec :init nil}))) + +(define + cl-parse-lambda-list + (fn + (forms) + (let + ((state "required") + (required (list)) + (optional (list)) + (rest-name nil) + (key (list)) + (allow-other-keys false) + (aux (list))) + + (define + scan + (fn + (items) + (when + (> (len items) 0) + (let + ((item (nth items 0)) (tail (rest items))) + (cond + ((= item "&OPTIONAL") + (do (set! state "optional") (scan tail))) + ((= item "&REST") + (do (set! state "rest") (scan tail))) + ((= item "&BODY") + (do (set! state "rest") (scan tail))) + ((= item "&KEY") + (do (set! state "key") (scan tail))) + ((= item "&AUX") + (do (set! state "aux") (scan tail))) + ((= item "&ALLOW-OTHER-KEYS") + (do (set! allow-other-keys true) (scan tail))) + ((= state "required") + (do (append! required item) (scan tail))) + ((= state "optional") + (do (append! optional (cl-parse-opt-spec item)) (scan tail))) + ((= state "rest") + (do (set! rest-name item) (set! state "done") (scan tail))) + ((= state "key") + (do (append! key (cl-parse-key-spec item)) (scan tail))) + ((= state "aux") + (do (append! aux (cl-parse-aux-spec item)) (scan tail))) + (:else (scan tail))))))) + + (scan forms) + {:required required + :optional optional + :rest rest-name + :key key + :allow-other-keys allow-other-keys + :aux aux}))) + +;; Convenience: parse lambda list from a CL source string +(define + cl-parse-lambda-list-str + (fn + (src) + (cl-parse-lambda-list (cl-read src)))) + +;; ── public API ──────────────────────────────────────────────────── + +(define + cl-read + (fn + (src) + (let + ((toks (cl-tokenize src))) + (get (cl-read-form toks) "form")))) + +(define + cl-read-all + (fn + (src) + (let + ((toks (cl-tokenize src))) + (define + loop + (fn + (toks acc) + (if + (or (not toks) (= (get (nth toks 0) "type") "eof")) + acc + (let + ((result (cl-read-form toks))) + (if + (get result "eof") + acc + (loop (get result "rest") (concat acc (list (get result "form"))))))))) + (loop toks (list))))) diff --git a/lib/common-lisp/reader.sx b/lib/common-lisp/reader.sx new file mode 100644 index 00000000..183969bf --- /dev/null +++ b/lib/common-lisp/reader.sx @@ -0,0 +1,381 @@ +;; Common Lisp tokenizer +;; +;; Tokens: {:type T :value V :pos P} +;; +;; Types: +;; "symbol" — FOO, PKG:SYM, PKG::SYM, T, NIL (upcase) +;; "keyword" — :foo (value is upcase name without colon) +;; "integer" — 42, -5, #xFF, #b1010, #o17 (string) +;; "float" — 3.14, 1.0e10 (string) +;; "ratio" — 1/3 (string "N/D") +;; "string" — unescaped content +;; "char" — single-character string +;; "lparen" "rparen" "quote" "backquote" "comma" "comma-at" +;; "hash-quote" — #' +;; "hash-paren" — #( +;; "uninterned" — #:foo (upcase name) +;; "dot" — standalone . (dotted pair separator) +;; "eof" + +(define cl-make-tok (fn (type value pos) {:type type :value value :pos pos})) + +;; ── char ordinal table ──────────────────────────────────────────── + +(define + cl-ord-table + (let + ((t (dict)) (i 0)) + (define + cl-fill + (fn + () + (when + (< i 128) + (do + (dict-set! t (char-from-code i) i) + (set! i (+ i 1)) + (cl-fill))))) + (cl-fill) + t)) + +(define cl-ord (fn (c) (or (get cl-ord-table c) 0))) + +;; ── character predicates ────────────────────────────────────────── + +(define cl-digit? (fn (c) (and (>= (cl-ord c) 48) (<= (cl-ord c) 57)))) + +(define + cl-hex? + (fn + (c) + (or + (cl-digit? c) + (and (>= (cl-ord c) 65) (<= (cl-ord c) 70)) + (and (>= (cl-ord c) 97) (<= (cl-ord c) 102))))) + +(define cl-octal? (fn (c) (and (>= (cl-ord c) 48) (<= (cl-ord c) 55)))) + +(define cl-binary? (fn (c) (or (= c "0") (= c "1")))) + +(define cl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r")))) + +(define + cl-alpha? + (fn + (c) + (or + (and (>= (cl-ord c) 65) (<= (cl-ord c) 90)) + (and (>= (cl-ord c) 97) (<= (cl-ord c) 122))))) + +;; Characters that end a token (whitespace + terminating macro chars) +(define + cl-terminating? + (fn + (c) + (or + (cl-ws? c) + (= c "(") + (= c ")") + (= c "\"") + (= c ";") + (= c "`") + (= c ",")))) + +;; Symbol constituent: not terminating, not reader-special +(define + cl-sym-char? + (fn + (c) + (not + (or + (cl-terminating? c) + (= c "#") + (= c "|") + (= c "\\") + (= c "'"))))) + +;; ── named character table ───────────────────────────────────────── + +(define + cl-named-chars + {:space " " + :newline "\n" + :tab "\t" + :return "\r" + :backspace (char-from-code 8) + :rubout (char-from-code 127) + :delete (char-from-code 127) + :escape (char-from-code 27) + :altmode (char-from-code 27) + :null (char-from-code 0) + :nul (char-from-code 0) + :page (char-from-code 12) + :formfeed (char-from-code 12)}) + +;; ── main tokenizer ──────────────────────────────────────────────── + +(define + cl-tokenize + (fn + (src) + (let + ((pos 0) (n (string-length src)) (toks (list))) + + (define at (fn () (if (< pos n) (substring src pos (+ pos 1)) nil))) + (define peek1 (fn () (if (< (+ pos 1) n) (substring src (+ pos 1) (+ pos 2)) nil))) + (define adv (fn () (set! pos (+ pos 1)))) + + ;; Advance while predicate holds; return substring from start to end + (define + read-while + (fn + (pred) + (let + ((start pos)) + (define + rw-loop + (fn + () + (when + (and (at) (pred (at))) + (do (adv) (rw-loop))))) + (rw-loop) + (substring src start pos)))) + + (define + skip-line + (fn + () + (when + (and (at) (not (= (at) "\n"))) + (do (adv) (skip-line))))) + + (define + skip-block + (fn + (depth) + (when + (at) + (cond + ((and (= (at) "#") (= (peek1) "|")) + (do (adv) (adv) (skip-block (+ depth 1)))) + ((and (= (at) "|") (= (peek1) "#")) + (do + (adv) + (adv) + (when (> depth 1) (skip-block (- depth 1))))) + (:else (do (adv) (skip-block depth))))))) + + ;; Read string literal — called with pos just past opening " + (define + read-str + (fn + (acc) + (if + (not (at)) + acc + (cond + ((= (at) "\"") (do (adv) acc)) + ((= (at) "\\") + (do + (adv) + (let + ((e (at))) + (adv) + (read-str + (str + acc + (cond + ((= e "n") "\n") + ((= e "t") "\t") + ((= e "r") "\r") + ((= e "\"") "\"") + ((= e "\\") "\\") + (:else e))))))) + (:else + (let + ((c (at))) + (adv) + (read-str (str acc c)))))))) + + ;; Read #\ char literal — called with pos just past the backslash + (define + read-char-lit + (fn + () + (let + ((first (at))) + (adv) + (let + ((rest (if (and (at) (cl-alpha? (at))) (read-while cl-alpha?) ""))) + (if + (= rest "") + first + (let + ((name (downcase (str first rest)))) + (or (get cl-named-chars name) first))))))) + + ;; Number scanner — called with pos just past first digit(s). + ;; acc holds what was already consumed (first digit or sign+digit). + (define + scan-num + (fn + (p acc) + (let + ((more (read-while cl-digit?))) + (set! acc (str acc more)) + (cond + ;; ratio N/D + ((and (at) (= (at) "/") (peek1) (cl-digit? (peek1))) + (do + (adv) + (let + ((denom (read-while cl-digit?))) + {:type "ratio" :value (str acc "/" denom) :pos p}))) + ;; float: decimal point N.M[eE] + ((and (at) (= (at) ".") (peek1) (cl-digit? (peek1))) + (do + (adv) + (let + ((frac (read-while cl-digit?))) + (set! acc (str acc "." frac)) + (when + (and (at) (or (= (at) "e") (= (at) "E"))) + (do + (set! acc (str acc (at))) + (adv) + (when + (and (at) (or (= (at) "+") (= (at) "-"))) + (do (set! acc (str acc (at))) (adv))) + (set! acc (str acc (read-while cl-digit?))))) + {:type "float" :value acc :pos p}))) + ;; float: exponent only NeE + ((and (at) (or (= (at) "e") (= (at) "E"))) + (do + (set! acc (str acc (at))) + (adv) + (when + (and (at) (or (= (at) "+") (= (at) "-"))) + (do (set! acc (str acc (at))) (adv))) + (set! acc (str acc (read-while cl-digit?))) + {:type "float" :value acc :pos p})) + (:else {:type "integer" :value acc :pos p}))))) + + (define + read-radix + (fn + (letter p) + (let + ((pred + (cond + ((or (= letter "x") (= letter "X")) cl-hex?) + ((or (= letter "b") (= letter "B")) cl-binary?) + ((or (= letter "o") (= letter "O")) cl-octal?) + (:else cl-digit?)))) + {:type "integer" + :value (str "#" letter (read-while pred)) + :pos p}))) + + (define emit (fn (tok) (append! toks tok))) + + (define + scan + (fn + () + (when + (< pos n) + (let + ((c (at)) (p pos)) + (cond + ((cl-ws? c) (do (adv) (scan))) + ((= c ";") (do (adv) (skip-line) (scan))) + ((= c "(") (do (adv) (emit (cl-make-tok "lparen" "(" p)) (scan))) + ((= c ")") (do (adv) (emit (cl-make-tok "rparen" ")" p)) (scan))) + ((= c "'") (do (adv) (emit (cl-make-tok "quote" "'" p)) (scan))) + ((= c "`") (do (adv) (emit (cl-make-tok "backquote" "`" p)) (scan))) + ((= c ",") + (do + (adv) + (if + (= (at) "@") + (do (adv) (emit (cl-make-tok "comma-at" ",@" p))) + (emit (cl-make-tok "comma" "," p))) + (scan))) + ((= c "\"") + (do + (adv) + (emit (cl-make-tok "string" (read-str "") p)) + (scan))) + ;; :keyword + ((= c ":") + (do + (adv) + (emit (cl-make-tok "keyword" (upcase (read-while cl-sym-char?)) p)) + (scan))) + ;; dispatch macro # + ((= c "#") + (do + (adv) + (let + ((d (at))) + (cond + ((= d "'") (do (adv) (emit (cl-make-tok "hash-quote" "#'" p)) (scan))) + ((= d "(") (do (adv) (emit (cl-make-tok "hash-paren" "#(" p)) (scan))) + ((= d ":") + (do + (adv) + (emit + (cl-make-tok "uninterned" (upcase (read-while cl-sym-char?)) p)) + (scan))) + ((= d "|") (do (adv) (skip-block 1) (scan))) + ((= d "\\") + (do (adv) (emit (cl-make-tok "char" (read-char-lit) p)) (scan))) + ((or (= d "x") (= d "X")) + (do (adv) (emit (read-radix d p)) (scan))) + ((or (= d "b") (= d "B")) + (do (adv) (emit (read-radix d p)) (scan))) + ((or (= d "o") (= d "O")) + (do (adv) (emit (read-radix d p)) (scan))) + (:else (scan)))))) + ;; standalone dot, float .5, or symbol starting with dots + ((= c ".") + (do + (adv) + (cond + ((or (not (at)) (cl-terminating? (at))) + (do (emit (cl-make-tok "dot" "." p)) (scan))) + ((cl-digit? (at)) + (do + (emit + (cl-make-tok "float" (str "0." (read-while cl-digit?)) p)) + (scan))) + (:else + (do + (emit + (cl-make-tok "symbol" (upcase (str "." (read-while cl-sym-char?))) p)) + (scan)))))) + ;; sign followed by digit → number + ((and (or (= c "+") (= c "-")) (peek1) (cl-digit? (peek1))) + (do + (adv) + (let + ((first-d (at))) + (adv) + (emit (scan-num p (str c first-d)))) + (scan))) + ;; decimal digit → number + ((cl-digit? c) + (do + (adv) + (emit (scan-num p c)) + (scan))) + ;; symbol constituent (includes bare +, -, etc.) + ((cl-sym-char? c) + (do + (emit (cl-make-tok "symbol" (upcase (read-while cl-sym-char?)) p)) + (scan))) + (:else (do (adv) (scan)))))))) + + (scan) + (append! toks (cl-make-tok "eof" nil n)) + toks))) diff --git a/lib/common-lisp/runtime.sx b/lib/common-lisp/runtime.sx new file mode 100644 index 00000000..73dac5b0 --- /dev/null +++ b/lib/common-lisp/runtime.sx @@ -0,0 +1,724 @@ +;; lib/common-lisp/runtime.sx — CL built-ins + condition system on SX +;; +;; Section 1-9: Type predicates, arithmetic, characters, strings, gensym, +;; multiple values, sets, radix formatting, list utilities. +;; Section 10: Condition system (define-condition, signal/error/warn, +;; handler-bind, handler-case, restart-case, invoke-restart). +;; +;; Primitives used from spec: +;; char/char->integer/integer->char/char-upcase/char-downcase +;; format gensym rational/rational? make-set/set-member?/etc +;; modulo/remainder/quotient/gcd/lcm/expt number->string + +;; --------------------------------------------------------------------------- +;; 1. Type predicates +;; --------------------------------------------------------------------------- + +(define (cl-null? x) (= x nil)) +(define (cl-consp? x) (and (list? x) (not (cl-empty? x)))) +(define (cl-listp? x) (or (cl-empty? x) (list? x))) +(define (cl-atom? x) (not (cl-consp? x))) + +(define + (cl-numberp? x) + (let ((t (type-of x))) (or (= t "number") (= t "rational")))) + +(define cl-integerp? integer?) +(define cl-floatp? float?) +(define cl-rationalp? rational?) + +(define (cl-realp? x) (or (integer? x) (float? x) (rational? x))) + +(define cl-characterp? char?) +(define cl-stringp? (fn (x) (= (type-of x) "string"))) +(define cl-symbolp? (fn (x) (= (type-of x) "symbol"))) +(define cl-keywordp? (fn (x) (= (type-of x) "keyword"))) + +(define + (cl-functionp? x) + (let + ((t (type-of x))) + (or + (= t "function") + (= t "lambda") + (= t "native-fn") + (= t "component")))) + +(define cl-vectorp? vector?) +(define cl-arrayp? vector?) + +;; sx_server: (rest (list x)) returns () not nil — cl-empty? handles both +(define + (cl-empty? x) + (or (nil? x) (and (list? x) (= (len x) 0)))) + +;; --------------------------------------------------------------------------- +;; 2. Arithmetic — thin aliases to spec primitives +;; --------------------------------------------------------------------------- + +(define cl-mod modulo) +(define cl-rem remainder) +(define cl-gcd gcd) +(define cl-lcm lcm) +(define cl-expt expt) +(define cl-floor floor) +(define cl-ceiling ceil) +(define cl-truncate truncate) +(define cl-round round) +(define cl-abs (fn (x) (if (< x 0) (- 0 x) x))) +(define cl-min (fn (a b) (if (< a b) a b))) +(define cl-max (fn (a b) (if (> a b) a b))) +(define cl-quotient quotient) + +(define + (cl-signum x) + (cond + ((> x 0) 1) + ((< x 0) -1) + (else 0))) + +(define (cl-evenp? n) (= (modulo n 2) 0)) +(define (cl-oddp? n) (= (modulo n 2) 1)) +(define (cl-zerop? n) (= n 0)) +(define (cl-plusp? n) (> n 0)) +(define (cl-minusp? n) (< n 0)) + +;; --------------------------------------------------------------------------- +;; 3. Character functions — alias spec char primitives + CL name mapping +;; --------------------------------------------------------------------------- + +(define cl-char->integer char->integer) +(define cl-integer->char integer->char) +(define cl-char-upcase char-upcase) +(define cl-char-downcase char-downcase) +(define cl-char-code char->integer) +(define cl-code-char integer->char) + +(define cl-char=? char=?) +(define cl-char? char>?) +(define cl-char<=? char<=?) +(define cl-char>=? char>=?) +(define cl-char-ci=? char-ci=?) +(define cl-char-ci? char-ci>?) + +;; Inline predicates — char-alphabetic?/char-numeric? unreliable in sx_server +(define + (cl-alpha-char-p c) + (let + ((n (char->integer c))) + (or + (and (>= n 65) (<= n 90)) + (and (>= n 97) (<= n 122))))) + +(define + (cl-digit-char-p c) + (let ((n (char->integer c))) (and (>= n 48) (<= n 57)))) + +(define + (cl-alphanumericp c) + (let + ((n (char->integer c))) + (or + (and (>= n 48) (<= n 57)) + (and (>= n 65) (<= n 90)) + (and (>= n 97) (<= n 122))))) + +(define + (cl-upper-case-p c) + (let ((n (char->integer c))) (and (>= n 65) (<= n 90)))) + +(define + (cl-lower-case-p c) + (let ((n (char->integer c))) (and (>= n 97) (<= n 122)))) + +;; Named character constants +(define cl-char-space (integer->char 32)) +(define cl-char-newline (integer->char 10)) +(define cl-char-tab (integer->char 9)) +(define cl-char-backspace (integer->char 8)) +(define cl-char-return (integer->char 13)) +(define cl-char-null (integer->char 0)) +(define cl-char-escape (integer->char 27)) +(define cl-char-delete (integer->char 127)) + +;; --------------------------------------------------------------------------- +;; 4. String + IO — use spec format and ports +;; --------------------------------------------------------------------------- + +;; CL format: (cl-format nil "~a ~a" x y) — nil destination means return string +(define + (cl-format dest template &rest args) + (let ((s (apply format (cons template args)))) (if (= dest nil) s s))) + +(define cl-write-to-string write-to-string) +(define cl-princ-to-string display-to-string) + +;; CL read-from-string: parse value from a string using SX port +(define + (cl-read-from-string s) + (let ((p (open-input-string s))) (read p))) + +;; String stream (output) +(define cl-make-string-output-stream open-output-string) +(define cl-get-output-stream-string get-output-string) + +;; String stream (input) +(define cl-make-string-input-stream open-input-string) + +;; --------------------------------------------------------------------------- +;; 5. Gensym +;; --------------------------------------------------------------------------- + +(define cl-gensym gensym) +(define cl-gentemp gensym) + +;; --------------------------------------------------------------------------- +;; 6. Multiple values (CL: values / nth-value) +;; --------------------------------------------------------------------------- + +(define (cl-values &rest args) {:_values true :_list args}) + +(define + (cl-call-with-values producer consumer) + (let + ((mv (producer))) + (if + (and (dict? mv) (get mv :_values)) + (apply consumer (get mv :_list)) + (consumer mv)))) + +(define + (cl-nth-value n mv) + (cond + ((and (dict? mv) (get mv :_values)) + (let + ((lst (get mv :_list))) + (if (>= n (len lst)) nil (nth lst n)))) + ((= n 0) mv) + (else nil))) + +;; --------------------------------------------------------------------------- +;; 7. Sets (CL: adjoin / member / union / intersection / set-difference) +;; --------------------------------------------------------------------------- + +(define cl-make-set make-set) +(define cl-set? set?) +(define cl-set-add set-add!) +(define cl-set-memberp set-member?) +(define cl-set-remove set-remove!) +(define cl-set-union set-union) +(define cl-set-intersect set-intersection) +(define cl-set-difference set-difference) +(define cl-list->set list->set) +(define cl-set->list set->list) + +;; CL: (member item list) — returns tail starting at item, or nil +(define + (cl-member item lst) + (cond + ((cl-empty? lst) nil) + ((equal? item (first lst)) lst) + (else (cl-member item (rest lst))))) + +;; CL: (adjoin item list) — cons only if not already present +(define (cl-adjoin item lst) (if (cl-member item lst) lst (cons item lst))) + +;; --------------------------------------------------------------------------- +;; 8. Radix formatting (CL: (write-to-string n :base radix)) +;; --------------------------------------------------------------------------- + +(define (cl-integer-to-string n radix) (number->string n radix)) + +(define (cl-string-to-integer s radix) (string->number s radix)) + +;; CL ~R directive helpers +(define (cl-format-binary n) (number->string n 2)) +(define (cl-format-octal n) (number->string n 8)) +(define (cl-format-hex n) (number->string n 16)) +(define (cl-format-decimal n) (number->string n 10)) + +;; --------------------------------------------------------------------------- +;; 9. List utilities — cl-empty? guards against () from rest +;; --------------------------------------------------------------------------- + +(define + (cl-last lst) + (cond + ((cl-empty? lst) nil) + ((cl-empty? (rest lst)) lst) + (else (cl-last (rest lst))))) + +(define + (cl-butlast lst) + (if + (or (cl-empty? lst) (cl-empty? (rest lst))) + nil + (cons (first lst) (cl-butlast (rest lst))))) + +(define + (cl-nthcdr n lst) + (if (= n 0) lst (cl-nthcdr (- n 1) (rest lst)))) + +(define (cl-nth n lst) (first (cl-nthcdr n lst))) + +(define (cl-list-length lst) (len lst)) + +(define + (cl-copy-list lst) + (if (cl-empty? lst) nil (cons (first lst) (cl-copy-list (rest lst))))) + +(define + (cl-flatten lst) + (cond + ((cl-empty? lst) nil) + ((list? (first lst)) + (append (cl-flatten (first lst)) (cl-flatten (rest lst)))) + (else (cons (first lst) (cl-flatten (rest lst)))))) + +;; CL: (assoc key alist) — returns matching pair or nil +(define + (cl-assoc key alist) + (cond + ((cl-empty? alist) nil) + ((equal? key (first (first alist))) (first alist)) + (else (cl-assoc key (rest alist))))) + +;; CL: (rassoc val alist) — reverse assoc (match on second element) +(define + (cl-rassoc val alist) + (cond + ((cl-empty? alist) nil) + ((equal? val (first (rest (first alist)))) (first alist)) + (else (cl-rassoc val (rest alist))))) + +;; CL: (getf plist key) — property list lookup +(define + (cl-getf plist key) + (cond + ((or (cl-empty? plist) (cl-empty? (rest plist))) nil) + ((equal? (first plist) key) (first (rest plist))) + (else (cl-getf (rest (rest plist)) key)))) + +;; --------------------------------------------------------------------------- +;; 10. Condition system (Phase 3) +;; +;; Condition objects: +;; {:cl-type "cl-condition" :class "NAME" :slots {slot-name val ...}} +;; +;; The built-in handler-bind / restart-case expect LITERAL handler specs in +;; source (they operate on the raw AST), so we implement our own handler and +;; restart stacks as mutable SX globals. +;; --------------------------------------------------------------------------- + +;; ── condition class registry ─────────────────────────────────────────────── +;; +;; Populated at load time with all ANSI standard condition types. +;; Also mutated by cl-define-condition. + +(define + cl-condition-classes + (dict + "condition" + {:parents (list) :slots (list) :name "condition"} + "serious-condition" + {:parents (list "condition") :slots (list) :name "serious-condition"} + "error" + {:parents (list "serious-condition") :slots (list) :name "error"} + "warning" + {:parents (list "condition") :slots (list) :name "warning"} + "simple-condition" + {:parents (list "condition") :slots (list "format-control" "format-arguments") :name "simple-condition"} + "simple-error" + {:parents (list "error" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-error"} + "simple-warning" + {:parents (list "warning" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-warning"} + "type-error" + {:parents (list "error") :slots (list "datum" "expected-type") :name "type-error"} + "arithmetic-error" + {:parents (list "error") :slots (list "operation" "operands") :name "arithmetic-error"} + "division-by-zero" + {:parents (list "arithmetic-error") :slots (list) :name "division-by-zero"} + "cell-error" + {:parents (list "error") :slots (list "name") :name "cell-error"} + "unbound-variable" + {:parents (list "cell-error") :slots (list) :name "unbound-variable"} + "undefined-function" + {:parents (list "cell-error") :slots (list) :name "undefined-function"} + "program-error" + {:parents (list "error") :slots (list) :name "program-error"} + "storage-condition" + {:parents (list "serious-condition") :slots (list) :name "storage-condition"})) + +;; ── condition predicates ─────────────────────────────────────────────────── + +(define + cl-condition? + (fn (x) (and (dict? x) (= (get x "cl-type") "cl-condition")))) + +;; cl-condition-of-type? walks the class hierarchy. +;; We capture cl-condition-classes at define time via let to avoid +;; free-variable scoping issues at call time. + +(define + cl-condition-of-type? + (let + ((classes cl-condition-classes)) + (fn + (c type-name) + (if + (not (cl-condition? c)) + false + (let + ((class-name (get c "class"))) + (define + check + (fn + (n) + (if + (= n type-name) + true + (let + ((entry (get classes n))) + (if + (nil? entry) + false + (some (fn (p) (check p)) (get entry "parents"))))))) + (check class-name)))))) + +;; ── condition constructors ───────────────────────────────────────────────── + +;; cl-define-condition registers a new condition class. +;; name: string (condition class name) +;; parents: list of strings (parent class names) +;; slot-names: list of strings + +(define + cl-define-condition + (fn + (name parents slot-names) + (begin (dict-set! cl-condition-classes name {:parents parents :slots slot-names :name name}) name))) + +;; cl-make-condition constructs a condition object. +;; Keyword args (alternating slot-name/value pairs) populate the slots dict. + +(define + cl-make-condition + (fn + (name &rest kw-args) + (let + ((slots (dict))) + (define + fill + (fn + (args) + (when + (>= (len args) 2) + (begin + (dict-set! slots (first args) (first (rest args))) + (fill (rest (rest args))))))) + (fill kw-args) + {:cl-type "cl-condition" :slots slots :class name}))) + +;; ── condition accessors ──────────────────────────────────────────────────── + +(define + cl-condition-slot + (fn + (c slot-name) + (if (cl-condition? c) (get (get c "slots") slot-name) nil))) + +(define + cl-condition-message + (fn + (c) + (if + (not (cl-condition? c)) + (str c) + (let + ((slots (get c "slots"))) + (or + (get slots "message") + (get slots "format-control") + (str "Condition: " (get c "class"))))))) + +(define + cl-simple-condition-format-control + (fn (c) (cl-condition-slot c "format-control"))) + +(define + cl-simple-condition-format-arguments + (fn (c) (cl-condition-slot c "format-arguments"))) + +(define cl-type-error-datum (fn (c) (cl-condition-slot c "datum"))) + +(define + cl-type-error-expected-type + (fn (c) (cl-condition-slot c "expected-type"))) + +(define + cl-arithmetic-error-operation + (fn (c) (cl-condition-slot c "operation"))) + +(define + cl-arithmetic-error-operands + (fn (c) (cl-condition-slot c "operands"))) + +;; ── mutable handler + restart stacks ────────────────────────────────────── +;; +;; Handler entry: {:type "type-name" :fn (fn (condition) result)} +;; Restart entry: {:name "restart-name" :fn (fn (&optional arg) result) :escape k} +;; +;; New handlers are prepended (checked first = most recent handler wins). + +(define cl-handler-stack (list)) +(define cl-restart-stack (list)) + +(define + cl-push-handlers + (fn (entries) (set! cl-handler-stack (append entries cl-handler-stack)))) + +(define + cl-pop-handlers + (fn + (n) + (set! cl-handler-stack (slice cl-handler-stack n (len cl-handler-stack))))) + +(define + cl-push-restarts + (fn (entries) (set! cl-restart-stack (append entries cl-restart-stack)))) + +(define + cl-pop-restarts + (fn + (n) + (set! cl-restart-stack (slice cl-restart-stack n (len cl-restart-stack))))) + +;; ── *debugger-hook* + invoke-debugger ──────────────────────────────────── +;; +;; cl-debugger-hook: called when an error propagates with no handler. +;; Signature: (fn (condition hook) result). The hook arg is itself +;; (so the hook can rebind it to nil to prevent recursion). +;; nil = use default (re-raise as host error). + +(define cl-debugger-hook nil) + +(define cl-invoke-debugger + (fn (c) + (if (nil? cl-debugger-hook) + (error (str "Debugger: " (cl-condition-message c))) + (let ((hook cl-debugger-hook)) + (set! cl-debugger-hook nil) + (let ((result (hook c hook))) + (set! cl-debugger-hook hook) + result))))) + +;; ── *break-on-signals* ──────────────────────────────────────────────────── +;; +;; When set to a type name string, cl-signal invokes the debugger hook +;; before walking handlers if the condition is of that type. +;; nil = disabled (ANSI default). + +(define cl-break-on-signals nil) + +;; ── invoke-restart-interactively ────────────────────────────────────────── +;; +;; Like invoke-restart but calls the restart's fn with no arguments +;; (real CL would prompt the user for each arg via :interactive). + +(define cl-invoke-restart-interactively + (fn (name) + (let ((entry (cl-find-restart-entry name cl-restart-stack))) + (if (nil? entry) + (error (str "No active restart: " name)) + (let ((restart-fn (get entry "fn")) + (escape (get entry "escape"))) + (escape (restart-fn))))))) + +;; ── cl-signal (non-unwinding) ───────────────────────────────────────────── +;; +;; Walks cl-handler-stack; for each matching entry, calls the handler fn. +;; Handlers return normally — signal continues to the next matching handler. + +(define + cl-signal-obj + (fn + (obj stack) + (if + (empty? stack) + nil + (let + ((entry (first stack))) + (if + (cl-condition-of-type? obj (get entry "type")) + (begin ((get entry "fn") obj) (cl-signal-obj obj (rest stack))) + (cl-signal-obj obj (rest stack))))))) + +(define cl-signal + (fn (c) + (let ((obj (if (cl-condition? c) + c + (cl-make-condition "simple-condition" + "format-control" (str c))))) + ;; *break-on-signals*: invoke debugger hook when type matches + (when (and (not (nil? cl-break-on-signals)) + (cl-condition-of-type? obj cl-break-on-signals)) + (cl-invoke-debugger obj)) + (cl-signal-obj obj cl-handler-stack)))) + +;; ── cl-error ─────────────────────────────────────────────────────────────── +;; +;; Signals an error. If no handler catches it, raises a host-level error. + +(define + cl-error + (fn + (c &rest args) + (let + ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c)))))) + (cl-signal-obj obj cl-handler-stack) + (cl-invoke-debugger obj)))) + +;; ── cl-warn ──────────────────────────────────────────────────────────────── + +(define + cl-warn + (fn + (c &rest args) + (let + ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-warning" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-warning" "format-control" (str c)))))) + (cl-signal-obj obj cl-handler-stack)))) + +;; ── cl-handler-bind (non-unwinding) ─────────────────────────────────────── +;; +;; bindings: list of (type-name handler-fn) pairs +;; thunk: (fn () body) + +(define + cl-handler-bind + (fn + (bindings thunk) + (let + ((entries (map (fn (b) {:fn (first (rest b)) :type (first b)}) bindings))) + (begin + (cl-push-handlers entries) + (let + ((result (thunk))) + (begin (cl-pop-handlers (len entries)) result)))))) + +;; ── cl-handler-case (unwinding) ─────────────────────────────────────────── +;; +;; thunk: (fn () body) +;; cases: list of (type-name handler-fn) pairs +;; +;; Uses call/cc for the escape continuation. + +(define + cl-handler-case + (fn + (thunk &rest cases) + (call/cc + (fn + (escape) + (let + ((entries (map (fn (c) {:fn (fn (x) (escape ((first (rest c)) x))) :type (first c)}) cases))) + (begin + (cl-push-handlers entries) + (let + ((result (thunk))) + (begin (cl-pop-handlers (len entries)) result)))))))) + +;; ── cl-restart-case ──────────────────────────────────────────────────────── +;; +;; thunk: (fn () body) +;; restarts: list of (name params body-fn) triples +;; body-fn is (fn () val) or (fn (arg) val) + +(define + cl-restart-case + (fn + (thunk &rest restarts) + (call/cc + (fn + (escape) + (let + ((entries (map (fn (r) {:fn (first (rest (rest r))) :escape escape :name (first r)}) restarts))) + (begin + (cl-push-restarts entries) + (let + ((result (thunk))) + (begin (cl-pop-restarts (len entries)) result)))))))) + +;; ── cl-with-simple-restart ───────────────────────────────────────────────── + +(define + cl-with-simple-restart + (fn + (name description thunk) + (cl-restart-case thunk (list name (list) (fn () nil))))) + +;; ── find-restart / invoke-restart / compute-restarts ────────────────────── + +(define + cl-find-restart-entry + (fn + (name stack) + (if + (empty? stack) + nil + (let + ((entry (first stack))) + (if + (= (get entry "name") name) + entry + (cl-find-restart-entry name (rest stack))))))) + +(define + cl-find-restart + (fn (name) (cl-find-restart-entry name cl-restart-stack))) + +(define + cl-invoke-restart + (fn + (name &rest args) + (let + ((entry (cl-find-restart-entry name cl-restart-stack))) + (if + (nil? entry) + (error (str "No active restart: " name)) + (let + ((restart-fn (get entry "fn")) (escape (get entry "escape"))) + (escape + (if (empty? args) (restart-fn) (restart-fn (first args))))))))) + +(define + cl-compute-restarts + (fn () (map (fn (e) (get e "name")) cl-restart-stack))) + +;; ── with-condition-restarts (stub — association is advisory) ────────────── + +(define cl-with-condition-restarts (fn (c restarts thunk) (thunk))) + +;; ── cl-cerror ────────────────────────────────────────────────────────────── +;; +;; Signals a continuable error. The "continue" restart is established; +;; invoke-restart "continue" to proceed past the error. + + + +;; ── cl-cerror ────────────────────────────────────────────────────────────── +;; +;; Signals a continuable error. The "continue" restart is established; +;; invoke-restart "continue" to proceed past the error. + +(define cl-cerror + (fn (continue-string c &rest args) + (let ((obj (if (cl-condition? c) + c + (cl-make-condition "simple-error" + "format-control" (str c) + "format-arguments" args)))) + (cl-restart-case + (fn () (cl-signal-obj obj cl-handler-stack)) + (list "continue" (list) (fn () nil)))))) \ No newline at end of file diff --git a/lib/common-lisp/scoreboard.json b/lib/common-lisp/scoreboard.json new file mode 100644 index 00000000..0052d20e --- /dev/null +++ b/lib/common-lisp/scoreboard.json @@ -0,0 +1,19 @@ +{ + "generated": "2026-05-05T12:35:09Z", + "total_pass": 518, + "total_fail": 0, + "suites": [ + {"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0}, + {"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0}, + {"name": "Phase 2: evaluator", "pass": 182, "fail": 0}, + {"name": "Phase 3: condition system", "pass": 59, "fail": 0}, + {"name": "Phase 3: restart-demo", "pass": 7, "fail": 0}, + {"name": "Phase 3: parse-recover", "pass": 6, "fail": 0}, + {"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0}, + {"name": "Phase 4: CLOS", "pass": 41, "fail": 0}, + {"name": "Phase 4: geometry", "pass": 12, "fail": 0}, + {"name": "Phase 4: mop-trace", "pass": 13, "fail": 0}, + {"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0}, + {"name": "Phase 6: stdlib", "pass": 54, "fail": 0} + ] +} diff --git a/lib/common-lisp/scoreboard.md b/lib/common-lisp/scoreboard.md new file mode 100644 index 00000000..5c4e07a9 --- /dev/null +++ b/lib/common-lisp/scoreboard.md @@ -0,0 +1,20 @@ +# Common Lisp on SX — Scoreboard + +_Generated: 2026-05-05 12:35 UTC_ + +| Suite | Pass | Fail | Status | +|-------|------|------|--------| +| Phase 1: tokenizer/reader | 79 | 0 | pass | +| Phase 1: parser/lambda-lists | 31 | 0 | pass | +| Phase 2: evaluator | 182 | 0 | pass | +| Phase 3: condition system | 59 | 0 | pass | +| Phase 3: restart-demo | 7 | 0 | pass | +| Phase 3: parse-recover | 6 | 0 | pass | +| Phase 3: interactive-debugger | 7 | 0 | pass | +| Phase 4: CLOS | 41 | 0 | pass | +| Phase 4: geometry | 12 | 0 | pass | +| Phase 4: mop-trace | 13 | 0 | pass | +| Phase 5: macros+LOOP | 27 | 0 | pass | +| Phase 6: stdlib | 54 | 0 | pass | + +**Total: 518 passed, 0 failed** diff --git a/lib/common-lisp/test.sh b/lib/common-lisp/test.sh new file mode 100755 index 00000000..cffa2a38 --- /dev/null +++ b/lib/common-lisp/test.sh @@ -0,0 +1,443 @@ +#!/usr/bin/env bash +# lib/common-lisp/test.sh — quick smoke-test the CL runtime layer. +# Uses sx_server.exe epoch protocol (same as lib/lua/test.sh). +# +# Usage: +# bash lib/common-lisp/test.sh +# bash lib/common-lisp/test.sh -v + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build" + exit 1 +fi + +VERBOSE="${1:-}" +PASS=0; FAIL=0; ERRORS="" +TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT + +cat > "$TMPFILE" << 'EPOCHS' +(epoch 1) +(load "spec/stdlib.sx") +(load "lib/common-lisp/runtime.sx") + +;; --- Type predicates --- +(epoch 10) +(eval "(cl-null? nil)") +(epoch 11) +(eval "(cl-null? false)") +(epoch 12) +(eval "(cl-consp? (list 1 2))") +(epoch 13) +(eval "(cl-consp? nil)") +(epoch 14) +(eval "(cl-listp? nil)") +(epoch 15) +(eval "(cl-listp? (list 1))") +(epoch 16) +(eval "(cl-atom? nil)") +(epoch 17) +(eval "(cl-atom? (list 1))") +(epoch 18) +(eval "(cl-integerp? 42)") +(epoch 19) +(eval "(cl-floatp? 3.14)") +(epoch 20) +(eval "(cl-characterp? (integer->char 65))") +(epoch 21) +(eval "(cl-stringp? \"hello\")") + +;; --- Arithmetic --- +(epoch 30) +(eval "(cl-mod 10 3)") +(epoch 31) +(eval "(cl-rem 10 3)") +(epoch 32) +(eval "(cl-quotient 10 3)") +(epoch 33) +(eval "(cl-gcd 12 8)") +(epoch 34) +(eval "(cl-lcm 4 6)") +(epoch 35) +(eval "(cl-abs -5)") +(epoch 36) +(eval "(cl-abs 5)") +(epoch 37) +(eval "(cl-min 2 7)") +(epoch 38) +(eval "(cl-max 2 7)") +(epoch 39) +(eval "(cl-evenp? 4)") +(epoch 40) +(eval "(cl-evenp? 3)") +(epoch 41) +(eval "(cl-oddp? 7)") +(epoch 42) +(eval "(cl-zerop? 0)") +(epoch 43) +(eval "(cl-plusp? 1)") +(epoch 44) +(eval "(cl-minusp? -1)") +(epoch 45) +(eval "(cl-signum 42)") +(epoch 46) +(eval "(cl-signum -7)") +(epoch 47) +(eval "(cl-signum 0)") + +;; --- Characters --- +(epoch 50) +(eval "(cl-char-code (integer->char 65))") +(epoch 51) +(eval "(char? (cl-code-char 65))") +(epoch 52) +(eval "(cl-char=? (integer->char 65) (integer->char 65))") +(epoch 53) +(eval "(cl-charchar 65) (integer->char 90))") +(epoch 54) +(eval "(cl-char-code cl-char-space)") +(epoch 55) +(eval "(cl-char-code cl-char-newline)") +(epoch 56) +(eval "(cl-alpha-char-p (integer->char 65))") +(epoch 57) +(eval "(cl-digit-char-p (integer->char 48))") + +;; --- Format --- +(epoch 60) +(eval "(cl-format nil \"hello\")") +(epoch 61) +(eval "(cl-format nil \"~a\" \"world\")") +(epoch 62) +(eval "(cl-format nil \"~d\" 42)") +(epoch 63) +(eval "(cl-format nil \"~x\" 255)") +(epoch 64) +(eval "(cl-format nil \"x=~d y=~d\" 3 4)") + +;; --- Gensym --- +(epoch 70) +(eval "(= (type-of (cl-gensym)) \"symbol\")") +(epoch 71) +(eval "(not (= (cl-gensym) (cl-gensym)))") + +;; --- Sets --- +(epoch 80) +(eval "(cl-set? (cl-make-set))") +(epoch 81) +(eval "(let ((s (cl-make-set))) (do (cl-set-add s 1) (cl-set-memberp s 1)))") +(epoch 82) +(eval "(cl-set-memberp (cl-make-set) 42)") +(epoch 83) +(eval "(cl-set-memberp (cl-list->set (list 1 2 3)) 2)") + +;; --- Lists --- +(epoch 90) +(eval "(cl-nth 0 (list 1 2 3))") +(epoch 91) +(eval "(cl-nth 2 (list 1 2 3))") +(epoch 92) +(eval "(cl-last (list 1 2 3))") +(epoch 93) +(eval "(cl-butlast (list 1 2 3))") +(epoch 94) +(eval "(cl-nthcdr 1 (list 1 2 3))") +(epoch 95) +(eval "(cl-assoc \"b\" (list (list \"a\" 1) (list \"b\" 2)))") +(epoch 96) +(eval "(cl-assoc \"z\" (list (list \"a\" 1)))") +(epoch 97) +(eval "(cl-getf (list \"x\" 42 \"y\" 99) \"x\")") +(epoch 98) +(eval "(cl-adjoin 0 (list 1 2))") +(epoch 99) +(eval "(cl-adjoin 1 (list 1 2))") +(epoch 100) +(eval "(cl-member 2 (list 1 2 3))") +(epoch 101) +(eval "(cl-member 9 (list 1 2 3))") +(epoch 102) +(eval "(cl-flatten (list 1 (list 2 3) 4))") + +;; --- Radix --- +(epoch 110) +(eval "(cl-format-binary 10)") +(epoch 111) +(eval "(cl-format-octal 15)") +(epoch 112) +(eval "(cl-format-hex 255)") +(epoch 113) +(eval "(cl-format-decimal 42)") +(epoch 114) +(eval "(cl-integer-to-string 31 16)") +(epoch 115) +(eval "(cl-string-to-integer \"1f\" 16)") + +EPOCHS + +OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) + +check() { + local epoch="$1" desc="$2" expected="$3" + local actual + # ok-len format: value appears on the line AFTER "(ok-len N length)" + actual=$(echo "$OUTPUT" | grep -A1 "^(ok-len $epoch " | tail -1 || true) + # strip any leading "(ok-len ...)" if grep -A1 returned it instead + if echo "$actual" | grep -q "^(ok-len"; then actual=""; fi + if [ -z "$actual" ]; then + actual=$(echo "$OUTPUT" | grep "^(ok $epoch " | head -1 || true) + fi + if [ -z "$actual" ]; then + actual=$(echo "$OUTPUT" | grep "^(error $epoch " | head -1 || true) + fi + [ -z "$actual" ] && actual="" + + if echo "$actual" | grep -qF -- "$expected"; then + PASS=$((PASS+1)) + [ "$VERBOSE" = "-v" ] && echo " ok $desc" + else + FAIL=$((FAIL+1)) + ERRORS+=" FAIL [$desc] (epoch $epoch) expected: $expected | actual: $actual +" + fi +} + +# Type predicates +check 10 "cl-null? nil" "true" +check 11 "cl-null? false" "false" +check 12 "cl-consp? pair" "true" +check 13 "cl-consp? nil" "false" +check 14 "cl-listp? nil" "true" +check 15 "cl-listp? list" "true" +check 16 "cl-atom? nil" "true" +check 17 "cl-atom? pair" "false" +check 18 "cl-integerp?" "true" +check 19 "cl-floatp?" "true" +check 20 "cl-characterp?" "true" +check 21 "cl-stringp?" "true" + +# Arithmetic +check 30 "cl-mod 10 3" "1" +check 31 "cl-rem 10 3" "1" +check 32 "cl-quotient 10 3" "3" +check 33 "cl-gcd 12 8" "4" +check 34 "cl-lcm 4 6" "12" +check 35 "cl-abs -5" "5" +check 36 "cl-abs 5" "5" +check 37 "cl-min 2 7" "2" +check 38 "cl-max 2 7" "7" +check 39 "cl-evenp? 4" "true" +check 40 "cl-evenp? 3" "false" +check 41 "cl-oddp? 7" "true" +check 42 "cl-zerop? 0" "true" +check 43 "cl-plusp? 1" "true" +check 44 "cl-minusp? -1" "true" +check 45 "cl-signum pos" "1" +check 46 "cl-signum neg" "-1" +check 47 "cl-signum zero" "0" + +# Characters +check 50 "cl-char-code" "65" +check 51 "code-char returns char" "true" +check 52 "cl-char=?" "true" +check 53 "cl-charset member" "true" + +# Lists +check 90 "cl-nth 0" "1" +check 91 "cl-nth 2" "3" +check 92 "cl-last" "(3)" +check 93 "cl-butlast" "(1 2)" +check 94 "cl-nthcdr 1" "(2 3)" +check 95 "cl-assoc hit" '("b" 2)' +check 96 "cl-assoc miss" "nil" +check 97 "cl-getf hit" "42" +check 98 "cl-adjoin new" "(0 1 2)" +check 99 "cl-adjoin dup" "(1 2)" +check 100 "cl-member hit" "(2 3)" +check 101 "cl-member miss" "nil" +check 102 "cl-flatten" "(1 2 3 4)" + +# Radix +check 110 "cl-format-binary 10" '"1010"' +check 111 "cl-format-octal 15" '"17"' +check 112 "cl-format-hex 255" '"ff"' +check 113 "cl-format-decimal 42" '"42"' +check 114 "n->s base 16" '"1f"' +check 115 "s->n base 16" "31" + +# ── Phase 2: condition system unit tests ───────────────────────────────────── +# Load runtime.sx then conditions.sx; query the passed/failed/failures globals. +UNIT_FILE=$(mktemp); trap "rm -f $UNIT_FILE" EXIT +cat > "$UNIT_FILE" << 'UNIT' +(epoch 1) +(load "spec/stdlib.sx") +(epoch 2) +(load "lib/common-lisp/runtime.sx") +(epoch 3) +(load "lib/common-lisp/tests/conditions.sx") +(epoch 4) +(eval "passed") +(epoch 5) +(eval "failed") +(epoch 6) +(eval "failures") +UNIT + +UNIT_OUT=$(timeout 30 "$SX_SERVER" < "$UNIT_FILE" 2>/dev/null) + +# extract passed/failed counts from ok-len lines +UNIT_PASSED=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 4 " | tail -1 || true) +UNIT_FAILED=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true) +UNIT_ERRS=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true) +# fallback: try plain ok lines +[ -z "$UNIT_PASSED" ] && UNIT_PASSED=$(echo "$UNIT_OUT" | grep "^(ok 4 " | awk '{print $3}' | tr -d ')' || true) +[ -z "$UNIT_FAILED" ] && UNIT_FAILED=$(echo "$UNIT_OUT" | grep "^(ok 5 " | awk '{print $3}' | tr -d ')' || true) +[ -z "$UNIT_PASSED" ] && UNIT_PASSED=0 +[ -z "$UNIT_FAILED" ] && UNIT_FAILED=0 + +if [ "$UNIT_FAILED" = "0" ] && [ "$UNIT_PASSED" -gt 0 ] 2>/dev/null; then + PASS=$((PASS + UNIT_PASSED)) + [ "$VERBOSE" = "-v" ] && echo " ok condition tests ($UNIT_PASSED)" +else + FAIL=$((FAIL + 1)) + ERRORS+=" FAIL [condition tests] (${UNIT_PASSED} passed, ${UNIT_FAILED} failed) ${UNIT_ERRS} +" +fi + +# ── Phase 3: classic program tests ─────────────────────────────────────────── +run_program_suite() { + local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4" + local PROG_FILE=$(mktemp) + printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "%s")\n(epoch 4)\n(eval "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n' \ + "$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE" + local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null) + rm -f "$PROG_FILE" + local P F + P=$(echo "$OUT" | grep -A1 "^(ok-len 4 " | tail -1 || true) + F=$(echo "$OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true) + local ERRS; ERRS=$(echo "$OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true) + [ -z "$P" ] && P=0; [ -z "$F" ] && F=0 + if [ "$F" = "0" ] && [ "$P" -gt 0 ] 2>/dev/null; then + PASS=$((PASS + P)) + [ "$VERBOSE" = "-v" ] && echo " ok $prog ($P)" + else + FAIL=$((FAIL + 1)) + ERRORS+=" FAIL [$prog] (${P} passed, ${F} failed) ${ERRS} +" + fi +} + +run_program_suite \ + "lib/common-lisp/tests/programs/restart-demo.sx" \ + "demo-passed" "demo-failed" "demo-failures" + +run_program_suite \ + "lib/common-lisp/tests/programs/parse-recover.sx" \ + "parse-passed" "parse-failed" "parse-failures" + +run_program_suite \ + "lib/common-lisp/tests/programs/interactive-debugger.sx" \ + "debugger-passed" "debugger-failed" "debugger-failures" + +# ── Phase 4: CLOS unit tests ───────────────────────────────────────────────── +CLOS_FILE=$(mktemp); trap "rm -f $CLOS_FILE" EXIT +printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE" +CLOS_OUT=$(timeout 30 "$SX_SERVER" < "$CLOS_FILE" 2>/dev/null) +rm -f "$CLOS_FILE" +CLOS_PASSED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true) +CLOS_FAILED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true) +[ -z "$CLOS_PASSED" ] && CLOS_PASSED=$(echo "$CLOS_OUT" | grep "^(ok 5 " | awk '{print $3}' | tr -d ')' || true) +[ -z "$CLOS_FAILED" ] && CLOS_FAILED=$(echo "$CLOS_OUT" | grep "^(ok 6 " | awk '{print $3}' | tr -d ')' || true) +[ -z "$CLOS_PASSED" ] && CLOS_PASSED=0; [ -z "$CLOS_FAILED" ] && CLOS_FAILED=0 +if [ "$CLOS_FAILED" = "0" ] && [ "$CLOS_PASSED" -gt 0 ] 2>/dev/null; then + PASS=$((PASS + CLOS_PASSED)) + [ "$VERBOSE" = "-v" ] && echo " ok CLOS unit tests ($CLOS_PASSED)" +else + FAIL=$((FAIL + 1)) + ERRORS+=" FAIL [CLOS unit tests] (${CLOS_PASSED} passed, ${CLOS_FAILED} failed) +" +fi + +# ── Phase 4: CLOS classic programs ─────────────────────────────────────────── +run_clos_suite() { + local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4" + local PROG_FILE=$(mktemp) + printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \ + "$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE" + local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null) + rm -f "$PROG_FILE" + local P F + P=$(echo "$OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true) + F=$(echo "$OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true) + local ERRS; ERRS=$(echo "$OUT" | grep -A1 "^(ok-len 7 " | tail -1 || true) + [ -z "$P" ] && P=0; [ -z "$F" ] && F=0 + if [ "$F" = "0" ] && [ "$P" -gt 0 ] 2>/dev/null; then + PASS=$((PASS + P)) + [ "$VERBOSE" = "-v" ] && echo " ok $prog ($P)" + else + FAIL=$((FAIL + 1)) + ERRORS+=" FAIL [$prog] (${P} passed, ${F} failed) ${ERRS} +" + fi +} + +run_clos_suite \ + "lib/common-lisp/tests/programs/geometry.sx" \ + "geo-passed" "geo-failed" "geo-failures" + +run_clos_suite \ + "lib/common-lisp/tests/programs/mop-trace.sx" \ + "mop-passed" "mop-failed" "mop-failures" + +# ── Phase 5: macros + LOOP ─────────────────────────────────────────────────── +MACRO_FILE=$(mktemp); trap "rm -f $MACRO_FILE" EXIT +printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/reader.sx")\n(epoch 3)\n(load "lib/common-lisp/parser.sx")\n(epoch 4)\n(load "lib/common-lisp/eval.sx")\n(epoch 5)\n(load "lib/common-lisp/loop.sx")\n(epoch 6)\n(load "lib/common-lisp/tests/macros.sx")\n(epoch 7)\n(eval "macro-passed")\n(epoch 8)\n(eval "macro-failed")\n(epoch 9)\n(eval "macro-failures")\n' > "$MACRO_FILE" +MACRO_OUT=$(timeout 60 "$SX_SERVER" < "$MACRO_FILE" 2>/dev/null) +rm -f "$MACRO_FILE" +MACRO_PASSED=$(echo "$MACRO_OUT" | grep -A1 "^(ok-len 7 " | tail -1 || true) +MACRO_FAILED=$(echo "$MACRO_OUT" | grep -A1 "^(ok-len 8 " | tail -1 || true) +[ -z "$MACRO_PASSED" ] && MACRO_PASSED=0; [ -z "$MACRO_FAILED" ] && MACRO_FAILED=0 +if [ "$MACRO_FAILED" = "0" ] && [ "$MACRO_PASSED" -gt 0 ] 2>/dev/null; then + PASS=$((PASS + MACRO_PASSED)) + [ "$VERBOSE" = "-v" ] && echo " ok Phase 5 macros+LOOP ($MACRO_PASSED)" +else + FAIL=$((FAIL + 1)) + ERRORS+=" FAIL [Phase 5 macros+LOOP] (${MACRO_PASSED} passed, ${MACRO_FAILED} failed) +" +fi + +TOTAL=$((PASS+FAIL)) +if [ $FAIL -eq 0 ]; then + echo "ok $PASS/$TOTAL lib/common-lisp tests passed" +else + echo "FAIL $PASS/$TOTAL passed, $FAIL failed:" + echo "$ERRORS" +fi +[ $FAIL -eq 0 ] diff --git a/lib/common-lisp/tests/clos.sx b/lib/common-lisp/tests/clos.sx new file mode 100644 index 00000000..5535ea5d --- /dev/null +++ b/lib/common-lisp/tests/clos.sx @@ -0,0 +1,334 @@ +;; lib/common-lisp/tests/clos.sx — CLOS test suite +;; +;; Loaded after: spec/stdlib.sx, lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + assert-equal + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +(define + assert-true + (fn + (label got) + (if + got + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str "FAIL [" label "]: expected true, got " (inspect got))))))))) + +(define + assert-nil + (fn + (label got) + (if + (nil? got) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list (str "FAIL [" label "]: expected nil, got " (inspect got))))))))) + +;; ── 1. class-of for built-in types ──────────────────────────────────────── + +(assert-equal "class-of integer" (clos-class-of 42) "integer") +(assert-equal "class-of float" (clos-class-of 3.14) "float") +(assert-equal "class-of string" (clos-class-of "hi") "string") +(assert-equal "class-of nil" (clos-class-of nil) "null") +(assert-equal "class-of list" (clos-class-of (list 1)) "cons") +(assert-equal "class-of empty" (clos-class-of (list)) "null") + +;; ── 2. subclass-of? ─────────────────────────────────────────────────────── + +(assert-true "integer subclass-of t" (clos-subclass-of? "integer" "t")) +(assert-true "float subclass-of t" (clos-subclass-of? "float" "t")) +(assert-true "t subclass-of t" (clos-subclass-of? "t" "t")) +(assert-equal + "integer not subclass-of float" + (clos-subclass-of? "integer" "float") + false) + +;; ── 3. defclass + make-instance ─────────────────────────────────────────── + +(clos-defclass "point" (list "t") (list {:initform 0 :initarg ":x" :reader nil :writer nil :accessor "point-x" :name "x"} {:initform 0 :initarg ":y" :reader nil :writer nil :accessor "point-y" :name "y"})) + +(let + ((p (clos-make-instance "point" ":x" 3 ":y" 4))) + (begin + (assert-equal "make-instance slot x" (clos-slot-value p "x") 3) + (assert-equal "make-instance slot y" (clos-slot-value p "y") 4) + (assert-equal "class-of instance" (clos-class-of p) "point") + (assert-true "instance-of? point" (clos-instance-of? p "point")) + (assert-true "instance-of? t" (clos-instance-of? p "t")) + (assert-equal "instance-of? string" (clos-instance-of? p "string") false))) + +;; initform defaults +(let + ((p0 (clos-make-instance "point"))) + (begin + (assert-equal "initform default x=0" (clos-slot-value p0 "x") 0) + (assert-equal "initform default y=0" (clos-slot-value p0 "y") 0))) + +;; ── 4. slot-value / set-slot-value! ────────────────────────────────────── + +(let + ((p (clos-make-instance "point" ":x" 10 ":y" 20))) + (begin + (clos-set-slot-value! p "x" 99) + (assert-equal "set-slot-value! x" (clos-slot-value p "x") 99) + (assert-equal "slot-value y unchanged" (clos-slot-value p "y") 20))) + +;; ── 5. slot-boundp ──────────────────────────────────────────────────────── + +(let + ((p (clos-make-instance "point" ":x" 5))) + (begin + (assert-true "slot-boundp x" (clos-slot-boundp p "x")) + (assert-true "slot-boundp y (initform 0)" (clos-slot-boundp p "y")))) + +;; ── 6. find-class ───────────────────────────────────────────────────────── + +(assert-equal + "find-class point" + (get (clos-find-class "point") "name") + "point") +(assert-nil "find-class missing" (clos-find-class "no-such-class")) + +;; ── 7. inheritance ──────────────────────────────────────────────────────── + +(clos-defclass "colored-point" (list "point") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"})) + +(let + ((cp (clos-make-instance "colored-point" ":x" 1 ":y" 2 ":color" "red"))) + (begin + (assert-equal "inherited slot x" (clos-slot-value cp "x") 1) + (assert-equal "inherited slot y" (clos-slot-value cp "y") 2) + (assert-equal "own slot color" (clos-slot-value cp "color") "red") + (assert-true + "instance-of? colored-point" + (clos-instance-of? cp "colored-point")) + (assert-true "instance-of? point (parent)" (clos-instance-of? cp "point")) + (assert-true "instance-of? t (root)" (clos-instance-of? cp "t")))) + +;; ── 8. defgeneric + primary method ─────────────────────────────────────── + +(clos-defgeneric "describe-obj" {}) + +(clos-defmethod + "describe-obj" + (list) + (list "point") + (fn + (args next-fn) + (let + ((p (first args))) + (str "(" (clos-slot-value p "x") "," (clos-slot-value p "y") ")")))) + +(clos-defmethod + "describe-obj" + (list) + (list "t") + (fn (args next-fn) (str "object:" (inspect (first args))))) + +(let + ((p (clos-make-instance "point" ":x" 3 ":y" 4))) + (begin + (assert-equal + "primary method for point" + (clos-call-generic "describe-obj" (list p)) + "(3,4)") + (assert-equal + "fallback t method" + (clos-call-generic "describe-obj" (list 42)) + "object:42"))) + +;; ── 9. method inheritance + specificity ─────────────────────────────────── + +(clos-defmethod + "describe-obj" + (list) + (list "colored-point") + (fn + (args next-fn) + (let + ((cp (first args))) + (str + (clos-slot-value cp "color") + "@(" + (clos-slot-value cp "x") + "," + (clos-slot-value cp "y") + ")")))) + +(let + ((cp (clos-make-instance "colored-point" ":x" 5 ":y" 6 ":color" "blue"))) + (assert-equal + "most specific method wins" + (clos-call-generic "describe-obj" (list cp)) + "blue@(5,6)")) + +;; ── 10. :before / :after / :around qualifiers ───────────────────────────── + +(clos-defgeneric "logged-action" {}) + +(clos-defmethod + "logged-action" + (list "before") + (list "t") + (fn (args next-fn) (set! action-log (append action-log (list "before"))))) + +(clos-defmethod + "logged-action" + (list) + (list "t") + (fn + (args next-fn) + (set! action-log (append action-log (list "primary"))) + "result")) + +(clos-defmethod + "logged-action" + (list "after") + (list "t") + (fn (args next-fn) (set! action-log (append action-log (list "after"))))) + +(define action-log (list)) +(clos-call-generic "logged-action" (list 1)) +(assert-equal + ":before/:after order" + action-log + (list "before" "primary" "after")) + +;; :around +(define around-log (list)) + +(clos-defgeneric "wrapped-action" {}) + +(clos-defmethod + "wrapped-action" + (list "around") + (list "t") + (fn + (args next-fn) + (set! around-log (append around-log (list "around-enter"))) + (let + ((r (next-fn))) + (set! around-log (append around-log (list "around-exit"))) + r))) + +(clos-defmethod + "wrapped-action" + (list) + (list "t") + (fn + (args next-fn) + (set! around-log (append around-log (list "primary"))) + 42)) + +(let + ((r (clos-call-generic "wrapped-action" (list nil)))) + (begin + (assert-equal ":around result" r 42) + (assert-equal + ":around log" + around-log + (list "around-enter" "primary" "around-exit")))) + +;; ── 11. call-next-method ───────────────────────────────────────────────── + +(clos-defgeneric "chain-test" {}) + +(clos-defmethod + "chain-test" + (list) + (list "colored-point") + (fn (args next-fn) (str "colored:" (clos-call-next-method next-fn)))) + +(clos-defmethod + "chain-test" + (list) + (list "point") + (fn (args next-fn) "point-base")) + +(let + ((cp (clos-make-instance "colored-point" ":x" 0 ":y" 0 ":color" "green"))) + (assert-equal + "call-next-method chains" + (clos-call-generic "chain-test" (list cp)) + "colored:point-base")) + +;; ── 12. accessor methods ────────────────────────────────────────────────── + +(let + ((p (clos-make-instance "point" ":x" 7 ":y" 8))) + (begin + (assert-equal + "accessor point-x" + (clos-call-generic "point-x" (list p)) + 7) + (assert-equal + "accessor point-y" + (clos-call-generic "point-y" (list p)) + 8))) + +;; ── 13. with-slots ──────────────────────────────────────────────────────── + +(let + ((p (clos-make-instance "point" ":x" 3 ":y" 4))) + (assert-equal + "with-slots" + (clos-with-slots p (list "x" "y") (fn (x y) (* x y))) + 12)) + +;; ── 14. change-class ───────────────────────────────────────────────────── + +(clos-defclass "special-point" (list "point") (list {:initform "" :initarg ":label" :reader nil :writer nil :accessor nil :name "label"})) + +(let + ((p (clos-make-instance "point" ":x" 1 ":y" 2))) + (begin + (clos-change-class! p "special-point") + (assert-equal + "change-class updates class" + (clos-class-of p) + "special-point"))) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(if + (= failed 0) + (print (str "ok " passed "/" (+ passed failed) " CLOS tests passed")) + (begin + (for-each (fn (f) (print f)) failures) + (print + (str "FAIL " passed "/" (+ passed failed) " passed, " failed " failed")))) \ No newline at end of file diff --git a/lib/common-lisp/tests/conditions.sx b/lib/common-lisp/tests/conditions.sx new file mode 100644 index 00000000..2745c1e8 --- /dev/null +++ b/lib/common-lisp/tests/conditions.sx @@ -0,0 +1,478 @@ +;; lib/common-lisp/tests/conditions.sx — Phase 3 condition system tests +;; +;; Loaded by lib/common-lisp/test.sh after: +;; (load "spec/stdlib.sx") +;; (load "lib/common-lisp/runtime.sx") +;; +;; Each test resets the handler/restart stacks to ensure isolation. + +(define + reset-stacks! + (fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list)))) + +;; ── helpers ──────────────────────────────────────────────────────────────── + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + assert-equal + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +(define + assert-true + (fn + (label got) + (if + got + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str "FAIL [" label "]: expected true, got " (inspect got))))))))) + +(define + assert-nil + (fn + (label got) + (if + (nil? got) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list (str "FAIL [" label "]: expected nil, got " (inspect got))))))))) + +;; ── 1. condition predicates ──────────────────────────────────────────────── + +(reset-stacks!) + +(let + ((c (cl-make-condition "simple-error" "format-control" "oops"))) + (begin + (assert-true "cl-condition? on condition" (cl-condition? c)) + (assert-equal "cl-condition? on string" (cl-condition? "hello") false) + (assert-equal "cl-condition? on number" (cl-condition? 42) false) + (assert-equal "cl-condition? on nil" (cl-condition? nil) false))) + +;; ── 2. cl-make-condition + slot access ──────────────────────────────────── + +(reset-stacks!) + +(let + ((c (cl-make-condition "simple-error" "format-control" "msg" "format-arguments" (list 1 2)))) + (begin + (assert-equal "class field" (get c "class") "simple-error") + (assert-equal "cl-type field" (get c "cl-type") "cl-condition") + (assert-equal + "format-control slot" + (cl-condition-slot c "format-control") + "msg") + (assert-equal + "format-arguments slot" + (cl-condition-slot c "format-arguments") + (list 1 2)) + (assert-nil "missing slot is nil" (cl-condition-slot c "no-such-slot")) + (assert-equal "condition-message" (cl-condition-message c) "msg"))) + +;; ── 3. cl-condition-of-type? — hierarchy walking ───────────────────────── + +(reset-stacks!) + +(let + ((se (cl-make-condition "simple-error" "format-control" "x")) + (w (cl-make-condition "simple-warning" "format-control" "y")) + (te + (cl-make-condition + "type-error" + "datum" + 5 + "expected-type" + "string")) + (dz (cl-make-condition "division-by-zero"))) + (begin + (assert-true + "se isa simple-error" + (cl-condition-of-type? se "simple-error")) + (assert-true "se isa error" (cl-condition-of-type? se "error")) + (assert-true + "se isa serious-condition" + (cl-condition-of-type? se "serious-condition")) + (assert-true "se isa condition" (cl-condition-of-type? se "condition")) + (assert-equal + "se not isa warning" + (cl-condition-of-type? se "warning") + false) + (assert-true + "w isa simple-warning" + (cl-condition-of-type? w "simple-warning")) + (assert-true "w isa warning" (cl-condition-of-type? w "warning")) + (assert-true "w isa condition" (cl-condition-of-type? w "condition")) + (assert-equal "w not isa error" (cl-condition-of-type? w "error") false) + (assert-true "te isa type-error" (cl-condition-of-type? te "type-error")) + (assert-true "te isa error" (cl-condition-of-type? te "error")) + (assert-true + "dz isa division-by-zero" + (cl-condition-of-type? dz "division-by-zero")) + (assert-true + "dz isa arithmetic-error" + (cl-condition-of-type? dz "arithmetic-error")) + (assert-true "dz isa error" (cl-condition-of-type? dz "error")) + (assert-equal + "non-condition not isa anything" + (cl-condition-of-type? 42 "error") + false))) + +;; ── 4. cl-define-condition ──────────────────────────────────────────────── + +(reset-stacks!) + +(begin + (cl-define-condition "my-app-error" (list "error") (list "code" "detail")) + (let + ((c (cl-make-condition "my-app-error" "code" 404 "detail" "not found"))) + (begin + (assert-true "user condition: cl-condition?" (cl-condition? c)) + (assert-true + "user condition isa my-app-error" + (cl-condition-of-type? c "my-app-error")) + (assert-true + "user condition isa error" + (cl-condition-of-type? c "error")) + (assert-true + "user condition isa condition" + (cl-condition-of-type? c "condition")) + (assert-equal + "user condition slot code" + (cl-condition-slot c "code") + 404) + (assert-equal + "user condition slot detail" + (cl-condition-slot c "detail") + "not found")))) + +;; ── 5. cl-handler-bind (non-unwinding) ─────────────────────────────────── + +(reset-stacks!) + +(let + ((log (list))) + (begin + (cl-handler-bind + (list + (list + "error" + (fn (c) (set! log (append log (list (cl-condition-message c))))))) + (fn + () + (cl-signal (cl-make-condition "simple-error" "format-control" "oops")))) + (assert-equal "handler-bind: handler fired" log (list "oops")))) + +(reset-stacks!) + +;; Non-unwinding: body continues after signal +(let + ((body-ran false)) + (begin + (cl-handler-bind + (list (list "error" (fn (c) nil))) + (fn + () + (cl-signal (cl-make-condition "simple-error" "format-control" "x")) + (set! body-ran true))) + (assert-true "handler-bind: body continues after signal" body-ran))) + +(reset-stacks!) + +;; Type filtering: warning handler does not fire for error +(let + ((w-fired false)) + (begin + (cl-handler-bind + (list (list "warning" (fn (c) (set! w-fired true)))) + (fn + () + (cl-signal (cl-make-condition "simple-error" "format-control" "e")))) + (assert-equal + "handler-bind: type filter (warning ignores error)" + w-fired + false))) + +(reset-stacks!) + +;; Multiple handlers: both matching handlers fire +(let + ((log (list))) + (begin + (cl-handler-bind + (list + (list "error" (fn (c) (set! log (append log (list "e1"))))) + (list "condition" (fn (c) (set! log (append log (list "e2")))))) + (fn + () + (cl-signal (cl-make-condition "simple-error" "format-control" "x")))) + (assert-equal "handler-bind: both handlers fire" log (list "e1" "e2")))) + +(reset-stacks!) + +;; ── 6. cl-handler-case (unwinding) ─────────────────────────────────────── + +;; Catches error, returns handler result +(let + ((result (cl-handler-case (fn () (cl-error "boom") 99) (list "error" (fn (c) (str "caught: " (cl-condition-message c))))))) + (assert-equal "handler-case: catches error" result "caught: boom")) + +(reset-stacks!) + +;; Returns body result when no signal +(let + ((result (cl-handler-case (fn () 42) (list "error" (fn (c) -1))))) + (assert-equal "handler-case: body result" result 42)) + +(reset-stacks!) + +;; Only first matching handler runs (unwinding) +(let + ((result (cl-handler-case (fn () (cl-error "x")) (list "simple-error" (fn (c) "simple")) (list "error" (fn (c) "error"))))) + (assert-equal "handler-case: most specific wins" result "simple")) + +(reset-stacks!) + +;; ── 7. cl-warn ──────────────────────────────────────────────────────────── + +(let + ((warned false)) + (begin + (cl-handler-bind + (list (list "warning" (fn (c) (set! warned true)))) + (fn () (cl-warn "be careful"))) + (assert-true "cl-warn: fires warning handler" warned))) + +(reset-stacks!) + +;; Warn with condition object +(let + ((msg "")) + (begin + (cl-handler-bind + (list (list "warning" (fn (c) (set! msg (cl-condition-message c))))) + (fn + () + (cl-warn + (cl-make-condition "simple-warning" "format-control" "take care")))) + (assert-equal "cl-warn: condition object" msg "take care"))) + +(reset-stacks!) + +;; ── 8. cl-restart-case + cl-invoke-restart ─────────────────────────────── + +;; Basic restart invocation +(let + ((result (cl-restart-case (fn () (cl-invoke-restart "use-zero")) (list "use-zero" (list) (fn () 0))))) + (assert-equal "restart-case: invoke-restart use-zero" result 0)) + +(reset-stacks!) + +;; Restart with argument +(let + ((result (cl-restart-case (fn () (cl-invoke-restart "use-value" 77)) (list "use-value" (list "v") (fn (v) v))))) + (assert-equal "restart-case: invoke-restart with arg" result 77)) + +(reset-stacks!) + +;; Body returns normally when restart not invoked +(let + ((result (cl-restart-case (fn () 42) (list "never-used" (list) (fn () -1))))) + (assert-equal "restart-case: body result" result 42)) + +(reset-stacks!) + +;; ── 9. cl-with-simple-restart ───────────────────────────────────────────── + +(let + ((result (cl-with-simple-restart "skip" "Skip this step" (fn () (cl-invoke-restart "skip") 99)))) + (assert-nil "with-simple-restart: invoke returns nil" result)) + +(reset-stacks!) + +;; ── 10. cl-find-restart ─────────────────────────────────────────────────── + +(let + ((found (cl-restart-case (fn () (cl-find-restart "retry")) (list "retry" (list) (fn () nil))))) + (assert-true "find-restart: finds active restart" (not (nil? found)))) + +(reset-stacks!) + +(let + ((not-found (cl-restart-case (fn () (cl-find-restart "nonexistent")) (list "retry" (list) (fn () nil))))) + (assert-nil "find-restart: nil for inactive restart" not-found)) + +(reset-stacks!) + +;; ── 11. cl-compute-restarts ─────────────────────────────────────────────── + +(let + ((names (cl-restart-case (fn () (cl-restart-case (fn () (cl-compute-restarts)) (list "inner" (list) (fn () nil)))) (list "outer" (list) (fn () nil))))) + (assert-equal + "compute-restarts: both restarts" + names + (list "inner" "outer"))) + +(reset-stacks!) + +;; ── 12. handler-bind + restart-case interop ─────────────────────────────── + +;; Classic CL pattern: error handler invokes a restart +(let + ((result (cl-restart-case (fn () (cl-handler-bind (list (list "error" (fn (c) (cl-invoke-restart "use-zero")))) (fn () (cl-error "divide by zero")))) (list "use-zero" (list) (fn () 0))))) + (assert-equal "interop: handler invokes restart" result 0)) + +(reset-stacks!) + +;; ── 13. cl-cerror ───────────────────────────────────────────────────────── + +;; When "continue" restart is invoked, cerror returns nil +(let + ((result (cl-restart-case (fn () (cl-cerror "continue anyway" "something bad") 42) (list "continue" (list) (fn () "resumed"))))) + (assert-true + "cerror: returns" + (or (nil? result) (= result 42) (= result "resumed")))) + +(reset-stacks!) + +;; ── 14. slot accessor helpers ───────────────────────────────────────────── + +(let + ((c (cl-make-condition "simple-error" "format-control" "msg" "format-arguments" (list 1 2)))) + (begin + (assert-equal + "simple-condition-format-control" + (cl-simple-condition-format-control c) + "msg") + (assert-equal + "simple-condition-format-arguments" + (cl-simple-condition-format-arguments c) + (list 1 2)))) + +(let + ((c (cl-make-condition "type-error" "datum" 42 "expected-type" "string"))) + (begin + (assert-equal "type-error-datum" (cl-type-error-datum c) 42) + (assert-equal + "type-error-expected-type" + (cl-type-error-expected-type c) + "string"))) + +(let + ((c (cl-make-condition "arithmetic-error" "operation" "/" "operands" (list 1 0)))) + (begin + (assert-equal + "arithmetic-error-operation" + (cl-arithmetic-error-operation c) + "/") + (assert-equal + "arithmetic-error-operands" + (cl-arithmetic-error-operands c) + (list 1 0)))) + + +;; ── 15. *debugger-hook* ─────────────────────────────────────────────────── + +(reset-stacks!) + +(let ((received nil)) + (begin + (set! cl-debugger-hook + (fn (c h) + (set! received (cl-condition-message c)) + (cl-invoke-restart "escape"))) + (cl-restart-case + (fn () (cl-error "debugger test")) + (list "escape" (list) (fn () nil))) + (set! cl-debugger-hook nil) + (assert-equal "debugger-hook receives condition" received "debugger test"))) + +(reset-stacks!) + +;; ── 16. *break-on-signals* ──────────────────────────────────────────────── + +(reset-stacks!) + +(let ((triggered false)) + (begin + (set! cl-break-on-signals "error") + (set! cl-debugger-hook + (fn (c h) + (set! triggered true) + (cl-invoke-restart "abort"))) + (cl-restart-case + (fn () + (cl-signal (cl-make-condition "simple-error" "format-control" "x"))) + (list "abort" (list) (fn () nil))) + (set! cl-break-on-signals nil) + (set! cl-debugger-hook nil) + (assert-true "break-on-signals fires hook" triggered))) + +(reset-stacks!) + +;; break-on-signals: non-matching type does NOT fire hook +(let ((triggered false)) + (begin + (set! cl-break-on-signals "error") + (set! cl-debugger-hook + (fn (c h) (set! triggered true) nil)) + (cl-handler-bind + (list (list "warning" (fn (c) nil))) + (fn () + (cl-signal (cl-make-condition "simple-warning" "format-control" "w")))) + (set! cl-break-on-signals nil) + (set! cl-debugger-hook nil) + (assert-equal "break-on-signals: type mismatch not triggered" triggered false))) + +(reset-stacks!) + +;; ── 17. cl-invoke-restart-interactively ────────────────────────────────── + +(let ((result + (cl-restart-case + (fn () (cl-invoke-restart-interactively "use-default")) + (list "use-default" (list) (fn () 99))))) + (assert-equal "invoke-restart-interactively: returns restart value" result 99)) + +(reset-stacks!) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(if + (= failed 0) + (print (str "ok " passed "/" (+ passed failed) " condition tests passed")) + (begin + (for-each (fn (f) (print f)) failures) + (print + (str "FAIL " passed "/" (+ passed failed) " passed, " failed " failed")))) \ No newline at end of file diff --git a/lib/common-lisp/tests/eval.sx b/lib/common-lisp/tests/eval.sx new file mode 100644 index 00000000..2a58146e --- /dev/null +++ b/lib/common-lisp/tests/eval.sx @@ -0,0 +1,466 @@ +;; CL evaluator tests + +(define cl-test-pass 0) +(define cl-test-fail 0) +(define cl-test-fails (list)) + +(define + cl-deep= + (fn + (a b) + (cond + ((= a b) true) + ((and (dict? a) (dict? b)) + (let + ((ak (keys a)) (bk (keys b))) + (if + (not (= (len ak) (len bk))) + false + (every? + (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k)))) + ak)))) + ((and (list? a) (list? b)) + (if + (not (= (len a) (len b))) + false + (let + ((i 0) (ok true)) + (define + chk + (fn + () + (when + (and ok (< i (len a))) + (do + (when + (not (cl-deep= (nth a i) (nth b i))) + (set! ok false)) + (set! i (+ i 1)) + (chk))))) + (chk) + ok))) + (:else false)))) + +(define + cl-test + (fn + (name actual expected) + (if + (cl-deep= actual expected) + (set! cl-test-pass (+ cl-test-pass 1)) + (do + (set! cl-test-fail (+ cl-test-fail 1)) + (append! cl-test-fails {:name name :expected expected :actual actual}))))) + +;; Convenience: evaluate CL string with fresh env each time +(define ev (fn (src) (cl-eval-str src (cl-make-env)))) +(define evall (fn (src) (cl-eval-all-str src (cl-make-env)))) + +;; ── self-evaluating literals ────────────────────────────────────── + +(cl-test "lit: nil" (ev "nil") nil) +(cl-test "lit: t" (ev "t") true) +(cl-test "lit: integer" (ev "42") 42) +(cl-test "lit: negative" (ev "-7") -7) +(cl-test "lit: zero" (ev "0") 0) +(cl-test "lit: string" (ev "\"hello\"") "hello") +(cl-test "lit: empty string" (ev "\"\"") "") +(cl-test "lit: keyword type" (get (ev ":foo") "cl-type") "keyword") +(cl-test "lit: keyword name" (get (ev ":foo") "name") "FOO") +(cl-test "lit: float type" (get (ev "3.14") "cl-type") "float") + +;; ── QUOTE ───────────────────────────────────────────────────────── + +(cl-test "quote: symbol" (ev "'x") "X") +(cl-test "quote: list" (ev "'(a b c)") (list "A" "B" "C")) +(cl-test "quote: nil" (ev "'nil") nil) +(cl-test "quote: integer" (ev "'42") 42) +(cl-test "quote: nested" (ev "'(a (b c))") (list "A" (list "B" "C"))) + +;; ── IF ──────────────────────────────────────────────────────────── + +(cl-test "if: true branch" (ev "(if t 1 2)") 1) +(cl-test "if: false branch" (ev "(if nil 1 2)") 2) +(cl-test "if: no else nil" (ev "(if nil 99)") nil) +(cl-test "if: number truthy" (ev "(if 0 'yes 'no)") "YES") +(cl-test "if: empty string truthy" (ev "(if \"\" 'yes 'no)") "YES") +(cl-test "if: nested" (ev "(if t (if nil 1 2) 3)") 2) + +;; ── PROGN ──────────────────────────────────────────────────────── + +(cl-test "progn: single" (ev "(progn 42)") 42) +(cl-test "progn: multiple" (ev "(progn 1 2 3)") 3) +(cl-test "progn: nil last" (ev "(progn 1 nil)") nil) + +;; ── AND / OR ───────────────────────────────────────────────────── + +(cl-test "and: empty" (ev "(and)") true) +(cl-test "and: all true" (ev "(and 1 2 3)") 3) +(cl-test "and: short-circuit" (ev "(and nil 99)") nil) +(cl-test "and: returns last" (ev "(and 1 2)") 2) +(cl-test "or: empty" (ev "(or)") nil) +(cl-test "or: first truthy" (ev "(or 1 2)") 1) +(cl-test "or: all nil" (ev "(or nil nil)") nil) +(cl-test "or: short-circuit" (ev "(or nil 42)") 42) + +;; ── COND ───────────────────────────────────────────────────────── + +(cl-test "cond: first match" (ev "(cond (t 1) (t 2))") 1) +(cl-test "cond: second match" (ev "(cond (nil 1) (t 2))") 2) +(cl-test "cond: no match" (ev "(cond (nil 1) (nil 2))") nil) +(cl-test "cond: returns test value" (ev "(cond (42))") 42) + +;; ── WHEN / UNLESS ───────────────────────────────────────────────── + +(cl-test "when: true" (ev "(when t 1 2 3)") 3) +(cl-test "when: nil" (ev "(when nil 99)") nil) +(cl-test "unless: nil runs" (ev "(unless nil 42)") 42) +(cl-test "unless: true skips" (ev "(unless t 99)") nil) + +;; ── LET ────────────────────────────────────────────────────────── + +(cl-test "let: empty bindings" (ev "(let () 42)") 42) +(cl-test "let: single binding" (ev "(let ((x 5)) x)") 5) +(cl-test "let: two bindings" (ev "(let ((x 3) (y 4)) (+ x y))") 7) +(cl-test "let: parallel" (ev "(let ((x 1)) (let ((x 2) (y x)) y))") 1) +(cl-test "let: nested" (ev "(let ((x 1)) (let ((y 2)) (+ x y)))") 3) +(cl-test "let: progn body" (ev "(let ((x 5)) (+ x 1) (* x 2))") 10) +(cl-test "let: bare name nil" (ev "(let (x) x)") nil) + +;; ── LET* ───────────────────────────────────────────────────────── + +(cl-test "let*: sequential" (ev "(let* ((x 1) (y (+ x 1))) y)") 2) +(cl-test "let*: chain" (ev "(let* ((a 2) (b (* a 3)) (c (+ b 1))) c)") 7) +(cl-test "let*: shadow" (ev "(let ((x 1)) (let* ((x 2) (y x)) y))") 2) + +;; ── SETQ / SETF ────────────────────────────────────────────────── + +(cl-test "setq: basic" (ev "(let ((x 0)) (setq x 5) x)") 5) +(cl-test "setq: returns value" (ev "(let ((x 0)) (setq x 99))") 99) +(cl-test "setf: basic" (ev "(let ((x 0)) (setf x 7) x)") 7) + +;; ── LAMBDA ──────────────────────────────────────────────────────── + +(cl-test "lambda: call" (ev "((lambda (x) x) 42)") 42) +(cl-test "lambda: multi-arg" (ev "((lambda (x y) (+ x y)) 3 4)") 7) +(cl-test "lambda: closure" (ev "(let ((n 10)) ((lambda (x) (+ x n)) 5))") 15) +(cl-test "lambda: rest arg" + (ev "((lambda (x &rest xs) (cons x xs)) 1 2 3)") + {:cl-type "cons" :car 1 :cdr (list 2 3)}) +(cl-test "lambda: optional no default" + (ev "((lambda (&optional x) x))") + nil) +(cl-test "lambda: optional with arg" + (ev "((lambda (&optional (x 99)) x) 42)") + 42) +(cl-test "lambda: optional default used" + (ev "((lambda (&optional (x 7)) x))") + 7) + +;; ── FUNCTION ───────────────────────────────────────────────────── + +(cl-test "function: lambda" (get (ev "(function (lambda (x) x))") "cl-type") "function") + +;; ── DEFUN ──────────────────────────────────────────────────────── + +(cl-test "defun: returns name" (evall "(defun sq (x) (* x x))") "SQ") +(cl-test "defun: call" (evall "(defun sq (x) (* x x)) (sq 5)") 25) +(cl-test "defun: multi-arg" (evall "(defun add (x y) (+ x y)) (add 3 4)") 7) +(cl-test "defun: recursive factorial" + (evall "(defun fact (n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)") + 120) +(cl-test "defun: multiple calls" + (evall "(defun double (x) (* x 2)) (+ (double 3) (double 5))") + 16) + +;; ── FLET ───────────────────────────────────────────────────────── + +(cl-test "flet: basic" + (ev "(flet ((double (x) (* x 2))) (double 5))") + 10) +(cl-test "flet: sees outer vars" + (ev "(let ((n 3)) (flet ((add-n (x) (+ x n))) (add-n 7)))") + 10) +(cl-test "flet: non-recursive" + (ev "(flet ((f (x) (+ x 1))) (flet ((f (x) (f (f x)))) (f 5)))") + 7) + +;; ── LABELS ──────────────────────────────────────────────────────── + +(cl-test "labels: basic" + (ev "(labels ((greet (x) x)) (greet 42))") + 42) +(cl-test "labels: recursive" + (ev "(labels ((count (n) (if (<= n 0) 0 (+ 1 (count (- n 1)))))) (count 5))") + 5) +(cl-test "labels: mutual recursion" + (ev "(labels + ((even? (n) (if (= n 0) t (odd? (- n 1)))) + (odd? (n) (if (= n 0) nil (even? (- n 1))))) + (list (even? 4) (odd? 3)))") + (list true true)) + +;; ── THE / LOCALLY / EVAL-WHEN ──────────────────────────────────── + +(cl-test "the: passthrough" (ev "(the integer 42)") 42) +(cl-test "the: string" (ev "(the string \"hi\")") "hi") +(cl-test "locally: body" (ev "(locally 1 2 3)") 3) +(cl-test "eval-when: execute" (ev "(eval-when (:execute) 99)") 99) +(cl-test "eval-when: no execute" (ev "(eval-when (:compile-toplevel) 99)") nil) + +;; ── DEFVAR / DEFPARAMETER ──────────────────────────────────────── + +(cl-test "defvar: returns name" (evall "(defvar *x* 10)") "*X*") +(cl-test "defparameter: sets value" (evall "(defparameter *y* 42) *y*") 42) +(cl-test "defvar: no reinit" (evall "(defvar *z* 1) (defvar *z* 99) *z*") 1) + +;; ── built-in arithmetic ─────────────────────────────────────────── + +(cl-test "arith: +" (ev "(+ 1 2 3)") 6) +(cl-test "arith: + zero" (ev "(+)") 0) +(cl-test "arith: -" (ev "(- 10 3 2)") 5) +(cl-test "arith: - negate" (ev "(- 5)") -5) +(cl-test "arith: *" (ev "(* 2 3 4)") 24) +(cl-test "arith: * one" (ev "(*)") 1) +(cl-test "arith: /" (ev "(/ 12 3)") 4) +(cl-test "arith: max" (ev "(max 3 1 4 1 5)") 5) +(cl-test "arith: min" (ev "(min 3 1 4 1 5)") 1) +(cl-test "arith: abs neg" (ev "(abs -7)") 7) +(cl-test "arith: abs pos" (ev "(abs 7)") 7) + +;; ── built-in comparisons ────────────────────────────────────────── + +(cl-test "cmp: = true" (ev "(= 3 3)") true) +(cl-test "cmp: = false" (ev "(= 3 4)") nil) +(cl-test "cmp: /=" (ev "(/= 3 4)") true) +(cl-test "cmp: <" (ev "(< 1 2)") true) +(cl-test "cmp: > false" (ev "(> 1 2)") nil) +(cl-test "cmp: <=" (ev "(<= 2 2)") true) + +;; ── built-in predicates ─────────────────────────────────────────── + +(cl-test "pred: null nil" (ev "(null nil)") true) +(cl-test "pred: null non-nil" (ev "(null 5)") nil) +(cl-test "pred: not nil" (ev "(not nil)") true) +(cl-test "pred: not truthy" (ev "(not 5)") nil) +(cl-test "pred: numberp" (ev "(numberp 5)") true) +(cl-test "pred: numberp str" (ev "(numberp \"x\")") nil) +(cl-test "pred: stringp" (ev "(stringp \"hello\")") true) +(cl-test "pred: listp list" (ev "(listp '(1))") true) +(cl-test "pred: listp nil" (ev "(listp nil)") true) +(cl-test "pred: zerop" (ev "(zerop 0)") true) +(cl-test "pred: plusp" (ev "(plusp 3)") true) +(cl-test "pred: evenp" (ev "(evenp 4)") true) +(cl-test "pred: oddp" (ev "(oddp 3)") true) + +;; ── built-in list ops ───────────────────────────────────────────── + +(cl-test "list: car" (ev "(car '(1 2 3))") 1) +(cl-test "list: cdr" (ev "(cdr '(1 2 3))") (list 2 3)) +(cl-test "list: cons" (get (ev "(cons 1 2)") "car") 1) +(cl-test "list: list fn" (ev "(list 1 2 3)") (list 1 2 3)) +(cl-test "list: length" (ev "(length '(a b c))") 3) +(cl-test "list: length nil" (ev "(length nil)") 0) +(cl-test "list: append" (ev "(append '(1 2) '(3 4))") (list 1 2 3 4)) +(cl-test "list: first" (ev "(first '(10 20 30))") 10) +(cl-test "list: second" (ev "(second '(10 20 30))") 20) +(cl-test "list: third" (ev "(third '(10 20 30))") 30) +(cl-test "list: rest" (ev "(rest '(1 2 3))") (list 2 3)) +(cl-test "list: nth" (ev "(nth 1 '(a b c))") "B") +(cl-test "list: reverse" (ev "(reverse '(1 2 3))") (list 3 2 1)) + +;; ── FUNCALL / APPLY / MAPCAR ───────────────────────────────────── + +(cl-test "funcall: lambda" + (ev "(funcall (lambda (x) (* x x)) 5)") + 25) +(cl-test "apply: basic" + (ev "(apply #'+ '(1 2 3))") + 6) +(cl-test "apply: leading args" + (ev "(apply #'+ 1 2 '(3 4))") + 10) +(cl-test "mapcar: basic" + (ev "(mapcar (lambda (x) (* x 2)) '(1 2 3))") + (list 2 4 6)) + +;; ── BLOCK / RETURN-FROM / RETURN ───────────────────────────────── + +(cl-test "block: last form value" + (ev "(block done 1 2 3)") + 3) +(cl-test "block: empty body" + (ev "(block done)") + nil) +(cl-test "block: single form" + (ev "(block foo 42)") + 42) +(cl-test "block: return-from" + (ev "(block done 1 (return-from done 99) 2)") + 99) +(cl-test "block: return-from nil block" + (ev "(block nil 1 (return-from nil 42) 3)") + 42) +(cl-test "block: return-from no value" + (ev "(block done (return-from done))") + nil) +(cl-test "block: nested inner return stays inner" + (ev "(block outer (block inner (return-from inner 1) 2) 3)") + 3) +(cl-test "block: nested outer return" + (ev "(block outer (block inner 1 2) (return-from outer 99) 3)") + 99) +(cl-test "return: shorthand for nil block" + (ev "(block nil (return 77))") + 77) +(cl-test "return: no value" + (ev "(block nil 1 (return) 2)") + nil) +(cl-test "block: return-from inside let" + (ev "(block done (let ((x 5)) (when (> x 3) (return-from done x))) 0)") + 5) +(cl-test "block: return-from inside progn" + (ev "(block done (progn (return-from done 7) 99))") + 7) +(cl-test "block: return-from through function" + (ev "(block done (flet ((f () (return-from done 42))) (f)) nil)") + 42) + +;; ── TAGBODY / GO ───────────────────────────────────────────────── + +(cl-test "tagbody: empty returns nil" + (ev "(tagbody)") + nil) +(cl-test "tagbody: forms only, returns nil" + (ev "(let ((x 0)) (tagbody (setq x 1) (setq x 2)) x)") + 2) +(cl-test "tagbody: tag only, returns nil" + (ev "(tagbody done)") + nil) +(cl-test "tagbody: go skips forms" + (ev "(let ((x 0)) (tagbody (go done) (setq x 99) done) x)") + 0) +(cl-test "tagbody: go to later tag" + (ev "(let ((x 0)) (tagbody start (setq x (+ x 1)) (go done) (setq x 99) done) x)") + 1) +(cl-test "tagbody: loop with counter" + (ev "(let ((n 0)) (tagbody loop (when (>= n 3) (go done)) (setq n (+ n 1)) (go loop) done) n)") + 3) +(cl-test "tagbody: go inside when" + (ev "(let ((x 0)) (tagbody (setq x 1) (when t (go done)) (setq x 99) done) x)") + 1) +(cl-test "tagbody: go inside progn" + (ev "(let ((x 0)) (tagbody (progn (setq x 1) (go done)) (setq x 99) done) x)") + 1) +(cl-test "tagbody: go inside let" + (ev "(let ((acc 0)) (tagbody (let ((y 5)) (when (> y 3) (go done))) (setq acc 99) done) acc)") + 0) +(cl-test "tagbody: integer tags" + (ev "(let ((x 0)) (tagbody (go 2) 1 (setq x 1) (go 3) 2 (setq x 2) (go 3) 3) x)") + 2) +(cl-test "tagbody: block-return propagates out" + (ev "(block done (tagbody (return-from done 42)) nil)") + 42) + +;; ── UNWIND-PROTECT ─────────────────────────────────────────────── + +(cl-test "unwind-protect: normal returns protected" + (ev "(unwind-protect 42 nil)") + 42) +(cl-test "unwind-protect: cleanup runs" + (ev "(let ((x 0)) (unwind-protect 1 (setq x 99)) x)") + 99) +(cl-test "unwind-protect: cleanup result ignored" + (ev "(unwind-protect 42 777)") + 42) +(cl-test "unwind-protect: multiple cleanup forms" + (ev "(let ((x 0)) (unwind-protect 1 (setq x (+ x 1)) (setq x (+ x 1))) x)") + 2) +(cl-test "unwind-protect: cleanup on return-from" + (ev "(let ((x 0)) (block done (unwind-protect (return-from done 7) (setq x 99))) x)") + 99) +(cl-test "unwind-protect: return-from still propagates" + (ev "(block done (unwind-protect (return-from done 42) nil))") + 42) +(cl-test "unwind-protect: cleanup on go" + (ev "(let ((x 0)) (tagbody (unwind-protect (go done) (setq x 1)) done) x)") + 1) +(cl-test "unwind-protect: nested, inner cleanup first" + (ev "(let ((n 0)) (unwind-protect (unwind-protect 1 (setq n (+ n 10))) (setq n (+ n 1))) n)") + 11) + +;; ── VALUES / MULTIPLE-VALUE-BIND / NTH-VALUE ──────────────────── + +(cl-test "values: single returns plain" + (ev "(values 42)") + 42) +(cl-test "values: zero returns nil" + (ev "(values)") + nil) +(cl-test "values: multi — primary via funcall" + (ev "(car (list (values 1 2)))") + 1) +(cl-test "multiple-value-bind: basic" + (ev "(multiple-value-bind (a b) (values 1 2) (+ a b))") + 3) +(cl-test "multiple-value-bind: extra vars get nil" + (ev "(multiple-value-bind (a b c) (values 10 20) (list a b c))") + (list 10 20 nil)) +(cl-test "multiple-value-bind: extra values ignored" + (ev "(multiple-value-bind (a) (values 1 2 3) a)") + 1) +(cl-test "multiple-value-bind: single value source" + (ev "(multiple-value-bind (a b) 42 (list a b))") + (list 42 nil)) +(cl-test "nth-value: 0" + (ev "(nth-value 0 (values 10 20 30))") + 10) +(cl-test "nth-value: 1" + (ev "(nth-value 1 (values 10 20 30))") + 20) +(cl-test "nth-value: out of range" + (ev "(nth-value 5 (values 10 20))") + nil) +(cl-test "multiple-value-call: basic" + (ev "(multiple-value-call #'+ (values 1 2) (values 3 4))") + 10) +(cl-test "multiple-value-prog1: returns first" + (ev "(multiple-value-prog1 1 2 3)") + 1) +(cl-test "multiple-value-prog1: side effects run" + (ev "(let ((x 0)) (multiple-value-prog1 99 (setq x 7)) x)") + 7) +(cl-test "values: nil primary in if" + (ev "(if (values nil t) 'yes 'no)") + "NO") +(cl-test "values: truthy primary in if" + (ev "(if (values 42 nil) 'yes 'no)") + "YES") + +;; --- Dynamic variables --- +(cl-test "defvar marks special" + (do (ev "(defvar *dv* 10)") + (cl-special? "*DV*")) + true) +(cl-test "defvar: let rebinds dynamically" + (ev "(progn (defvar *x* 1) (defun get-x () *x*) (let ((*x* 99)) (get-x)))") + 99) +(cl-test "defvar: binding restores after let" + (ev "(progn (defvar *yrst* 5) (let ((*yrst* 42)) *yrst*) *yrst*)") + 5) +(cl-test "defparameter marks special" + (do (ev "(defparameter *dp* 0)") + (cl-special? "*DP*")) + true) +(cl-test "defparameter: let rebinds dynamically" + (ev "(progn (defparameter *z* 10) (defun get-z () *z*) (let ((*z* 77)) (get-z)))") + 77) +(cl-test "defparameter: always assigns" + (ev "(progn (defparameter *p* 1) (defparameter *p* 2) *p*)") + 2) +(cl-test "dynamic binding: nested lets" + (ev "(progn (defvar *n* 0) (let ((*n* 1)) (let ((*n* 2)) *n*)))") + 2) +(cl-test "dynamic binding: restores across nesting" + (ev "(progn (defvar *m* 10) (let ((*m* 20)) (let ((*m* 30)) nil)) *m*)") + 10) diff --git a/lib/common-lisp/tests/lambda.sx b/lib/common-lisp/tests/lambda.sx new file mode 100644 index 00000000..fa56b6e6 --- /dev/null +++ b/lib/common-lisp/tests/lambda.sx @@ -0,0 +1,204 @@ +;; Lambda list parser tests + +(define cl-test-pass 0) +(define cl-test-fail 0) +(define cl-test-fails (list)) + +;; Deep structural equality for dicts and lists +(define + cl-deep= + (fn + (a b) + (cond + ((= a b) true) + ((and (dict? a) (dict? b)) + (let + ((ak (keys a)) (bk (keys b))) + (if + (not (= (len ak) (len bk))) + false + (every? + (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k)))) + ak)))) + ((and (list? a) (list? b)) + (if + (not (= (len a) (len b))) + false + (let + ((i 0) (ok true)) + (define + chk + (fn + () + (when + (and ok (< i (len a))) + (do + (when + (not (cl-deep= (nth a i) (nth b i))) + (set! ok false)) + (set! i (+ i 1)) + (chk))))) + (chk) + ok))) + (:else false)))) + +(define + cl-test + (fn + (name actual expected) + (if + (cl-deep= actual expected) + (set! cl-test-pass (+ cl-test-pass 1)) + (do + (set! cl-test-fail (+ cl-test-fail 1)) + (append! cl-test-fails {:name name :expected expected :actual actual}))))) + +;; Helper: parse lambda list from string "(x y ...)" +(define ll (fn (src) (cl-parse-lambda-list-str src))) +(define ll-req (fn (src) (get (ll src) "required"))) +(define ll-opt (fn (src) (get (ll src) "optional"))) +(define ll-rest (fn (src) (get (ll src) "rest"))) +(define ll-key (fn (src) (get (ll src) "key"))) +(define ll-aok (fn (src) (get (ll src) "allow-other-keys"))) +(define ll-aux (fn (src) (get (ll src) "aux"))) + +;; ── required parameters ─────────────────────────────────────────── + +(cl-test "required: empty" (ll-req "()") (list)) +(cl-test "required: one" (ll-req "(x)") (list "X")) +(cl-test "required: two" (ll-req "(x y)") (list "X" "Y")) +(cl-test "required: three" (ll-req "(a b c)") (list "A" "B" "C")) +(cl-test "required: upcased" (ll-req "(foo bar)") (list "FOO" "BAR")) + +;; ── &optional ───────────────────────────────────────────────────── + +(cl-test "optional: none" (ll-opt "(x)") (list)) + +(cl-test + "optional: bare symbol" + (ll-opt "(x &optional z)") + (list {:name "Z" :default nil :supplied nil})) + +(cl-test + "optional: with default" + (ll-opt "(x &optional (z 0))") + (list {:name "Z" :default 0 :supplied nil})) + +(cl-test + "optional: with supplied-p" + (ll-opt "(x &optional (z 0 z-p))") + (list {:name "Z" :default 0 :supplied "Z-P"})) + +(cl-test + "optional: two params" + (ll-opt "(&optional a (b 1))") + (list {:name "A" :default nil :supplied nil} {:name "B" :default 1 :supplied nil})) + +(cl-test + "optional: string default" + (ll-opt "(&optional (name \"world\"))") + (list {:name "NAME" :default {:cl-type "string" :value "world"} :supplied nil})) + +;; ── &rest ───────────────────────────────────────────────────────── + +(cl-test "rest: none" (ll-rest "(x)") nil) +(cl-test "rest: present" (ll-rest "(x &rest args)") "ARGS") +(cl-test "rest: with required" (ll-rest "(a b &rest tail)") "TAIL") + +;; &body is an alias for &rest +(cl-test "body: alias for rest" (ll-rest "(&body forms)") "FORMS") + +;; rest doesn't consume required params +(cl-test "rest: required still there" (ll-req "(a b &rest rest)") (list "A" "B")) + +;; ── &key ────────────────────────────────────────────────────────── + +(cl-test "key: none" (ll-key "(x)") (list)) + +(cl-test + "key: bare symbol" + (ll-key "(&key x)") + (list {:name "X" :keyword "X" :default nil :supplied nil})) + +(cl-test + "key: with default" + (ll-key "(&key (x 42))") + (list {:name "X" :keyword "X" :default 42 :supplied nil})) + +(cl-test + "key: with supplied-p" + (ll-key "(&key (x 42 x-p))") + (list {:name "X" :keyword "X" :default 42 :supplied "X-P"})) + +(cl-test + "key: two params" + (ll-key "(&key a b)") + (list + {:name "A" :keyword "A" :default nil :supplied nil} + {:name "B" :keyword "B" :default nil :supplied nil})) + +;; ── &allow-other-keys ───────────────────────────────────────────── + +(cl-test "aok: absent" (ll-aok "(x)") false) +(cl-test "aok: present" (ll-aok "(&key x &allow-other-keys)") true) + +;; ── &aux ────────────────────────────────────────────────────────── + +(cl-test "aux: none" (ll-aux "(x)") (list)) + +(cl-test + "aux: bare symbol" + (ll-aux "(&aux temp)") + (list {:name "TEMP" :init nil})) + +(cl-test + "aux: with init" + (ll-aux "(&aux (count 0))") + (list {:name "COUNT" :init 0})) + +(cl-test + "aux: two vars" + (ll-aux "(&aux a (b 1))") + (list {:name "A" :init nil} {:name "B" :init 1})) + +;; ── combined ────────────────────────────────────────────────────── + +(cl-test + "combined: full lambda list" + (let + ((parsed (ll "(x y &optional (z 0 z-p) &rest args &key a (b nil b-p) &aux temp)"))) + (list + (get parsed "required") + (get (nth (get parsed "optional") 0) "name") + (get (nth (get parsed "optional") 0) "default") + (get (nth (get parsed "optional") 0) "supplied") + (get parsed "rest") + (get (nth (get parsed "key") 0) "name") + (get (nth (get parsed "key") 1) "supplied") + (get (nth (get parsed "aux") 0) "name"))) + (list + (list "X" "Y") + "Z" + 0 + "Z-P" + "ARGS" + "A" + "B-P" + "TEMP")) + +(cl-test + "combined: required only stops before &" + (ll-req "(a b &optional c)") + (list "A" "B")) + +(cl-test + "combined: required only with &key" + (ll-req "(x &key y)") + (list "X")) + +(cl-test + "combined: &rest and &key together" + (let + ((parsed (ll "(&rest args &key verbose)"))) + (list (get parsed "rest") (get (nth (get parsed "key") 0) "name"))) + (list "ARGS" "VERBOSE")) diff --git a/lib/common-lisp/tests/macros.sx b/lib/common-lisp/tests/macros.sx new file mode 100644 index 00000000..5d1addae --- /dev/null +++ b/lib/common-lisp/tests/macros.sx @@ -0,0 +1,204 @@ +;; lib/common-lisp/tests/macros.sx — Phase 5: defmacro, gensym, LOOP tests +;; +;; Depends on: runtime.sx, eval.sx, loop.sx already loaded. +;; Tests via (ev "...") using the CL evaluator. + +(define ev (fn (src) (cl-eval-str src (cl-make-env)))) +(define evall (fn (src) (cl-eval-all-str src (cl-make-env)))) + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + check + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +;; ── defmacro basics ────────────────────────────────────────────────────────── + +(check + "defmacro returns name" + (ev "(defmacro my-or (a b) (list 'if a a b))") + "MY-OR") + +(check + "defmacro expansion works" + (ev "(progn (defmacro my-inc (x) (list '+ x 1)) (my-inc 5))") + 6) + +(check + "defmacro with &rest" + (ev "(progn (defmacro my-list (&rest xs) (cons 'list xs)) (my-list 1 2 3))") + (list 1 2 3)) + +(check + "nested macro expansion" + (ev "(progn (defmacro sq (x) (list '* x x)) (sq 7))") + 49) + +(check + "macro in conditional" + (ev + "(progn (defmacro my-when (c &rest body) (list 'if c (cons 'progn body) nil)) (my-when t 10 20))") + 20) + +(check + "macro returns nil branch" + (ev + "(progn (defmacro my-when (c &rest body) (list 'if c (cons 'progn body) nil)) (my-when nil 42))") + nil) + +;; ── macroexpand ─────────────────────────────────────────────────────────────── + +(check + "macroexpand returns expanded form" + (ev "(progn (defmacro double (x) (list '+ x x)) (macroexpand '(double 5)))") + (list "+" 5 5)) + +;; ── gensym ──────────────────────────────────────────────────────────────────── + +(check "gensym returns string" (ev "(stringp (gensym))") true) + +(check + "gensym prefix" + (ev "(let ((g (gensym \"MY\"))) (not (= g nil)))") + true) + +(check "gensyms are unique" (ev "(not (= (gensym) (gensym)))") true) + +;; ── swap! macro with gensym ─────────────────────────────────────────────────── + +(check + "swap! macro" + (evall + "(defmacro swap! (a b) (let ((tmp (gensym))) (list 'let (list (list tmp a)) (list 'setq a b) (list 'setq b tmp)))) (defvar *a* 10) (defvar *b* 20) (swap! *a* *b*) (list *a* *b*)") + (list 20 10)) + +;; ── LOOP: basic repeat and collect ──────────────────────────────────────────── + +(check + "loop repeat collect" + (ev "(loop repeat 3 collect 99)") + (list 99 99 99)) + +(check + "loop for-in collect" + (ev "(loop for x in '(1 2 3) collect (* x x))") + (list 1 4 9)) + +(check + "loop for-from-to collect" + (ev "(loop for i from 1 to 5 collect i)") + (list 1 2 3 4 5)) + +(check + "loop for-from-below collect" + (ev "(loop for i from 0 below 4 collect i)") + (list 0 1 2 3)) + +(check + "loop for-downto collect" + (ev "(loop for i from 5 downto 1 collect i)") + (list 5 4 3 2 1)) + +(check + "loop for-by collect" + (ev "(loop for i from 0 to 10 by 2 collect i)") + (list 0 2 4 6 8 10)) + +;; ── LOOP: sum, count, maximize, minimize ───────────────────────────────────── + +(check "loop sum" (ev "(loop for i from 1 to 5 sum i)") 15) + +(check + "loop count" + (ev "(loop for x in '(1 2 3 4 5) count (> x 3))") + 2) + +(check + "loop maximize" + (ev "(loop for x in '(3 1 4 1 5 9 2 6) maximize x)") + 9) + +(check + "loop minimize" + (ev "(loop for x in '(3 1 4 1 5 9 2 6) minimize x)") + 1) + +;; ── LOOP: while and until ───────────────────────────────────────────────────── + +(check + "loop while" + (ev "(loop for i from 1 to 10 while (< i 5) collect i)") + (list 1 2 3 4)) + +(check + "loop until" + (ev "(loop for i from 1 to 10 until (= i 5) collect i)") + (list 1 2 3 4)) + +;; ── LOOP: when / unless ─────────────────────────────────────────────────────── + +(check + "loop when filter" + (ev "(loop for i from 0 below 8 when (evenp i) collect i)") + (list 0 2 4 6)) + +(check + "loop unless filter" + (ev "(loop for i from 0 below 8 unless (evenp i) collect i)") + (list 1 3 5 7)) + +;; ── LOOP: append ───────────────────────────────────────────────────────────── + +(check + "loop append" + (ev "(loop for x in '((1 2) (3 4) (5 6)) append x)") + (list 1 2 3 4 5 6)) + +;; ── LOOP: always, never, thereis ───────────────────────────────────────────── + +(check + "loop always true" + (ev "(loop for x in '(2 4 6) always (evenp x))") + true) + +(check + "loop always false" + (ev "(loop for x in '(2 3 6) always (evenp x))") + false) + +(check "loop never" (ev "(loop for x in '(1 3 5) never (evenp x))") true) + +(check "loop thereis" (ev "(loop for x in '(1 2 3) thereis (> x 2))") true) + +;; ── LOOP: for = then (general iteration) ───────────────────────────────────── + +(check + "loop for = then doubling" + (ev "(loop repeat 5 for x = 1 then (* x 2) collect x)") + (list 1 2 4 8 16)) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define macro-passed passed) +(define macro-failed failed) +(define macro-failures failures) diff --git a/lib/common-lisp/tests/parse.sx b/lib/common-lisp/tests/parse.sx new file mode 100644 index 00000000..ba39a4aa --- /dev/null +++ b/lib/common-lisp/tests/parse.sx @@ -0,0 +1,160 @@ +;; Common Lisp reader/parser tests + +(define cl-test-pass 0) +(define cl-test-fail 0) +(define cl-test-fails (list)) + +(define + cl-deep= + (fn + (a b) + (cond + ((= a b) true) + ((and (dict? a) (dict? b)) + (let + ((ak (keys a)) (bk (keys b))) + (if + (not (= (len ak) (len bk))) + false + (every? + (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k)))) + ak)))) + ((and (list? a) (list? b)) + (if + (not (= (len a) (len b))) + false + (let + ((i 0) (ok true)) + (define + chk + (fn + () + (when + (and ok (< i (len a))) + (do + (when + (not (cl-deep= (nth a i) (nth b i))) + (set! ok false)) + (set! i (+ i 1)) + (chk))))) + (chk) + ok))) + (:else false)))) + +(define + cl-test + (fn + (name actual expected) + (if + (cl-deep= actual expected) + (set! cl-test-pass (+ cl-test-pass 1)) + (do + (set! cl-test-fail (+ cl-test-fail 1)) + (append! cl-test-fails {:name name :expected expected :actual actual}))))) + +;; ── atoms ───────────────────────────────────────────────────────── + +(cl-test "integer: 42" (cl-read "42") 42) +(cl-test "integer: 0" (cl-read "0") 0) +(cl-test "integer: negative" (cl-read "-5") -5) +(cl-test "integer: positive sign" (cl-read "+3") 3) +(cl-test "integer: hex #xFF" (cl-read "#xFF") 255) +(cl-test "integer: hex #xAB" (cl-read "#xAB") 171) +(cl-test "integer: binary #b1010" (cl-read "#b1010") 10) +(cl-test "integer: octal #o17" (cl-read "#o17") 15) + +(cl-test "float: type" (get (cl-read "3.14") "cl-type") "float") +(cl-test "float: value" (get (cl-read "3.14") "value") "3.14") +(cl-test "float: neg" (get (cl-read "-2.5") "value") "-2.5") +(cl-test "float: exp" (get (cl-read "1.0e10") "value") "1.0e10") + +(cl-test "ratio: type" (get (cl-read "1/3") "cl-type") "ratio") +(cl-test "ratio: value" (get (cl-read "1/3") "value") "1/3") +(cl-test "ratio: 22/7" (get (cl-read "22/7") "value") "22/7") + +(cl-test "string: basic" (cl-read "\"hello\"") {:cl-type "string" :value "hello"}) +(cl-test "string: empty" (cl-read "\"\"") {:cl-type "string" :value ""}) +(cl-test "string: with escape" (cl-read "\"a\\nb\"") {:cl-type "string" :value "a\nb"}) + +(cl-test "symbol: foo" (cl-read "foo") "FOO") +(cl-test "symbol: BAR" (cl-read "BAR") "BAR") +(cl-test "symbol: pkg:sym" (cl-read "cl:car") "CL:CAR") +(cl-test "symbol: pkg::sym" (cl-read "pkg::foo") "PKG::FOO") + +(cl-test "nil: symbol" (cl-read "nil") nil) +(cl-test "nil: uppercase" (cl-read "NIL") nil) +(cl-test "t: symbol" (cl-read "t") true) +(cl-test "t: uppercase" (cl-read "T") true) + +(cl-test "keyword: type" (get (cl-read ":foo") "cl-type") "keyword") +(cl-test "keyword: name" (get (cl-read ":foo") "name") "FOO") +(cl-test "keyword: :test" (get (cl-read ":test") "name") "TEST") + +(cl-test "char: type" (get (cl-read "#\\a") "cl-type") "char") +(cl-test "char: value" (get (cl-read "#\\a") "value") "a") +(cl-test "char: Space" (get (cl-read "#\\Space") "value") " ") +(cl-test "char: Newline" (get (cl-read "#\\Newline") "value") "\n") + +(cl-test "uninterned: type" (get (cl-read "#:foo") "cl-type") "uninterned") +(cl-test "uninterned: name" (get (cl-read "#:foo") "name") "FOO") + +;; ── lists ───────────────────────────────────────────────────────── + +(cl-test "list: empty" (cl-read "()") (list)) +(cl-test "list: one element" (cl-read "(foo)") (list "FOO")) +(cl-test "list: two elements" (cl-read "(foo bar)") (list "FOO" "BAR")) +(cl-test "list: nested" (cl-read "((a b) c)") (list (list "A" "B") "C")) +(cl-test "list: with integer" (cl-read "(+ 1 2)") (list "+" 1 2)) +(cl-test "list: with string" (cl-read "(print \"hi\")") (list "PRINT" {:cl-type "string" :value "hi"})) +(cl-test "list: nil element" (cl-read "(a nil b)") (list "A" nil "B")) +(cl-test "list: t element" (cl-read "(a t b)") (list "A" true "B")) + +;; ── dotted pairs ──────────────────────────────────────────────��── + +(cl-test "dotted: type" (get (cl-read "(a . b)") "cl-type") "cons") +(cl-test "dotted: car" (get (cl-read "(a . b)") "car") "A") +(cl-test "dotted: cdr" (get (cl-read "(a . b)") "cdr") "B") +(cl-test "dotted: number cdr" (get (cl-read "(x . 42)") "cdr") 42) + +;; ── reader macros ────────────────────────────────────────────────�� + +(cl-test "quote: form" (cl-read "'x") (list "QUOTE" "X")) +(cl-test "quote: list" (cl-read "'(a b)") (list "QUOTE" (list "A" "B"))) +(cl-test "backquote: form" (cl-read "`x") (list "QUASIQUOTE" "X")) +(cl-test "unquote: form" (cl-read ",x") (list "UNQUOTE" "X")) +(cl-test "comma-at: form" (cl-read ",@x") (list "UNQUOTE-SPLICING" "X")) +(cl-test "function: form" (cl-read "#'foo") (list "FUNCTION" "FOO")) + +;; ── vector ──────────────────────────────────────────────────────── + +(cl-test "vector: type" (get (cl-read "#(1 2 3)") "cl-type") "vector") +(cl-test "vector: elements" (get (cl-read "#(1 2 3)") "elements") (list 1 2 3)) +(cl-test "vector: empty" (get (cl-read "#()") "elements") (list)) +(cl-test "vector: mixed" (get (cl-read "#(a 1 \"s\")") "elements") (list "A" 1 {:cl-type "string" :value "s"})) + +;; ── cl-read-all ─────────────────────────────────────────────────── + +(cl-test + "read-all: empty" + (cl-read-all "") + (list)) + +(cl-test + "read-all: two forms" + (cl-read-all "42 foo") + (list 42 "FOO")) + +(cl-test + "read-all: three forms" + (cl-read-all "(+ 1 2) (+ 3 4) hello") + (list (list "+" 1 2) (list "+" 3 4) "HELLO")) + +(cl-test + "read-all: with comments" + (cl-read-all "; this is a comment\n42 ; inline\nfoo") + (list 42 "FOO")) + +(cl-test + "read-all: defun form" + (nth (cl-read-all "(defun square (x) (* x x))") 0) + (list "DEFUN" "SQUARE" (list "X") (list "*" "X" "X"))) diff --git a/lib/common-lisp/tests/programs/geometry.sx b/lib/common-lisp/tests/programs/geometry.sx new file mode 100644 index 00000000..a7e17188 --- /dev/null +++ b/lib/common-lisp/tests/programs/geometry.sx @@ -0,0 +1,291 @@ +;; geometry.sx — Multiple dispatch with CLOS +;; +;; Demonstrates generic functions dispatching on combinations of +;; geometric types: point, line, plane. +;; +;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx + +;; ── geometric classes ────────────────────────────────────────────────────── + +(clos-defclass "geo-point" (list "t") (list {:initform 0 :initarg ":px" :reader nil :writer nil :accessor nil :name "px"} {:initform 0 :initarg ":py" :reader nil :writer nil :accessor nil :name "py"})) + +(clos-defclass "geo-line" (list "t") (list {:initform nil :initarg ":p1" :reader nil :writer nil :accessor nil :name "p1"} {:initform nil :initarg ":p2" :reader nil :writer nil :accessor nil :name "p2"})) + +(clos-defclass "geo-plane" (list "t") (list {:initform nil :initarg ":normal" :reader nil :writer nil :accessor nil :name "normal"} {:initform 0 :initarg ":d" :reader nil :writer nil :accessor nil :name "d"})) + +;; ── helpers ──────────────────────────────────────────────────────────────── + +(define geo-point-x (fn (p) (clos-slot-value p "px"))) +(define geo-point-y (fn (p) (clos-slot-value p "py"))) + +(define + geo-make-point + (fn (x y) (clos-make-instance "geo-point" ":px" x ":py" y))) + +(define + geo-make-line + (fn (p1 p2) (clos-make-instance "geo-line" ":p1" p1 ":p2" p2))) + +(define + geo-make-plane + (fn + (nx ny d) + (clos-make-instance "geo-plane" ":normal" (list nx ny) ":d" d))) + +;; ── describe generic ─────────────────────────────────────────────────────── + +(clos-defgeneric "geo-describe" {}) + +(clos-defmethod + "geo-describe" + (list) + (list "geo-point") + (fn + (args next-fn) + (let + ((p (first args))) + (str "P(" (geo-point-x p) "," (geo-point-y p) ")")))) + +(clos-defmethod + "geo-describe" + (list) + (list "geo-line") + (fn + (args next-fn) + (let + ((l (first args))) + (str + "L[" + (clos-call-generic "geo-describe" (list (clos-slot-value l "p1"))) + "-" + (clos-call-generic "geo-describe" (list (clos-slot-value l "p2"))) + "]")))) + +(clos-defmethod + "geo-describe" + (list) + (list "geo-plane") + (fn + (args next-fn) + (let + ((pl (first args))) + (str "Plane(d=" (clos-slot-value pl "d") ")")))) + +;; ── intersect: multi-dispatch generic ───────────────────────────────────── +;; +;; Returns a string description of the intersection result. + +(clos-defgeneric "intersect" {}) + +;; point ∩ point: same if coordinates match +(clos-defmethod + "intersect" + (list) + (list "geo-point" "geo-point") + (fn + (args next-fn) + (let + ((p1 (first args)) (p2 (first (rest args)))) + (if + (and + (= (geo-point-x p1) (geo-point-x p2)) + (= (geo-point-y p1) (geo-point-y p2))) + "point" + "empty")))) + +;; point ∩ line: check if point lies on line (cross product = 0) +(clos-defmethod + "intersect" + (list) + (list "geo-point" "geo-line") + (fn + (args next-fn) + (let + ((pt (first args)) (ln (first (rest args)))) + (let + ((lp1 (clos-slot-value ln "p1")) (lp2 (clos-slot-value ln "p2"))) + (let + ((dx (- (geo-point-x lp2) (geo-point-x lp1))) + (dy (- (geo-point-y lp2) (geo-point-y lp1))) + (ex (- (geo-point-x pt) (geo-point-x lp1))) + (ey (- (geo-point-y pt) (geo-point-y lp1)))) + (if (= (- (* dx ey) (* dy ex)) 0) "point" "empty")))))) + +;; line ∩ line: parallel (same slope = empty) or point +(clos-defmethod + "intersect" + (list) + (list "geo-line" "geo-line") + (fn + (args next-fn) + (let + ((l1 (first args)) (l2 (first (rest args)))) + (let + ((p1 (clos-slot-value l1 "p1")) + (p2 (clos-slot-value l1 "p2")) + (p3 (clos-slot-value l2 "p1")) + (p4 (clos-slot-value l2 "p2"))) + (let + ((dx1 (- (geo-point-x p2) (geo-point-x p1))) + (dy1 (- (geo-point-y p2) (geo-point-y p1))) + (dx2 (- (geo-point-x p4) (geo-point-x p3))) + (dy2 (- (geo-point-y p4) (geo-point-y p3)))) + (let + ((cross (- (* dx1 dy2) (* dy1 dx2)))) + (if (= cross 0) "parallel" "point"))))))) + +;; line ∩ plane: general case = point (or parallel if line ⊥ normal) +(clos-defmethod + "intersect" + (list) + (list "geo-line" "geo-plane") + (fn + (args next-fn) + (let + ((ln (first args)) (pl (first (rest args)))) + (let + ((p1 (clos-slot-value ln "p1")) + (p2 (clos-slot-value ln "p2")) + (n (clos-slot-value pl "normal"))) + (let + ((dx (- (geo-point-x p2) (geo-point-x p1))) + (dy (- (geo-point-y p2) (geo-point-y p1))) + (nx (first n)) + (ny (first (rest n)))) + (let + ((dot (+ (* dx nx) (* dy ny)))) + (if (= dot 0) "parallel" "point"))))))) + +;; ── tests ───────────────────────────────────────────────────────────────── + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + check + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +;; describe +(check + "describe point" + (clos-call-generic + "geo-describe" + (list (geo-make-point 3 4))) + "P(3,4)") +(check + "describe line" + (clos-call-generic + "geo-describe" + (list + (geo-make-line + (geo-make-point 0 0) + (geo-make-point 1 1)))) + "L[P(0,0)-P(1,1)]") +(check + "describe plane" + (clos-call-generic + "geo-describe" + (list (geo-make-plane 0 1 5))) + "Plane(d=5)") + +;; intersect point×point +(check + "P∩P same" + (clos-call-generic + "intersect" + (list + (geo-make-point 2 3) + (geo-make-point 2 3))) + "point") +(check + "P∩P diff" + (clos-call-generic + "intersect" + (list + (geo-make-point 1 2) + (geo-make-point 3 4))) + "empty") + +;; intersect point×line +(let + ((origin (geo-make-point 0 0)) + (p10 (geo-make-point 10 0)) + (p55 (geo-make-point 5 5)) + (l-x + (geo-make-line + (geo-make-point 0 0) + (geo-make-point 10 0)))) + (begin + (check + "P∩L on line" + (clos-call-generic "intersect" (list p10 l-x)) + "point") + (check + "P∩L on x-axis" + (clos-call-generic "intersect" (list origin l-x)) + "point") + (check + "P∩L off line" + (clos-call-generic "intersect" (list p55 l-x)) + "empty"))) + +;; intersect line×line +(let + ((horiz (geo-make-line (geo-make-point 0 0) (geo-make-point 10 0))) + (vert + (geo-make-line + (geo-make-point 5 -5) + (geo-make-point 5 5))) + (horiz2 + (geo-make-line + (geo-make-point 0 3) + (geo-make-point 10 3)))) + (begin + (check + "L∩L crossing" + (clos-call-generic "intersect" (list horiz vert)) + "point") + (check + "L∩L parallel" + (clos-call-generic "intersect" (list horiz horiz2)) + "parallel"))) + +;; intersect line×plane +(let + ((diag (geo-make-line (geo-make-point 0 0) (geo-make-point 1 1))) + (vert-plane (geo-make-plane 1 0 5)) + (diag-plane (geo-make-plane -1 1 0))) + (begin + (check + "L∩Plane cross" + (clos-call-generic "intersect" (list diag vert-plane)) + "point") + (check + "L∩Plane parallel" + (clos-call-generic "intersect" (list diag diag-plane)) + "parallel"))) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define geo-passed passed) +(define geo-failed failed) +(define geo-failures failures) \ No newline at end of file diff --git a/lib/common-lisp/tests/programs/interactive-debugger.sx b/lib/common-lisp/tests/programs/interactive-debugger.sx new file mode 100644 index 00000000..cf089aa8 --- /dev/null +++ b/lib/common-lisp/tests/programs/interactive-debugger.sx @@ -0,0 +1,196 @@ +;; interactive-debugger.sx — Condition debugger using *debugger-hook* +;; +;; Demonstrates the classic CL debugger pattern: +;; - *debugger-hook* is invoked when an unhandled error reaches the top level +;; - The hook receives the condition and a reference to itself +;; - It can offer restarts interactively (here simulated with a policy fn) +;; +;; In real CL the debugger reads from the terminal. Here we simulate +;; the "user input" via a policy function passed in at call time. +;; +;; Depends on: lib/common-lisp/runtime.sx already loaded. + +;; ── *debugger-hook* global ──────────────────────────────────────────────── +;; +;; CL: when error is unhandled, invoke *debugger-hook* with (condition hook). +;; A nil hook means use the system default (which we simulate as re-raise). + +(define cl-debugger-hook nil) + +;; ── invoke-debugger ──────────────────────────────────────────────────────── +;; +;; Called when cl-error finds no handler. Tries cl-debugger-hook first; +;; falls back to a simple error report. + +(define + cl-invoke-debugger + (fn + (c) + (if + (nil? cl-debugger-hook) + (error (str "Debugger: " (cl-condition-message c))) + (begin + (let + ((hook cl-debugger-hook)) + (set! cl-debugger-hook nil) + (let + ((result (hook c hook))) + (set! cl-debugger-hook hook) + result)))))) + +;; ── cl-error/debugger — error that routes through invoke-debugger ───────── + +(define + cl-error-with-debugger + (fn + (c &rest args) + (let + ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c)))))) + (cl-signal-obj obj cl-handler-stack) + (cl-invoke-debugger obj)))) + +;; ── simulated debugger session ──────────────────────────────────────────── +;; +;; A debugger hook takes (condition hook) and "reads" user commands. +;; We simulate this with a policy function: (fn (c restarts) restart-name) +;; that picks a restart given the condition and available restarts. + +(define + make-policy-debugger + (fn + (policy) + (fn + (c hook) + (let + ((available (cl-compute-restarts))) + (let + ((choice (policy c available))) + (if + (and choice (not (nil? (cl-find-restart choice)))) + (cl-invoke-restart choice) + (error + (str + "Debugger: no restart chosen for: " + (cl-condition-message c))))))))) + +;; ── tests ───────────────────────────────────────────────────────────────── + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + check + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +(define + reset-stacks! + (fn + () + (set! cl-handler-stack (list)) + (set! cl-restart-stack (list)) + (set! cl-debugger-hook nil))) + +;; Test 1: debugger hook receives condition +(reset-stacks!) +(let + ((received-msg "")) + (begin + (set! + cl-debugger-hook + (fn (c hook) (set! received-msg (cl-condition-message c)) nil)) + (cl-restart-case + (fn () (cl-error-with-debugger "something broke")) + (list "abort" (list) (fn () nil))) + (check "debugger hook receives condition" received-msg "something broke"))) + +;; Test 2: policy-driven restart selection (use-zero) +(reset-stacks!) +(let + ((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "use-zero"))) (cl-restart-case (fn () (cl-error-with-debugger (cl-make-condition "division-by-zero")) 999) (list "use-zero" (list) (fn () 0)))))) + (check "policy debugger: use-zero restart" result 0)) + +;; Test 3: policy selects abort +(reset-stacks!) +(let + ((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "abort"))) (cl-restart-case (fn () (cl-error-with-debugger "aborting error") 999) (list "abort" (list) (fn () "aborted")))))) + (check "policy debugger: abort restart" result "aborted")) + +;; Test 4: compute-restarts inside debugger hook +(reset-stacks!) +(let + ((seen-restarts (list))) + (begin + (set! + cl-debugger-hook + (fn + (c hook) + (set! seen-restarts (cl-compute-restarts)) + (cl-invoke-restart "continue"))) + (cl-restart-case + (fn () (cl-error-with-debugger "test") 42) + (list "continue" (list) (fn () "ok")) + (list "abort" (list) (fn () "no"))) + (check + "debugger: compute-restarts visible" + (= (len seen-restarts) 2) + true))) + +;; Test 5: hook not invoked when handler catches first +(reset-stacks!) +(let + ((hook-called false) + (result + (begin + (set! cl-debugger-hook (fn (c hook) (set! hook-called true) nil)) + (cl-handler-case + (fn () (cl-error-with-debugger "handled")) + (list "error" (fn (c) "handler-won")))))) + (check "handler wins; hook not called" hook-called false) + (check "handler result returned" result "handler-won")) + +;; Test 6: debugger-hook nil after re-raise guard +(reset-stacks!) +(let + ((hook-calls 0)) + (begin + (set! + cl-debugger-hook + (fn + (c hook) + (set! hook-calls (+ hook-calls 1)) + (if + (> hook-calls 1) + (error "infinite loop guard") + (cl-invoke-restart "escape")))) + (cl-restart-case + (fn () (cl-error-with-debugger "once")) + (list "escape" (list) (fn () nil))) + (check + "hook called exactly once (no infinite recursion)" + hook-calls + 1))) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define debugger-passed passed) +(define debugger-failed failed) +(define debugger-failures failures) \ No newline at end of file diff --git a/lib/common-lisp/tests/programs/mop-trace.sx b/lib/common-lisp/tests/programs/mop-trace.sx new file mode 100644 index 00000000..4b3ecb8a --- /dev/null +++ b/lib/common-lisp/tests/programs/mop-trace.sx @@ -0,0 +1,228 @@ +;; mop-trace.sx — :before/:after method tracing with CLOS +;; +;; Classic CLOS pattern: instrument generic functions with :before and :after +;; qualifiers to print call/return traces without modifying the primary method. +;; +;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx + +;; ── trace log (mutable accumulator) ─────────────────────────────────────── + +(define trace-log (list)) + +(define + trace-push + (fn (msg) (set! trace-log (append trace-log (list msg))))) + +(define trace-clear (fn () (set! trace-log (list)))) + +;; ── domain classes ───────────────────────────────────────────────────────── + +(clos-defclass "shape" (list "t") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"})) + +(clos-defclass "circle" (list "shape") (list {:initform 1 :initarg ":radius" :reader nil :writer nil :accessor nil :name "radius"})) + +(clos-defclass "rect" (list "shape") (list {:initform 1 :initarg ":width" :reader nil :writer nil :accessor nil :name "width"} {:initform 1 :initarg ":height" :reader nil :writer nil :accessor nil :name "height"})) + +;; ── generic function: area ───────────────────────────────────────────────── + +(clos-defgeneric "area" {}) + +;; primary methods +(clos-defmethod + "area" + (list) + (list "circle") + (fn + (args next-fn) + (let + ((c (first args))) + (let ((r (clos-slot-value c "radius"))) (* r r))))) + +(clos-defmethod + "area" + (list) + (list "rect") + (fn + (args next-fn) + (let + ((r (first args))) + (* (clos-slot-value r "width") (clos-slot-value r "height"))))) + +;; :before tracing +(clos-defmethod + "area" + (list "before") + (list "shape") + (fn + (args next-fn) + (trace-push (str "BEFORE area(" (clos-class-of (first args)) ")")))) + +;; :after tracing +(clos-defmethod + "area" + (list "after") + (list "shape") + (fn + (args next-fn) + (trace-push (str "AFTER area(" (clos-class-of (first args)) ")")))) + +;; ── generic function: describe-shape ────────────────────────────────────── + +(clos-defgeneric "describe-shape" {}) + +(clos-defmethod + "describe-shape" + (list) + (list "shape") + (fn + (args next-fn) + (let + ((s (first args))) + (str "shape[" (clos-slot-value s "color") "]")))) + +(clos-defmethod + "describe-shape" + (list) + (list "circle") + (fn + (args next-fn) + (let + ((c (first args))) + (str + "circle[r=" + (clos-slot-value c "radius") + " " + (clos-call-next-method next-fn) + "]")))) + +(clos-defmethod + "describe-shape" + (list) + (list "rect") + (fn + (args next-fn) + (let + ((r (first args))) + (str + "rect[" + (clos-slot-value r "width") + "x" + (clos-slot-value r "height") + " " + (clos-call-next-method next-fn) + "]")))) + +;; :before on base shape (fires for all subclasses too) +(clos-defmethod + "describe-shape" + (list "before") + (list "shape") + (fn + (args next-fn) + (trace-push + (str "BEFORE describe-shape(" (clos-class-of (first args)) ")")))) + +;; ── tests ───────────────────────────────────────────────────────────────── + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + check + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +;; ── area tests ──────────────────────────────────────────────────────────── + +;; circle area = r*r (no pi — integer arithmetic for predictability) +(let + ((c (clos-make-instance "circle" ":radius" 5 ":color" "red"))) + (do + (trace-clear) + (check "circle area" (clos-call-generic "area" (list c)) 25) + (check + ":before fired for circle" + (= (first trace-log) "BEFORE area(circle)") + true) + (check + ":after fired for circle" + (= (first (rest trace-log)) "AFTER area(circle)") + true) + (check "trace length 2" (len trace-log) 2))) + +;; rect area = w*h +(let + ((r (clos-make-instance "rect" ":width" 4 ":height" 6 ":color" "blue"))) + (do + (trace-clear) + (check "rect area" (clos-call-generic "area" (list r)) 24) + (check + ":before fired for rect" + (= (first trace-log) "BEFORE area(rect)") + true) + (check + ":after fired for rect" + (= (first (rest trace-log)) "AFTER area(rect)") + true) + (check "trace length 2 (rect)" (len trace-log) 2))) + +;; ── describe-shape tests ─────────────────────────────────────────────────── + +(let + ((c (clos-make-instance "circle" ":radius" 3 ":color" "green"))) + (do + (trace-clear) + (check + "circle describe" + (clos-call-generic "describe-shape" (list c)) + "circle[r=3 shape[green]]") + (check + ":before fired for describe circle" + (= (first trace-log) "BEFORE describe-shape(circle)") + true))) + +(let + ((r (clos-make-instance "rect" ":width" 2 ":height" 7 ":color" "black"))) + (do + (trace-clear) + (check + "rect describe" + (clos-call-generic "describe-shape" (list r)) + "rect[2x7 shape[black]]") + (check + ":before fired for describe rect" + (= (first trace-log) "BEFORE describe-shape(rect)") + true))) + +;; ── call-next-method: circle -> shape ───────────────────────────────────── + +(let + ((c (clos-make-instance "circle" ":radius" 1 ":color" "purple"))) + (check + "call-next-method result in describe" + (clos-call-generic "describe-shape" (list c)) + "circle[r=1 shape[purple]]")) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define mop-passed passed) +(define mop-failed failed) +(define mop-failures failures) diff --git a/lib/common-lisp/tests/programs/parse-recover.sx b/lib/common-lisp/tests/programs/parse-recover.sx new file mode 100644 index 00000000..9d980cc6 --- /dev/null +++ b/lib/common-lisp/tests/programs/parse-recover.sx @@ -0,0 +1,163 @@ +;; parse-recover.sx — Parser with skipped-token restart +;; +;; Classic CL pattern: a simple token parser that signals a condition +;; when it encounters an unexpected token. The :skip-token restart +;; allows the parser to continue past the offending token. +;; +;; Depends on: lib/common-lisp/runtime.sx already loaded. + +;; ── condition type ───────────────────────────────────────────────────────── + +(cl-define-condition "parse-error" (list "error") (list "token" "position")) + +;; ── simple token parser ──────────────────────────────────────────────────── +;; +;; parse-numbers: given a list of tokens (strings), parse integers. +;; Non-integer tokens signal parse-error with two restarts: +;; skip-token — skip the bad token and continue +;; use-zero — use 0 in place of the bad token + +(define + parse-numbers + (fn + (tokens) + (define result (list)) + (define + process + (fn + (toks) + (if + (empty? toks) + result + (let + ((tok (first toks)) (rest-toks (rest toks))) + (let + ((n (string->number tok 10))) + (if + n + (begin + (set! result (append result (list n))) + (process rest-toks)) + (cl-restart-case + (fn + () + (cl-signal + (cl-make-condition + "parse-error" + "token" + tok + "position" + (len result))) + (set! result (append result (list 0))) + (process rest-toks)) + (list "skip-token" (list) (fn () (process rest-toks))) + (list + "use-zero" + (list) + (fn + () + (begin + (set! result (append result (list 0))) + (process rest-toks))))))))))) + (process tokens) + result)) + +;; ── tests ───────────────────────────────────────────────────────────────── + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + check + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +(define + reset-stacks! + (fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list)))) + +;; All valid tokens +(reset-stacks!) +(check + "all valid: 1 2 3" + (cl-handler-bind + (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token")))) + (fn () (parse-numbers (list "1" "2" "3")))) + (list 1 2 3)) + +;; Skip bad token +(reset-stacks!) +(check + "skip bad token: 1 x 3 -> (1 3)" + (cl-handler-bind + (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token")))) + (fn () (parse-numbers (list "1" "x" "3")))) + (list 1 3)) + +;; Use zero for bad token +(reset-stacks!) +(check + "use-zero for bad: 1 x 3 -> (1 0 3)" + (cl-handler-bind + (list (list "parse-error" (fn (c) (cl-invoke-restart "use-zero")))) + (fn () (parse-numbers (list "1" "x" "3")))) + (list 1 0 3)) + +;; Multiple bad tokens, all skipped +(reset-stacks!) +(check + "skip multiple bad: a 2 b 4 -> (2 4)" + (cl-handler-bind + (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token")))) + (fn () (parse-numbers (list "a" "2" "b" "4")))) + (list 2 4)) + +;; handler-case: abort on first bad token +(reset-stacks!) +(check + "handler-case: abort on first bad" + (cl-handler-case + (fn () (parse-numbers (list "1" "bad" "3"))) + (list + "parse-error" + (fn + (c) + (str + "parse error at position " + (cl-condition-slot c "position") + ": " + (cl-condition-slot c "token"))))) + "parse error at position 1: bad") + +;; Verify condition type hierarchy +(reset-stacks!) +(check + "parse-error isa error" + (cl-condition-of-type? + (cl-make-condition "parse-error" "token" "x" "position" 0) + "error") + true) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define parse-passed passed) +(define parse-failed failed) +(define parse-failures failures) \ No newline at end of file diff --git a/lib/common-lisp/tests/programs/restart-demo.sx b/lib/common-lisp/tests/programs/restart-demo.sx new file mode 100644 index 00000000..db615135 --- /dev/null +++ b/lib/common-lisp/tests/programs/restart-demo.sx @@ -0,0 +1,141 @@ +;; restart-demo.sx — Classic CL condition system demo +;; +;; Demonstrates resumable exceptions via restarts. +;; The `safe-divide` function signals a division-by-zero condition +;; and offers two restarts: +;; :use-zero — return 0 as the result +;; :retry — call safe-divide again with a corrected divisor +;; +;; Depends on: lib/common-lisp/runtime.sx already loaded. + +;; ── safe-divide ──────────────────────────────────────────────────────────── +;; +;; Divides numerator by denominator. +;; When denominator is 0, signals division-by-zero with two restarts. + +(define + safe-divide + (fn + (n d) + (if + (= d 0) + (cl-restart-case + (fn + () + (cl-signal + (cl-make-condition + "division-by-zero" + "operation" + "/" + "operands" + (list n d))) + (error "division by zero — no restart invoked")) + (list "use-zero" (list) (fn () 0)) + (list "retry" (list "d") (fn (d2) (safe-divide n d2)))) + (/ n d)))) + +;; ── tests ───────────────────────────────────────────────────────────────── + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + check + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +(define + reset-stacks! + (fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list)))) + +;; Normal division +(reset-stacks!) +(check "10 / 2 = 5" (safe-divide 10 2) 5) + +;; Invoke use-zero restart +(reset-stacks!) +(check + "10 / 0 -> use-zero" + (cl-handler-bind + (list + (list "division-by-zero" (fn (c) (cl-invoke-restart "use-zero")))) + (fn () (safe-divide 10 0))) + 0) + +;; Invoke retry restart with a corrected denominator +(reset-stacks!) +(check + "10 / 0 -> retry with 2" + (cl-handler-bind + (list + (list + "division-by-zero" + (fn (c) (cl-invoke-restart "retry" 2)))) + (fn () (safe-divide 10 0))) + 5) + +;; Nested calls: outer handles the inner divide-by-zero +(reset-stacks!) +(check + "nested: 20 / (0->4) = 5" + (cl-handler-bind + (list + (list + "division-by-zero" + (fn (c) (cl-invoke-restart "retry" 4)))) + (fn () (let ((r1 (safe-divide 20 0))) r1))) + 5) + +;; handler-case — unwinding version +(reset-stacks!) +(check + "handler-case: catches division-by-zero" + (cl-handler-case + (fn () (safe-divide 9 0)) + (list "division-by-zero" (fn (c) "caught!"))) + "caught!") + +;; Verify use-zero is idempotent (two uses) +(reset-stacks!) +(check + "two use-zero invocations" + (cl-handler-bind + (list + (list "division-by-zero" (fn (c) (cl-invoke-restart "use-zero")))) + (fn + () + (+ + (safe-divide 10 0) + (safe-divide 3 0)))) + 0) + +;; No restart needed for normal division +(reset-stacks!) +(check + "no restart needed for 8/4" + (safe-divide 8 4) + 2) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define demo-passed passed) +(define demo-failed failed) +(define demo-failures failures) \ No newline at end of file diff --git a/lib/common-lisp/tests/read.sx b/lib/common-lisp/tests/read.sx new file mode 100644 index 00000000..af519fc0 --- /dev/null +++ b/lib/common-lisp/tests/read.sx @@ -0,0 +1,180 @@ +;; Common Lisp tokenizer tests + +(define cl-test-pass 0) +(define cl-test-fail 0) +(define cl-test-fails (list)) + +(define + cl-test + (fn + (name actual expected) + (if + (= actual expected) + (set! cl-test-pass (+ cl-test-pass 1)) + (do + (set! cl-test-fail (+ cl-test-fail 1)) + (append! cl-test-fails {:name name :expected expected :actual actual}))))) + +;; Helpers: extract types and values from token stream (drops eof) +(define + cl-tok-types + (fn + (src) + (map + (fn (t) (get t "type")) + (filter (fn (t) (not (= (get t "type") "eof"))) (cl-tokenize src))))) + +(define + cl-tok-values + (fn + (src) + (map + (fn (t) (get t "value")) + (filter (fn (t) (not (= (get t "type") "eof"))) (cl-tokenize src))))) + +(define + cl-tok-first + (fn (src) (nth (cl-tokenize src) 0))) + +;; ── symbols ─────────────────────────────────────────────────────── + +(cl-test "symbol: bare lowercase" (cl-tok-values "foo") (list "FOO")) +(cl-test "symbol: uppercase" (cl-tok-values "BAR") (list "BAR")) +(cl-test "symbol: mixed case folded" (cl-tok-values "FooBar") (list "FOOBAR")) +(cl-test "symbol: with hyphen" (cl-tok-values "foo-bar") (list "FOO-BAR")) +(cl-test "symbol: with star" (cl-tok-values "*special*") (list "*SPECIAL*")) +(cl-test "symbol: with question" (cl-tok-values "null?") (list "NULL?")) +(cl-test "symbol: with exclamation" (cl-tok-values "set!") (list "SET!")) +(cl-test "symbol: plus sign alone" (cl-tok-values "+") (list "+")) +(cl-test "symbol: minus sign alone" (cl-tok-values "-") (list "-")) +(cl-test "symbol: type is symbol" (cl-tok-types "foo") (list "symbol")) + +;; ── package-qualified symbols ───────────────────────────────────── + +(cl-test "symbol: pkg:sym external" (cl-tok-values "cl:car") (list "CL:CAR")) +(cl-test "symbol: pkg::sym internal" (cl-tok-values "pkg::foo") (list "PKG::FOO")) +(cl-test "symbol: cl:car type" (cl-tok-types "cl:car") (list "symbol")) + +;; ── keywords ────────────────────────────────────────────────────── + +(cl-test "keyword: basic" (cl-tok-values ":foo") (list "FOO")) +(cl-test "keyword: type" (cl-tok-types ":foo") (list "keyword")) +(cl-test "keyword: upcase" (cl-tok-values ":hello-world") (list "HELLO-WORLD")) +(cl-test "keyword: multiple" (cl-tok-types ":a :b :c") (list "keyword" "keyword" "keyword")) + +;; ── integers ────────────────────────────────────────────────────── + +(cl-test "integer: zero" (cl-tok-values "0") (list "0")) +(cl-test "integer: positive" (cl-tok-values "42") (list "42")) +(cl-test "integer: negative" (cl-tok-values "-5") (list "-5")) +(cl-test "integer: positive-sign" (cl-tok-values "+3") (list "+3")) +(cl-test "integer: type" (cl-tok-types "42") (list "integer")) +(cl-test "integer: multi-digit" (cl-tok-values "12345678") (list "12345678")) + +;; ── hex, binary, octal ─────────────────────────────────────────── + +(cl-test "hex: lowercase x" (cl-tok-values "#xFF") (list "#xFF")) +(cl-test "hex: uppercase X" (cl-tok-values "#XFF") (list "#XFF")) +(cl-test "hex: type" (cl-tok-types "#xFF") (list "integer")) +(cl-test "hex: zero" (cl-tok-values "#x0") (list "#x0")) +(cl-test "binary: #b" (cl-tok-values "#b1010") (list "#b1010")) +(cl-test "binary: type" (cl-tok-types "#b1010") (list "integer")) +(cl-test "octal: #o" (cl-tok-values "#o17") (list "#o17")) +(cl-test "octal: type" (cl-tok-types "#o17") (list "integer")) + +;; ── floats ──────────────────────────────────────────────────────── + +(cl-test "float: basic" (cl-tok-values "3.14") (list "3.14")) +(cl-test "float: type" (cl-tok-types "3.14") (list "float")) +(cl-test "float: negative" (cl-tok-values "-2.5") (list "-2.5")) +(cl-test "float: exponent" (cl-tok-values "1.0e10") (list "1.0e10")) +(cl-test "float: neg exponent" (cl-tok-values "1.5e-3") (list "1.5e-3")) +(cl-test "float: leading dot" (cl-tok-values ".5") (list "0.5")) +(cl-test "float: exp only" (cl-tok-values "1e5") (list "1e5")) + +;; ── ratios ──────────────────────────────────────────────────────── + +(cl-test "ratio: 1/3" (cl-tok-values "1/3") (list "1/3")) +(cl-test "ratio: type" (cl-tok-types "1/3") (list "ratio")) +(cl-test "ratio: 22/7" (cl-tok-values "22/7") (list "22/7")) +(cl-test "ratio: negative" (cl-tok-values "-1/2") (list "-1/2")) + +;; ── strings ─────────────────────────────────────────────────────── + +(cl-test "string: empty" (cl-tok-values "\"\"") (list "")) +(cl-test "string: basic" (cl-tok-values "\"hello\"") (list "hello")) +(cl-test "string: type" (cl-tok-types "\"hello\"") (list "string")) +(cl-test "string: with space" (cl-tok-values "\"hello world\"") (list "hello world")) +(cl-test "string: escaped quote" (cl-tok-values "\"say \\\"hi\\\"\"") (list "say \"hi\"")) +(cl-test "string: escaped backslash" (cl-tok-values "\"a\\\\b\"") (list "a\\b")) +(cl-test "string: newline escape" (cl-tok-values "\"a\\nb\"") (list "a\nb")) +(cl-test "string: tab escape" (cl-tok-values "\"a\\tb\"") (list "a\tb")) + +;; ── characters ──────────────────────────────────────────────────── + +(cl-test "char: lowercase a" (cl-tok-values "#\\a") (list "a")) +(cl-test "char: uppercase A" (cl-tok-values "#\\A") (list "A")) +(cl-test "char: digit" (cl-tok-values "#\\1") (list "1")) +(cl-test "char: type" (cl-tok-types "#\\a") (list "char")) +(cl-test "char: Space" (cl-tok-values "#\\Space") (list " ")) +(cl-test "char: Newline" (cl-tok-values "#\\Newline") (list "\n")) +(cl-test "char: Tab" (cl-tok-values "#\\Tab") (list "\t")) +(cl-test "char: Return" (cl-tok-values "#\\Return") (list "\r")) + +;; ── reader macros ───────────────────────────────────────────────── + +(cl-test "quote: type" (cl-tok-types "'x") (list "quote" "symbol")) +(cl-test "backquote: type" (cl-tok-types "`x") (list "backquote" "symbol")) +(cl-test "comma: type" (cl-tok-types ",x") (list "comma" "symbol")) +(cl-test "comma-at: type" (cl-tok-types ",@x") (list "comma-at" "symbol")) +(cl-test "hash-quote: type" (cl-tok-types "#'foo") (list "hash-quote" "symbol")) +(cl-test "hash-paren: type" (cl-tok-types "#(1 2)") (list "hash-paren" "integer" "integer" "rparen")) + +;; ── uninterned ──────────────────────────────────────────────────── + +(cl-test "uninterned: type" (cl-tok-types "#:foo") (list "uninterned")) +(cl-test "uninterned: value upcase" (cl-tok-values "#:foo") (list "FOO")) +(cl-test "uninterned: compound" (cl-tok-values "#:my-sym") (list "MY-SYM")) + +;; ── parens and structure ────────────────────────────────────────── + +(cl-test "paren: empty list" (cl-tok-types "()") (list "lparen" "rparen")) +(cl-test "paren: nested" (cl-tok-types "((a))") (list "lparen" "lparen" "symbol" "rparen" "rparen")) +(cl-test "dot: standalone" (cl-tok-types "(a . b)") (list "lparen" "symbol" "dot" "symbol" "rparen")) + +;; ── comments ────────────────────────────────────────────────────── + +(cl-test "comment: line" (cl-tok-types "; comment\nfoo") (list "symbol")) +(cl-test "comment: inline" (cl-tok-values "foo ; bar\nbaz") (list "FOO" "BAZ")) +(cl-test "block-comment: basic" (cl-tok-types "#| hello |# foo") (list "symbol")) +(cl-test "block-comment: nested" (cl-tok-types "#| a #| b |# c |# x") (list "symbol")) + +;; ── combined ────────────────────────────────────────────────────── + +(cl-test + "combined: defun skeleton" + (cl-tok-types "(defun foo (x) x)") + (list "lparen" "symbol" "symbol" "lparen" "symbol" "rparen" "symbol" "rparen")) + +(cl-test + "combined: let form" + (cl-tok-types "(let ((x 1)) x)") + (list + "lparen" + "symbol" + "lparen" + "lparen" + "symbol" + "integer" + "rparen" + "rparen" + "symbol" + "rparen")) + +(cl-test + "combined: whitespace skip" + (cl-tok-values " foo bar baz ") + (list "FOO" "BAR" "BAZ")) + +(cl-test "eof: present" (get (nth (cl-tokenize "") 0) "type") "eof") +(cl-test "eof: at end of tokens" (get (nth (cl-tokenize "x") 1) "type") "eof") diff --git a/lib/common-lisp/tests/runtime.sx b/lib/common-lisp/tests/runtime.sx new file mode 100644 index 00000000..8da5478a --- /dev/null +++ b/lib/common-lisp/tests/runtime.sx @@ -0,0 +1,207 @@ +;; lib/common-lisp/tests/runtime.sx — tests for CL runtime layer + +(load "lib/common-lisp/runtime.sx") + +(defsuite + "cl-types" + (deftest "cl-null? nil" (assert= true (cl-null? nil))) + (deftest "cl-null? false" (assert= false (cl-null? false))) + (deftest + "cl-consp? pair" + (assert= true (cl-consp? (list 1 2)))) + (deftest "cl-consp? nil" (assert= false (cl-consp? nil))) + (deftest "cl-listp? nil" (assert= true (cl-listp? nil))) + (deftest + "cl-listp? list" + (assert= true (cl-listp? (list 1 2)))) + (deftest "cl-atom? nil" (assert= true (cl-atom? nil))) + (deftest "cl-atom? pair" (assert= false (cl-atom? (list 1)))) + (deftest "cl-integerp?" (assert= true (cl-integerp? 42))) + (deftest "cl-floatp?" (assert= true (cl-floatp? 3.14))) + (deftest + "cl-characterp?" + (assert= true (cl-characterp? (integer->char 65)))) + (deftest "cl-stringp?" (assert= true (cl-stringp? "hello"))) + (deftest "cl-symbolp?" (assert= true (cl-symbolp? (quote foo))))) + +(defsuite + "cl-arithmetic" + (deftest "cl-mod" (assert= 1 (cl-mod 10 3))) + (deftest "cl-rem" (assert= 1 (cl-rem 10 3))) + (deftest + "cl-quotient" + (assert= 3 (cl-quotient 10 3))) + (deftest "cl-gcd" (assert= 4 (cl-gcd 12 8))) + (deftest "cl-lcm" (assert= 12 (cl-lcm 4 6))) + (deftest "cl-abs pos" (assert= 5 (cl-abs 5))) + (deftest "cl-abs neg" (assert= 5 (cl-abs -5))) + (deftest "cl-min" (assert= 2 (cl-min 2 7))) + (deftest "cl-max" (assert= 7 (cl-max 2 7))) + (deftest "cl-evenp? t" (assert= true (cl-evenp? 4))) + (deftest "cl-evenp? f" (assert= false (cl-evenp? 3))) + (deftest "cl-oddp? t" (assert= true (cl-oddp? 7))) + (deftest "cl-zerop?" (assert= true (cl-zerop? 0))) + (deftest "cl-plusp?" (assert= true (cl-plusp? 1))) + (deftest "cl-minusp?" (assert= true (cl-minusp? -1))) + (deftest "cl-signum pos" (assert= 1 (cl-signum 42))) + (deftest "cl-signum neg" (assert= -1 (cl-signum -7))) + (deftest "cl-signum zero" (assert= 0 (cl-signum 0)))) + +(defsuite + "cl-chars" + (deftest + "cl-char-code" + (assert= 65 (cl-char-code (integer->char 65)))) + (deftest "cl-code-char" (assert= true (char? (cl-code-char 65)))) + (deftest + "cl-char-upcase" + (assert= + (integer->char 65) + (cl-char-upcase (integer->char 97)))) + (deftest + "cl-char-downcase" + (assert= + (integer->char 97) + (cl-char-downcase (integer->char 65)))) + (deftest + "cl-alpha-char-p" + (assert= true (cl-alpha-char-p (integer->char 65)))) + (deftest + "cl-digit-char-p" + (assert= true (cl-digit-char-p (integer->char 48)))) + (deftest + "cl-char=?" + (assert= + true + (cl-char=? (integer->char 65) (integer->char 65)))) + (deftest + "cl-charchar 65) (integer->char 90)))) + (deftest + "cl-char space" + (assert= (integer->char 32) cl-char-space)) + (deftest + "cl-char newline" + (assert= (integer->char 10) cl-char-newline))) + +(defsuite + "cl-format" + (deftest + "cl-format nil basic" + (assert= "hello" (cl-format nil "~a" "hello"))) + (deftest + "cl-format nil number" + (assert= "42" (cl-format nil "~d" 42))) + (deftest + "cl-format nil hex" + (assert= "ff" (cl-format nil "~x" 255))) + (deftest + "cl-format nil template" + (assert= "x=3 y=4" (cl-format nil "x=~d y=~d" 3 4))) + (deftest "cl-format nil tilde" (assert= "a~b" (cl-format nil "a~~b")))) + +(defsuite + "cl-gensym" + (deftest + "cl-gensym returns symbol" + (assert= "symbol" (type-of (cl-gensym)))) + (deftest "cl-gensym unique" (assert= false (= (cl-gensym) (cl-gensym))))) + +(defsuite + "cl-sets" + (deftest "cl-make-set empty" (assert= true (cl-set? (cl-make-set)))) + (deftest + "cl-set-add/member" + (let + ((s (cl-make-set))) + (do + (cl-set-add s 1) + (assert= true (cl-set-memberp s 1))))) + (deftest + "cl-set-memberp false" + (assert= false (cl-set-memberp (cl-make-set) 42))) + (deftest + "cl-list->set" + (let + ((s (cl-list->set (list 1 2 3)))) + (assert= true (cl-set-memberp s 2))))) + +(defsuite + "cl-lists" + (deftest + "cl-nth 0" + (assert= + 1 + (cl-nth 0 (list 1 2 3)))) + (deftest + "cl-nth 2" + (assert= + 3 + (cl-nth 2 (list 1 2 3)))) + (deftest + "cl-last" + (assert= + (list 3) + (cl-last (list 1 2 3)))) + (deftest + "cl-butlast" + (assert= + (list 1 2) + (cl-butlast (list 1 2 3)))) + (deftest + "cl-nthcdr 1" + (assert= + (list 2 3) + (cl-nthcdr 1 (list 1 2 3)))) + (deftest + "cl-assoc hit" + (assert= + (list "b" 2) + (cl-assoc "b" (list (list "a" 1) (list "b" 2))))) + (deftest + "cl-assoc miss" + (assert= nil (cl-assoc "z" (list (list "a" 1))))) + (deftest + "cl-getf hit" + (assert= 42 (cl-getf (list "x" 42 "y" 99) "x"))) + (deftest "cl-getf miss" (assert= nil (cl-getf (list "x" 42) "z"))) + (deftest + "cl-adjoin new" + (assert= + (list 0 1 2) + (cl-adjoin 0 (list 1 2)))) + (deftest + "cl-adjoin dup" + (assert= + (list 1 2) + (cl-adjoin 1 (list 1 2)))) + (deftest + "cl-flatten" + (assert= + (list 1 2 3 4) + (cl-flatten (list 1 (list 2 3) 4)))) + (deftest + "cl-member hit" + (assert= + (list 2 3) + (cl-member 2 (list 1 2 3)))) + (deftest + "cl-member miss" + (assert= + nil + (cl-member 9 (list 1 2 3))))) + +(defsuite + "cl-radix" + (deftest "binary" (assert= "1010" (cl-format-binary 10))) + (deftest "octal" (assert= "17" (cl-format-octal 15))) + (deftest "hex" (assert= "ff" (cl-format-hex 255))) + (deftest "decimal" (assert= "42" (cl-format-decimal 42))) + (deftest + "n->s r16" + (assert= "1f" (cl-integer-to-string 31 16))) + (deftest + "s->n r16" + (assert= 31 (cl-string-to-integer "1f" 16)))) diff --git a/lib/common-lisp/tests/stdlib.sx b/lib/common-lisp/tests/stdlib.sx new file mode 100644 index 00000000..0b70e804 --- /dev/null +++ b/lib/common-lisp/tests/stdlib.sx @@ -0,0 +1,285 @@ +;; lib/common-lisp/tests/stdlib.sx — Phase 6: sequence, list, string functions + +(define ev (fn (src) (cl-eval-str src (cl-make-env)))) + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + check + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +;; ── mapc ───────────────────────────────────────────────────────── + +(check "mapc returns list" + (ev "(mapc #'1+ '(1 2 3))") + (list 1 2 3)) + +;; ── mapcan ─────────────────────────────────────────────────────── + +(check "mapcan basic" + (ev "(mapcan (lambda (x) (list x (* x x))) '(1 2 3))") + (list 1 1 2 4 3 9)) + +(check "mapcan filter-like" + (ev "(mapcan (lambda (x) (if (evenp x) (list x) nil)) '(1 2 3 4 5 6))") + (list 2 4 6)) + +;; ── reduce ─────────────────────────────────────────────────────── + +(check "reduce sum" + (ev "(reduce #'+ '(1 2 3 4 5))") + 15) + +(check "reduce with initial-value" + (ev "(reduce #'+ '(1 2 3) :initial-value 10)") + 16) + +(check "reduce max" + (ev "(reduce (lambda (a b) (if (> a b) a b)) '(3 1 4 1 5 9 2 6))") + 9) + +;; ── find ───────────────────────────────────────────────────────── + +(check "find present" + (ev "(find 3 '(1 2 3 4 5))") + 3) + +(check "find absent" + (ev "(find 9 '(1 2 3))") + nil) + +(check "find-if present" + (ev "(find-if #'evenp '(1 3 4 7))") + 4) + +(check "find-if absent" + (ev "(find-if #'evenp '(1 3 5))") + nil) + +(check "find-if-not" + (ev "(find-if-not #'evenp '(2 4 5 6))") + 5) + +;; ── position ───────────────────────────────────────────────────── + +(check "position found" + (ev "(position 3 '(1 2 3 4 5))") + 2) + +(check "position not found" + (ev "(position 9 '(1 2 3))") + nil) + +(check "position-if" + (ev "(position-if #'evenp '(1 3 4 8))") + 2) + +;; ── count ──────────────────────────────────────────────────────── + +(check "count" + (ev "(count 2 '(1 2 3 2 4 2))") + 3) + +(check "count-if" + (ev "(count-if #'evenp '(1 2 3 4 5 6))") + 3) + +;; ── every / some / notany / notevery ───────────────────────────── + +(check "every true" + (ev "(every #'evenp '(2 4 6))") + true) + +(check "every false" + (ev "(every #'evenp '(2 3 6))") + nil) + +(check "every empty" + (ev "(every #'evenp '())") + true) + +(check "some truthy" + (ev "(some #'evenp '(1 3 4))") + true) + +(check "some nil" + (ev "(some #'evenp '(1 3 5))") + nil) + +(check "notany true" + (ev "(notany #'evenp '(1 3 5))") + true) + +(check "notany false" + (ev "(notany #'evenp '(1 2 5))") + nil) + +(check "notevery false" + (ev "(notevery #'evenp '(2 4 6))") + nil) + +(check "notevery true" + (ev "(notevery #'evenp '(2 3 6))") + true) + +;; ── remove ─────────────────────────────────────────────────────── + +(check "remove" + (ev "(remove 3 '(1 2 3 4 3 5))") + (list 1 2 4 5)) + +(check "remove-if" + (ev "(remove-if #'evenp '(1 2 3 4 5 6))") + (list 1 3 5)) + +(check "remove-if-not" + (ev "(remove-if-not #'evenp '(1 2 3 4 5 6))") + (list 2 4 6)) + +;; ── member ─────────────────────────────────────────────────────── + +(check "member found" + (ev "(member 3 '(1 2 3 4 5))") + (list 3 4 5)) + +(check "member not found" + (ev "(member 9 '(1 2 3))") + nil) + +;; ── subst ──────────────────────────────────────────────────────── + +(check "subst flat" + (ev "(subst 'b 'a '(a b c a))") + (list "B" "B" "C" "B")) + +(check "subst nested" + (ev "(subst 99 1 '(1 (2 1) 3))") + (list 99 (list 2 99) 3)) + +;; ── assoc ──────────────────────────────────────────────────────── + +(check "assoc found" + (ev "(assoc 'b '((a 1) (b 2) (c 3)))") + (list "B" 2)) + +(check "assoc not found" + (ev "(assoc 'z '((a 1) (b 2)))") + nil) + +;; ── list ops ───────────────────────────────────────────────────── + +(check "last" + (ev "(last '(1 2 3 4))") + (list 4)) + +(check "butlast" + (ev "(butlast '(1 2 3 4))") + (list 1 2 3)) + +(check "nthcdr" + (ev "(nthcdr 2 '(a b c d))") + (list "C" "D")) + +(check "list*" + (ev "(list* 1 2 '(3 4))") + (list 1 2 3 4)) + +(check "cadr" + (ev "(cadr '(1 2 3))") + 2) + +(check "caddr" + (ev "(caddr '(1 2 3))") + 3) + +(check "cadddr" + (ev "(cadddr '(1 2 3 4))") + 4) + +(check "cddr" + (ev "(cddr '(1 2 3 4))") + (list 3 4)) + +;; ── subseq ─────────────────────────────────────────────────────── + +(check "subseq string" + (ev "(subseq \"hello\" 1 3)") + "el") + +(check "subseq list" + (ev "(subseq '(a b c d) 1 3)") + (list "B" "C")) + +(check "subseq no end" + (ev "(subseq \"hello\" 2)") + "llo") + +;; ── FORMAT ───────────────────────────────────────────────────────── + +(check "format ~A" + (ev "(format nil \"hello ~A\" \"world\")") + "hello world") + +(check "format ~D" + (ev "(format nil \"~D items\" 42)") + "42 items") + +(check "format two args" + (ev "(format nil \"~A ~A\" 1 2)") + "1 2") + +(check "format ~A+~A=~A" + (ev "(format nil \"~A + ~A = ~A\" 1 2 3)") + "1 + 2 = 3") + +(check "format iterate" + (ev "(format nil \"~{~A~}\" (quote (1 2 3)))") + "123") + +(check "format iterate with space" + (ev "(format nil \"(~{~A ~})\" (quote (1 2 3)))") + "(1 2 3 )") + +;; ── packages ───────────────────────────────────────────────────── + +(check "defpackage returns name" + (ev "(defpackage :my-pkg (:use :cl))") + "MY-PKG") + +(check "in-package" + (ev "(progn (defpackage :test-pkg) (in-package :test-pkg) (package-name))") + "TEST-PKG") + +(check "package-qualified function" + (ev "(cl:car (quote (1 2 3)))") + 1) + +(check "package-qualified function 2" + (ev "(cl:mapcar (function evenp) (quote (2 3 4)))") + (list true nil true)) + +;; ── summary ────────────────────────────────────────────────────── + +(define stdlib-passed passed) +(define stdlib-failed failed) +(define stdlib-failures failures) diff --git a/lib/erlang/bench_ring.sh b/lib/erlang/bench_ring.sh new file mode 100755 index 00000000..c7b9625c --- /dev/null +++ b/lib/erlang/bench_ring.sh @@ -0,0 +1,86 @@ +#!/usr/bin/env bash +# Erlang-on-SX ring benchmark. +# +# Spawns N processes in a ring, passes a token N hops (one full round), +# and reports wall-clock time + throughput. Aspirational target from +# the plan is 1M processes; current sync-scheduler architecture caps out +# orders of magnitude lower — this script measures honestly across a +# range of N so the result/scaling is recorded. +# +# Usage: +# bash lib/erlang/bench_ring.sh # default ladder +# bash lib/erlang/bench_ring.sh 100 1000 5000 # custom Ns + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found." >&2 + exit 1 +fi + +if [ "$#" -gt 0 ]; then + NS=("$@") +else + NS=(10 100 500 1000) +fi + +TMPFILE=$(mktemp) +trap "rm -f $TMPFILE" EXIT + +# One-line Erlang program. Replaces __N__ with the size for each run. +PROGRAM='Me = self(), N = __N__, Spawner = fun () -> receive {setup, Next} -> Loop = fun () -> receive {token, 0, Parent} -> Parent ! done; {token, K, Parent} -> Next ! {token, K-1, Parent}, Loop() end end, Loop() end end, BuildRing = fun (K, Acc) -> if K =:= 0 -> Acc; true -> BuildRing(K-1, [spawn(Spawner) | Acc]) end end, Pids = BuildRing(N, []), Wire = fun (Ps) -> case Ps of [P, Q | _] -> P ! {setup, Q}, Wire(tl(Ps)); [Last] -> Last ! {setup, hd(Pids)} end end, Wire(Pids), hd(Pids) ! {token, N, Me}, receive done -> done end' + +run_n() { + local n="$1" + local prog="${PROGRAM//__N__/$n}" + cat > "$TMPFILE" <&1) + end_s=$(date +%s) + end_ns=$(date +%N) + + local ok="false" + if echo "$out" | grep -q ':name "done"'; then ok="true"; fi + + # ms = (end_s - start_s)*1000 + (end_ns - start_ns)/1e6 + elapsed_ms=$(awk -v s1="$start_s" -v n1="$start_ns" -v s2="$end_s" -v n2="$end_ns" \ + 'BEGIN { printf "%d", (s2 - s1) * 1000 + (n2 - n1) / 1000000 }') + + if [ "$ok" = "true" ]; then + local hops_per_s + hops_per_s=$(awk -v n="$n" -v ms="$elapsed_ms" \ + 'BEGIN { if (ms == 0) ms = 1; printf "%.0f", n * 1000 / ms }') + printf " N=%-8s hops=%-8s %sms (%s hops/s)\n" "$n" "$n" "$elapsed_ms" "$hops_per_s" + else + printf " N=%-8s FAILED %sms\n" "$n" "$elapsed_ms" + fi +} + +echo "Ring benchmark — sx_server.exe (synchronous scheduler)" +echo +for n in "${NS[@]}"; do + run_n "$n" +done +echo +echo "Note: 1M-process target from the plan is aspirational; the synchronous" +echo "scheduler with shift-based suspension and dict-based env copies is not" +echo "engineered for that scale. Numbers above are honest baselines." diff --git a/lib/erlang/bench_ring_results.md b/lib/erlang/bench_ring_results.md new file mode 100644 index 00000000..96883b8f --- /dev/null +++ b/lib/erlang/bench_ring_results.md @@ -0,0 +1,35 @@ +# Ring Benchmark Results + +Generated by `lib/erlang/bench_ring.sh` against `sx_server.exe` on the +synchronous Erlang-on-SX scheduler. + +| N (processes) | Hops | Wall-clock | Throughput | +|---|---|---|---| +| 10 | 10 | 907ms | 11 hops/s | +| 50 | 50 | 2107ms | 24 hops/s | +| 100 | 100 | 3827ms | 26 hops/s | +| 500 | 500 | 17004ms | 29 hops/s | +| 1000 | 1000 | 29832ms | 34 hops/s | + +(Each `Nm` row spawns N processes connected in a ring and passes a +single token N hops total — i.e. the token completes one full lap.) + +## Status of the 1M-process target + +Phase 3's stretch goal in `plans/erlang-on-sx.md` is a million-process +ring benchmark. **That target is not met** in the current synchronous +scheduler; extrapolating from the table above, 1M hops would take +~30 000 s. Correctness is fine — the program runs at every measured +size — but throughput is bound by per-hop overhead. + +Per-hop cost is dominated by: +- `er-env-copy` per fun clause attempt (whole-dict copy each time) +- `call/cc` capture + `raise`/`guard` unwind on every `receive` +- `er-q-delete-at!` rebuilds the mailbox backing list on every match +- `dict-set!`/`dict-has?` lookups in the global processes table + +To reach 1M-process throughput in this architecture would need at +least: persistent (path-copying) envs, an inline scheduler that +doesn't call/cc on the common path (msg-already-in-mailbox), and a +linked-list mailbox. None of those are in scope for the Phase 3 +checkbox — captured here as the floor we're starting from. diff --git a/lib/erlang/conformance.sh b/lib/erlang/conformance.sh new file mode 100755 index 00000000..7b0d7121 --- /dev/null +++ b/lib/erlang/conformance.sh @@ -0,0 +1,153 @@ +#!/usr/bin/env bash +# Erlang-on-SX conformance runner. +# +# Loads every erlang test suite via the epoch protocol, collects +# pass/fail counts, and writes lib/erlang/scoreboard.json + .md. +# +# Usage: +# bash lib/erlang/conformance.sh # run all suites +# bash lib/erlang/conformance.sh -v # verbose per-suite + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found." >&2 + exit 1 +fi + +VERBOSE="${1:-}" +TMPFILE=$(mktemp) +OUTFILE=$(mktemp) +trap "rm -f $TMPFILE $OUTFILE" EXIT + +# Each suite: name | counter pass | counter total +SUITES=( + "tokenize|er-test-pass|er-test-count" + "parse|er-parse-test-pass|er-parse-test-count" + "eval|er-eval-test-pass|er-eval-test-count" + "runtime|er-rt-test-pass|er-rt-test-count" + "ring|er-ring-test-pass|er-ring-test-count" + "ping-pong|er-pp-test-pass|er-pp-test-count" + "bank|er-bank-test-pass|er-bank-test-count" + "echo|er-echo-test-pass|er-echo-test-count" + "fib|er-fib-test-pass|er-fib-test-count" +) + +cat > "$TMPFILE" << 'EPOCHS' +(epoch 1) +(load "lib/erlang/tokenizer.sx") +(load "lib/erlang/parser.sx") +(load "lib/erlang/parser-core.sx") +(load "lib/erlang/parser-expr.sx") +(load "lib/erlang/parser-module.sx") +(load "lib/erlang/transpile.sx") +(load "lib/erlang/runtime.sx") +(load "lib/erlang/tests/tokenize.sx") +(load "lib/erlang/tests/parse.sx") +(load "lib/erlang/tests/eval.sx") +(load "lib/erlang/tests/runtime.sx") +(load "lib/erlang/tests/programs/ring.sx") +(load "lib/erlang/tests/programs/ping_pong.sx") +(load "lib/erlang/tests/programs/bank.sx") +(load "lib/erlang/tests/programs/echo.sx") +(load "lib/erlang/tests/programs/fib_server.sx") +(epoch 100) +(eval "(list er-test-pass er-test-count)") +(epoch 101) +(eval "(list er-parse-test-pass er-parse-test-count)") +(epoch 102) +(eval "(list er-eval-test-pass er-eval-test-count)") +(epoch 103) +(eval "(list er-rt-test-pass er-rt-test-count)") +(epoch 104) +(eval "(list er-ring-test-pass er-ring-test-count)") +(epoch 105) +(eval "(list er-pp-test-pass er-pp-test-count)") +(epoch 106) +(eval "(list er-bank-test-pass er-bank-test-count)") +(epoch 107) +(eval "(list er-echo-test-pass er-echo-test-count)") +(epoch 108) +(eval "(list er-fib-test-pass er-fib-test-count)") +EPOCHS + +timeout 120 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1 + +# Parse "(N M)" from the line after each "(ok-len ...)" marker. +parse_pair() { + local epoch="$1" + local line + line=$(grep -A1 "^(ok-len $epoch " "$OUTFILE" | tail -1) + echo "$line" | sed -E 's/[()]//g' +} + +TOTAL_PASS=0 +TOTAL_COUNT=0 +JSON_SUITES="" +MD_ROWS="" + +idx=0 +for entry in "${SUITES[@]}"; do + name="${entry%%|*}" + epoch=$((100 + idx)) + pair=$(parse_pair "$epoch") + pass=$(echo "$pair" | awk '{print $1}') + count=$(echo "$pair" | awk '{print $2}') + if [ -z "$pass" ] || [ -z "$count" ]; then + pass=0 + count=0 + fi + TOTAL_PASS=$((TOTAL_PASS + pass)) + TOTAL_COUNT=$((TOTAL_COUNT + count)) + status="ok" + marker="✅" + if [ "$pass" != "$count" ]; then + status="fail" + marker="❌" + fi + if [ "$VERBOSE" = "-v" ]; then + printf " %-12s %s/%s\n" "$name" "$pass" "$count" + fi + if [ -n "$JSON_SUITES" ]; then JSON_SUITES+=","; fi + JSON_SUITES+=$'\n ' + JSON_SUITES+="{\"name\":\"$name\",\"pass\":$pass,\"total\":$count,\"status\":\"$status\"}" + MD_ROWS+="| $marker | $name | $pass | $count |"$'\n' + idx=$((idx + 1)) +done + +printf '\nErlang-on-SX conformance: %d / %d\n' "$TOTAL_PASS" "$TOTAL_COUNT" + +# scoreboard.json +cat > lib/erlang/scoreboard.json < lib/erlang/scoreboard.md <") (let ((body (er-parse-body st))) {:pattern pat :body body :class klass :guards guards})))))) + +;; ── binary literals / patterns ──────────────────────────────── +;; `<< [Seg {, Seg}] >>` where Seg = Value [: Size] [/ Spec]. Size is +;; a literal integer (multiple of 8 supported); Spec is `integer` +;; (default) or `binary` (rest-of-binary tail). Sufficient for the +;; common `<>` patterns. +(define + er-parse-binary + (fn + (st) + (er-expect! st "punct" "<<") + (cond + (er-is? st "punct" ">>") + (do (er-advance! st) {:segments (list) :type "binary"}) + :else (let + ((segs (list (er-parse-binary-segment st)))) + (er-parse-binary-tail st segs))))) + +(define + er-parse-binary-tail + (fn + (st segs) + (cond + (er-is? st "punct" ",") + (do + (er-advance! st) + (append! segs (er-parse-binary-segment st)) + (er-parse-binary-tail st segs)) + (er-is? st "punct" ">>") + (do (er-advance! st) {:segments segs :type "binary"}) + :else (error + (str + "Erlang parse: expected ',' or '>>' in binary, got '" + (er-cur-value st) + "'"))))) + +(define + er-parse-binary-segment + (fn + (st) + ;; Use `er-parse-primary` for the value so a leading `:` falls + ;; through to the segment's size suffix instead of being eaten + ;; by `er-parse-postfix-loop` as a `Mod:Fun` remote call. + (let + ((v (er-parse-primary st))) + (let + ((size (cond + (er-is? st "punct" ":") + (do (er-advance! st) (er-parse-primary st)) + :else nil)) + (spec (cond + (er-is? st "op" "/") + (do + (er-advance! st) + (let + ((tok (er-cur st))) + (er-advance! st) + (get tok :value))) + :else "integer"))) + {:size size :spec spec :value v})))) diff --git a/lib/erlang/runtime.sx b/lib/erlang/runtime.sx new file mode 100644 index 00000000..03aaad5d --- /dev/null +++ b/lib/erlang/runtime.sx @@ -0,0 +1,1204 @@ +;; Erlang runtime — scheduler, process records, mailbox queue. +;; Phase 3 foundation. spawn/send/receive build on these primitives. +;; +;; Scheduler is a single global dict in `er-scheduler` holding: +;; :next-pid INT — counter for fresh pid allocation +;; :processes DICT — pid-key (string) -> process record +;; :runnable QUEUE — FIFO of pids ready to run +;; :current PID — pid currently executing, or nil +;; +;; A pid value is tagged: {:tag "pid" :id INT}. Pids compare by id. +;; +;; Process record fields: +;; :pid — this process's pid +;; :mailbox — queue of received messages (arrival order) +;; :state — "runnable" | "running" | "waiting" | "exiting" | "dead" +;; :continuation — saved k (for receive suspension); nil otherwise +;; :receive-pats — patterns the process is blocked on; nil otherwise +;; :trap-exit — bool +;; :links — list of pids +;; :monitors — list of {:ref :pid} +;; :env — Erlang env at the last yield +;; :exit-reason — nil until the process exits +;; +;; Queue — amortised-O(1) FIFO with head-pointer + slab-compact: +;; {:items (list...) :head-idx INT} + +;; ── queue ──────────────────────────────────────────────────────── +(define er-q-new (fn () {:head-idx 0 :items (list)})) + +(define er-q-push! (fn (q x) (append! (get q :items) x))) + +(define + er-q-pop! + (fn + (q) + (let + ((h (get q :head-idx)) (items (get q :items))) + (if + (>= h (len items)) + nil + (let + ((x (nth items h))) + (dict-set! q :head-idx (+ h 1)) + (er-q-compact! q) + x))))) + +(define + er-q-peek + (fn + (q) + (let + ((h (get q :head-idx)) (items (get q :items))) + (if (>= h (len items)) nil (nth items h))))) + +(define + er-q-len + (fn (q) (- (len (get q :items)) (get q :head-idx)))) + +(define er-q-empty? (fn (q) (= (er-q-len q) 0))) + +;; Compact the backing list when the head pointer gets large so the +;; queue doesn't grow without bound. Threshold chosen to amortise the +;; O(n) copy — pops are still amortised O(1). +(define + er-q-compact! + (fn + (q) + (let + ((h (get q :head-idx)) (items (get q :items))) + (when + (> h 128) + (let + ((new (list))) + (for-each + (fn (i) (append! new (nth items i))) + (range h (len items))) + (dict-set! q :items new) + (dict-set! q :head-idx 0)))))) + +(define + er-q-to-list + (fn + (q) + (let + ((h (get q :head-idx)) (items (get q :items)) (out (list))) + (for-each + (fn (i) (append! out (nth items i))) + (range h (len items))) + out))) + +;; Read the i'th entry (relative to head) without popping. +(define + er-q-nth + (fn (q i) (nth (get q :items) (+ (get q :head-idx) i)))) + +;; Remove entry at logical index i, shift tail in. +(define + er-q-delete-at! + (fn + (q i) + (let + ((h (get q :head-idx)) (items (get q :items)) (new (list))) + (for-each + (fn + (j) + (when (not (= j (+ h i))) (append! new (nth items j)))) + (range h (len items))) + (dict-set! q :items new) + (dict-set! q :head-idx 0)))) + +;; ── pids ───────────────────────────────────────────────────────── +(define er-mk-pid (fn (id) {:id id :tag "pid"})) +(define er-pid? (fn (v) (er-is-tagged? v "pid"))) +(define er-pid-id (fn (pid) (get pid :id))) +(define er-pid-key (fn (pid) (str "p" (er-pid-id pid)))) +(define + er-pid-equal? + (fn (a b) (and (er-pid? a) (er-pid? b) (= (er-pid-id a) (er-pid-id b))))) + +;; ── refs ───────────────────────────────────────────────────────── +(define er-mk-ref (fn (id) {:id id :tag "ref"})) +(define er-ref? (fn (v) (er-is-tagged? v "ref"))) +(define + er-ref-equal? + (fn (a b) (and (er-ref? a) (er-ref? b) (= (get a :id) (get b :id))))) + +(define + er-ref-new! + (fn + () + (let + ((s (er-sched))) + (let + ((n (get s :next-ref))) + (dict-set! s :next-ref (+ n 1)) + (er-mk-ref n))))) + +;; ── scheduler state ────────────────────────────────────────────── +(define er-scheduler (list nil)) + +(define + er-sched-init! + (fn + () + (set-nth! + er-scheduler + 0 + {:next-pid 0 + :next-ref 0 + :current nil + :processes {} + :registered {} + :ets {} + :runnable (er-q-new)}))) + +(define er-sched (fn () (nth er-scheduler 0))) + +(define + er-pid-new! + (fn + () + (let + ((s (er-sched))) + (let + ((n (get s :next-pid))) + (dict-set! s :next-pid (+ n 1)) + (er-mk-pid n))))) + +(define + er-sched-runnable + (fn () (get (er-sched) :runnable))) + +(define + er-sched-processes + (fn () (get (er-sched) :processes))) + +(define + er-sched-enqueue! + (fn (pid) (er-q-push! (er-sched-runnable) pid))) + +(define + er-sched-next-runnable! + (fn () (er-q-pop! (er-sched-runnable)))) + +(define + er-sched-runnable-count + (fn () (er-q-len (er-sched-runnable)))) + +(define + er-sched-set-current! + (fn (pid) (dict-set! (er-sched) :current pid))) + +(define er-sched-current-pid (fn () (get (er-sched) :current))) + +(define + er-sched-process-count + (fn () (len (keys (er-sched-processes))))) + +;; ── process records ────────────────────────────────────────────── +(define + er-proc-new! + (fn + (env) + (let + ((pid (er-pid-new!))) + (let + ((proc + {:pid pid + :env env + :links (list) + :mailbox (er-q-new) + :state "runnable" + :monitors (list) + :monitored-by (list) + :continuation nil + :receive-pats nil + :trap-exit false + :has-timeout false + :timed-out false + :exit-reason nil})) + (dict-set! (er-sched-processes) (er-pid-key pid) proc) + (er-sched-enqueue! pid) + proc)))) + +(define + er-proc-get + (fn (pid) (get (er-sched-processes) (er-pid-key pid)))) + +(define + er-proc-exists? + (fn (pid) (dict-has? (er-sched-processes) (er-pid-key pid)))) + +(define + er-proc-field + (fn (pid field) (get (er-proc-get pid) field))) + +(define + er-proc-set! + (fn + (pid field val) + (let + ((p (er-proc-get pid))) + (if + (= p nil) + (error (str "Erlang: no such process " (er-pid-key pid))) + (dict-set! p field val))))) + +(define + er-proc-mailbox-push! + (fn (pid msg) (er-q-push! (er-proc-field pid :mailbox) msg))) + +(define + er-proc-mailbox-size + (fn (pid) (er-q-len (er-proc-field pid :mailbox)))) + +;; Main process is always pid 0 (scheduler starts with next-pid 0 and +;; erlang-eval-ast calls er-proc-new! first). Returns nil if no eval +;; has run. +(define + er-main-pid + (fn () (er-mk-pid 0))) + +(define + er-last-main-exit-reason + (fn + () + (if + (er-proc-exists? (er-main-pid)) + (er-proc-field (er-main-pid) :exit-reason) + nil))) + +;; ── process BIFs ──────────────────────────────────────────────── +(define + er-bif-is-pid + (fn (vs) (er-bool (er-pid? (er-bif-arg1 vs "is_pid"))))) + +(define + er-bif-self + (fn + (vs) + (if + (not (= (len vs) 0)) + (error "Erlang: self/0: arity") + (let + ((pid (er-sched-current-pid))) + (if + (= pid nil) + (error "Erlang: self/0: no current process") + pid))))) + +(define + er-bif-spawn + (fn + (vs) + (cond + (= (len vs) 1) (er-spawn-fun (nth vs 0)) + (= (len vs) 3) (error + "Erlang: spawn/3: module-based spawn deferred to Phase 5 (modules)") + :else (error "Erlang: spawn: wrong arity")))) + +(define + er-spawn-fun + (fn + (fv) + (if + (not (er-fun? fv)) + (error "Erlang: spawn/1: not a fun") + (let + ((proc (er-proc-new! (er-env-new)))) + (dict-set! proc :initial-fun fv) + (get proc :pid))))) + +(define + er-bif-exit + (fn + (vs) + (cond + (= (len vs) 1) (raise (er-mk-exit-marker (nth vs 0))) + (= (len vs) 2) + (error + "Erlang: exit/2 (signal another process) deferred to next Phase 4 step (signal propagation)") + :else (error "Erlang: exit: wrong arity")))) + +;; ── links / monitors / refs ───────────────────────────────────── +(define + er-bif-is-reference + (fn (vs) (er-bool (er-ref? (er-bif-arg1 vs "is_reference"))))) + +;; ── name registry ───────────────────────────────────────────── +(define er-registered (fn () (get (er-sched) :registered))) + +(define + er-bif-register + (fn + (vs) + (if + (not (= (len vs) 2)) + (error "Erlang: register/2: arity") + (let + ((name (nth vs 0)) (pid (nth vs 1))) + (cond + (not (er-atom? name)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (not (er-pid? pid)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (not (er-proc-exists? pid)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (dict-has? (er-registered) (get name :name)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (do + (dict-set! (er-registered) (get name :name) pid) + (er-mk-atom "true"))))))) + +(define + er-bif-unregister + (fn + (vs) + (let + ((name (er-bif-arg1 vs "unregister"))) + (cond + (not (er-atom? name)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (not (dict-has? (er-registered) (get name :name))) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (do + (dict-delete! (er-registered) (get name :name)) + (er-mk-atom "true")))))) + +(define + er-bif-whereis + (fn + (vs) + (let + ((name (er-bif-arg1 vs "whereis"))) + (cond + (not (er-atom? name)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (dict-has? (er-registered) (get name :name)) + (get (er-registered) (get name :name)) + :else (er-mk-atom "undefined"))))) + +(define + er-bif-registered + (fn + (vs) + (if + (not (= (len vs) 0)) + (error "Erlang: registered/0: arity") + (let + ((ks (keys (er-registered))) (out (er-mk-nil))) + (for-each + (fn + (i) + (let + ((k (nth ks (- (- (len ks) 1) i)))) + (set! out (er-mk-cons (er-mk-atom k) out)))) + (range 0 (len ks))) + out)))) + +;; Find the registered name for a pid, if any. Returns string or nil. +(define + er-find-registration + (fn + (pid) + (let + ((reg (er-registered)) (ks (keys reg)) (found (list nil))) + (for-each + (fn + (i) + (when + (= (nth found 0) nil) + (let + ((k (nth ks i))) + (when (er-pid-equal? (get reg k) pid) (set-nth! found 0 k))))) + (range 0 (len ks))) + (nth found 0)))) + +;; Drop pid from the registry (called on process death). +(define + er-unregister-pid! + (fn + (pid) + (let + ((name (er-find-registration pid))) + (when (not (= name nil)) (dict-delete! (er-registered) name))))) + +(define + er-bif-process-flag + (fn + (vs) + (if + (not (= (len vs) 2)) + (error "Erlang: process_flag/2: arity") + (let + ((flag (nth vs 0)) + (val (nth vs 1)) + (me (er-sched-current-pid))) + (cond + (and (er-atom? flag) (= (get flag :name) "trap_exit")) + (let + ((old (er-proc-field me :trap-exit))) + (er-proc-set! me :trap-exit (er-truthy? val)) + (er-bool old)) + :else (error + (str + "Erlang: process_flag: unsupported flag '" + (er-format-value flag) + "'"))))))) + +(define + er-bif-make-ref + (fn + (vs) + (if + (not (= (len vs) 0)) + (error "Erlang: make_ref/0: arity") + (er-ref-new!)))) + +;; Add `target` to `pid`'s :links list if not already there. +(define + er-link-add-one! + (fn + (pid target) + (let + ((links (er-proc-field pid :links))) + (when + (not (er-link-has? links target)) + (append! links target))))) + +(define + er-link-has? + (fn + (links target) + (cond + (= (len links) 0) false + (er-pid-equal? (nth links 0) target) true + :else (er-link-has? (er-slice-list links 1) target)))) + +(define + er-link-remove-one! + (fn + (pid target) + (let + ((old (er-proc-field pid :links)) (out (list))) + (for-each + (fn + (i) + (let + ((p (nth old i))) + (when (not (er-pid-equal? p target)) (append! out p)))) + (range 0 (len old))) + (er-proc-set! pid :links out)))) + +(define + er-bif-link + (fn + (vs) + (let + ((target (er-bif-arg1 vs "link")) (me (er-sched-current-pid))) + (cond + (not (er-pid? target)) (error "Erlang: link: not a pid") + (er-pid-equal? target me) (er-mk-atom "true") + (not (er-proc-exists? target)) + (raise (er-mk-exit-marker (er-mk-atom "noproc"))) + :else (do + (er-link-add-one! me target) + (er-link-add-one! target me) + (er-mk-atom "true")))))) + +(define + er-bif-unlink + (fn + (vs) + (let + ((target (er-bif-arg1 vs "unlink")) (me (er-sched-current-pid))) + (cond + (not (er-pid? target)) (error "Erlang: unlink: not a pid") + :else (do + (er-link-remove-one! me target) + (when + (er-proc-exists? target) + (er-link-remove-one! target me)) + (er-mk-atom "true")))))) + +(define + er-bif-monitor + (fn + (vs) + (if + (not (= (len vs) 2)) + (error "Erlang: monitor/2: arity") + (let + ((kind (nth vs 0)) + (target (nth vs 1)) + (me (er-sched-current-pid))) + (cond + (not (and (er-atom? kind) (= (get kind :name) "process"))) + (error "Erlang: monitor: only 'process' supported") + (not (er-pid? target)) (error "Erlang: monitor: not a pid") + :else (let + ((ref (er-ref-new!))) + (append! + (er-proc-field me :monitors) + {:ref ref :pid target}) + (when + (er-proc-exists? target) + (append! + (er-proc-field target :monitored-by) + {:from me :ref ref})) + ref)))))) + +(define + er-bif-demonitor + (fn + (vs) + (let + ((ref (er-bif-arg1 vs "demonitor")) (me (er-sched-current-pid))) + (if + (not (er-ref? ref)) + (error "Erlang: demonitor: not a reference") + (do + (er-demonitor-purge! me ref) + (er-mk-atom "true")))))) + +(define + er-demonitor-purge! + (fn + (me ref) + (let + ((old (er-proc-field me :monitors)) (out (list)) (target-ref (list nil))) + (for-each + (fn + (i) + (let + ((m (nth old i))) + (if + (er-ref-equal? (get m :ref) ref) + (set-nth! target-ref 0 (get m :pid)) + (append! out m)))) + (range 0 (len old))) + (er-proc-set! me :monitors out) + (when + (and + (not (= (nth target-ref 0) nil)) + (er-proc-exists? (nth target-ref 0))) + (let + ((target (nth target-ref 0)) + (oldby (er-proc-field (nth target-ref 0) :monitored-by)) + (out2 (list))) + (for-each + (fn + (i) + (let + ((m (nth oldby i))) + (when + (not (er-ref-equal? (get m :ref) ref)) + (append! out2 m)))) + (range 0 (len oldby))) + (er-proc-set! target :monitored-by out2)))))) + +;; ── scheduler loop ────────────────────────────────────────────── +;; Each scheduler step wraps the process body in `guard`. `receive` +;; with no match captures a `call/cc` continuation onto the proc +;; record and then `raise`s `er-suspend-marker`; the guard catches +;; the raise and the scheduler moves on. `exit/1` raises an exit +;; marker the same way. Resumption from a saved continuation also +;; runs under a fresh `guard` so a resumed receive that needs to +;; suspend again has a handler to unwind to. `shift`/`reset` aren't +;; usable here because SX's captured delimited continuations don't +;; re-establish their own reset boundary when invoked — a second +;; suspension during replay raises "shift without enclosing reset". +(define er-suspend-marker {:tag "er-suspend-marker"}) + +(define + er-suspended? + (fn + (v) + (and + (= (type-of v) "dict") + (= (get v :tag) "er-suspend-marker")))) + +(define + er-exited? + (fn + (v) + (and + (= (type-of v) "dict") + (= (get v :tag) "er-exit-marker")))) + +(define + er-mk-exit-marker + (fn (reason) {:tag "er-exit-marker" :reason reason})) + +(define + er-mk-throw-marker + (fn (reason) {:tag "er-throw-marker" :reason reason})) + +(define + er-mk-error-marker + (fn (reason) {:tag "er-error-marker" :reason reason})) + +(define + er-thrown? + (fn + (v) + (and + (= (type-of v) "dict") + (= (get v :tag) "er-throw-marker")))) + +(define + er-errored? + (fn + (v) + (and + (= (type-of v) "dict") + (= (get v :tag) "er-error-marker")))) + +(define + er-sched-run-all! + (fn + () + (let + ((pid (er-sched-next-runnable!))) + (cond + (not (= pid nil)) + (do (er-sched-step! pid) (er-sched-run-all!)) + ;; Queue empty — fire one pending receive-with-timeout and go again. + (er-sched-fire-one-timeout!) (er-sched-run-all!) + :else nil)))) + +;; Wake one waiting process whose receive had an `after Ms` clause. +;; Returns true if one fired. In our synchronous model "time passes" +;; once the runnable queue drains — timeouts only fire then. +(define + er-sched-fire-one-timeout! + (fn + () + (let + ((ks (keys (er-sched-processes))) (fired (list false))) + (for-each + (fn + (k) + (when + (not (nth fired 0)) + (let + ((p (get (er-sched-processes) k))) + (when + (and + (= (get p :state) "waiting") + (get p :has-timeout)) + (dict-set! p :timed-out true) + (dict-set! p :has-timeout false) + (dict-set! p :state "runnable") + (er-sched-enqueue! (get p :pid)) + (set-nth! fired 0 true))))) + ks) + (nth fired 0)))) + +(define + er-sched-step! + (fn + (pid) + (cond + (= (er-proc-field pid :state) "dead") nil + :else (er-sched-step-alive! pid)))) + +(define + er-sched-step-alive! + (fn + (pid) + (er-sched-set-current! pid) + (er-proc-set! pid :state "running") + (let + ((prev-k (er-proc-field pid :continuation)) + (result-ref (list nil))) + (guard + (c + ((er-suspended? c) (set-nth! result-ref 0 c)) + ((er-exited? c) (set-nth! result-ref 0 c)) + ((er-thrown? c) + (set-nth! + result-ref + 0 + (er-mk-exit-marker + (er-mk-tuple + (list (er-mk-atom "nocatch") (get c :reason)))))) + ((er-errored? c) + (set-nth! result-ref 0 (er-mk-exit-marker (get c :reason))))) + (set-nth! + result-ref + 0 + (if + (= prev-k nil) + (er-apply-fun (er-proc-field pid :initial-fun) (list)) + (do (er-proc-set! pid :continuation nil) (prev-k nil))))) + (let + ((r (nth result-ref 0))) + (cond + (er-suspended? r) nil + (er-exited? r) + (do + (er-proc-set! pid :state "dead") + (er-proc-set! pid :exit-reason (get r :reason)) + (er-proc-set! pid :exit-result nil) + (er-proc-set! pid :continuation nil) + (er-unregister-pid! pid) + (er-propagate-exit! pid (get r :reason))) + :else (do + (er-proc-set! pid :state "dead") + (er-proc-set! pid :exit-reason (er-mk-atom "normal")) + (er-proc-set! pid :exit-result r) + (er-proc-set! pid :continuation nil) + (er-unregister-pid! pid) + (er-propagate-exit! pid (er-mk-atom "normal")))))) + (er-sched-set-current! nil))) + +;; ── exit-signal propagation ───────────────────────────────────── +;; Called when `pid` finishes (normally or via exit). Walks the +;; process's `:monitored-by` and `:links` lists to deliver `{'DOWN'}` +;; messages and exit signals respectively. Linked processes without +;; `trap_exit` cascade-die with the same reason; those with +;; `trap_exit` true receive an `{'EXIT', From, Reason}` message. +(define + er-propagate-exit! + (fn + (pid reason) + (er-fire-monitors! pid reason) + (er-fire-links! pid reason))) + +(define + er-fire-monitors! + (fn + (pid reason) + (let + ((mons (er-proc-field pid :monitored-by))) + (for-each + (fn + (i) + (let + ((m (nth mons i))) + (let + ((from (get m :from)) (ref (get m :ref))) + (when + (and (er-proc-exists? from) + (not (= (er-proc-field from :state) "dead"))) + (let + ((msg + (er-mk-tuple + (list + (er-mk-atom "DOWN") + ref + (er-mk-atom "process") + pid + reason)))) + (er-proc-mailbox-push! from msg) + (when + (= (er-proc-field from :state) "waiting") + (er-proc-set! from :state "runnable") + (er-sched-enqueue! from))))))) + (range 0 (len mons)))))) + +(define + er-fire-links! + (fn + (pid reason) + (let + ((links (er-proc-field pid :links)) + (is-normal (er-is-atom-named? reason "normal"))) + (for-each + (fn + (i) + (let + ((target (nth links i))) + (when + (and (er-proc-exists? target) + (not (= (er-proc-field target :state) "dead"))) + (let + ((trap (er-proc-field target :trap-exit))) + (cond + trap (er-deliver-exit-msg! target pid reason) + is-normal nil + :else (er-cascade-exit! target reason)))))) + (range 0 (len links)))))) + +(define + er-deliver-exit-msg! + (fn + (target from reason) + (let + ((msg + (er-mk-tuple (list (er-mk-atom "EXIT") from reason)))) + (er-proc-mailbox-push! target msg) + (when + (= (er-proc-field target :state) "waiting") + (er-proc-set! target :state "runnable") + (er-sched-enqueue! target))))) + +(define + er-cascade-exit! + (fn + (target reason) + (er-proc-set! target :state "dead") + (er-proc-set! target :exit-reason reason) + (er-proc-set! target :exit-result nil) + (er-proc-set! target :continuation nil) + (er-propagate-exit! target reason))) + +;; ── module registry ───────────────────────────────────────────── +;; Global mutable dict from module name -> module env (which itself +;; binds each function name to a fun value capturing the same env, so +;; sibling functions can call each other recursively). +(define er-modules (list {})) +(define er-modules-get (fn () (nth er-modules 0))) +(define er-modules-reset! (fn () (set-nth! er-modules 0 {}))) + +;; Load an Erlang module declaration. Source must start with +;; `-module(Name).` and contain function definitions. Functions +;; sharing a name (different arities) get their clauses concatenated +;; into a single fun value — `er-apply-fun-clauses` already filters +;; by arity, so multi-arity dispatch falls out for free. +(define + erlang-load-module + (fn + (src) + (let + ((module-ast (er-parse-module src))) + (let + ((mod-name (get module-ast :name)) + (functions (get module-ast :functions)) + (mod-env (er-env-new)) + (by-name {})) + (for-each + (fn + (i) + (let + ((f (nth functions i))) + (let + ((name (get f :name)) (clauses (get f :clauses))) + (if + (dict-has? by-name name) + (let + ((existing (get by-name name))) + (for-each + (fn (j) (append! existing (nth clauses j))) + (range 0 (len clauses)))) + (let + ((init (list))) + (for-each + (fn (j) (append! init (nth clauses j))) + (range 0 (len clauses))) + (dict-set! by-name name init)))))) + (range 0 (len functions))) + (for-each + (fn + (k) + (let + ((all-clauses (get by-name k))) + (er-env-bind! mod-env k (er-mk-fun all-clauses mod-env)))) + (keys by-name)) + (dict-set! (er-modules-get) mod-name mod-env) + (er-mk-atom mod-name))))) + +(define + er-apply-user-module + (fn + (mod name vs) + (let + ((mod-env (get (er-modules-get) mod))) + (if + (not (dict-has? mod-env name)) + (raise + (er-mk-error-marker + (er-mk-tuple + (list + (er-mk-atom "undef") + (er-mk-atom mod) + (er-mk-atom name))))) + (er-apply-fun (get mod-env name) vs))))) + +;; ── gen_server (OTP-lite) ─────────────────────────────────────── +;; A minimal gen_server behaviour — `start_link/2`, `call/2`, `cast/2`, +;; `stop/1`, plus the receive loop dispatching `Mod:handle_call/3`, +;; `Mod:handle_cast/2`, `Mod:handle_info/2`. Loaded into the user +;; module registry on demand via `(er-load-gen-server!)`. +(define + er-gen-server-source + "-module(gen_server). + start_link(Mod, Args) -> + spawn(fun () -> + case Mod:init(Args) of + {ok, State} -> gen_server:loop(Mod, State); + {stop, Reason} -> exit(Reason) + end + end). + call(Pid, Req) -> + Ref = make_ref(), + Pid ! {'$gen_call', {self(), Ref}, Req}, + receive {Ref, Reply} -> Reply end. + cast(Pid, Msg) -> + Pid ! {'$gen_cast', Msg}, + ok. + stop(Pid) -> + gen_server:call(Pid, '$gen_stop'). + loop(Mod, State) -> + receive + {'$gen_call', {From, Ref}, '$gen_stop'} -> + From ! {Ref, ok}; + {'$gen_call', {From, Ref}, Req} -> + case Mod:handle_call(Req, From, State) of + {reply, Reply, NewState} -> + From ! {Ref, Reply}, + gen_server:loop(Mod, NewState); + {noreply, NewState} -> + gen_server:loop(Mod, NewState); + {stop, Reason, Reply, NewState} -> + From ! {Ref, Reply}, + exit(Reason) + end; + {'$gen_cast', Msg} -> + case Mod:handle_cast(Msg, State) of + {noreply, NewState} -> gen_server:loop(Mod, NewState); + {stop, Reason, NewState} -> exit(Reason) + end; + Other -> + case Mod:handle_info(Other, State) of + {noreply, NewState} -> gen_server:loop(Mod, NewState); + {stop, Reason, NewState} -> exit(Reason) + end + end.") + +(define + er-load-gen-server! + (fn () (erlang-load-module er-gen-server-source))) + +;; ── supervisor (OTP-lite, one-for-one) ────────────────────────── +;; Each child spec is `{Id, StartFn}` — `StartFn/0` returns the +;; child's pid. The supervisor `process_flag(trap_exit, true)`, +;; links to every child, and on `{'EXIT', DeadPid, _}` calls the +;; matching `StartFn` to bring up a fresh replacement. Strategy is +;; one-for-one: only the dead child restarts; siblings keep running. +(define + er-supervisor-source + "-module(supervisor). + start_link(Mod, Args) -> + spawn(fun () -> + process_flag(trap_exit, true), + case Mod:init(Args) of + {ok, ChildSpecs} -> + Children = lists:map( + fun (Spec) -> supervisor:start_child(Spec) end, + ChildSpecs), + supervisor:loop(Children) + end + end). + start_child({Id, StartFn}) -> + P = StartFn(), + link(P), + {Id, StartFn, P}. + which_children(Sup) -> + Sup ! {'$sup_which', self()}, + receive {'$sup_children', Cs} -> Cs end. + stop(Sup) -> + Sup ! '$sup_stop', + ok. + loop(Children) -> + receive + {'EXIT', Dead, _Reason} -> + supervisor:loop(supervisor:restart(Children, Dead)); + {'$sup_which', From} -> + From ! {'$sup_children', Children}, + supervisor:loop(Children); + '$sup_stop' -> + ok + end. + restart([], _) -> []; + restart([{Id, SF, P} | T], Dead) -> + case P =:= Dead of + true -> + NewP = SF(), + link(NewP), + [{Id, SF, NewP} | T]; + false -> + [{Id, SF, P} | supervisor:restart(T, Dead)] + end.") + +(define + er-load-supervisor! + (fn () (erlang-load-module er-supervisor-source))) + +;; ── ETS-lite ──────────────────────────────────────────────────── +;; Each table is a mutable list of tuples; key is the tuple's first +;; element (keypos=1, the default). Tables live on the scheduler +;; under `:ets` keyed by the registering atom name. Set semantics: +;; `insert/2` replaces an existing entry with the same key. +(define er-ets-tables (fn () (get (er-sched) :ets))) + +(define + er-bif-ets-new + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: ets:new/2: arity") + :else (let + ((name (nth vs 0))) + (cond + (not (er-atom? name)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (dict-has? (er-ets-tables) (get name :name)) + (raise + (er-mk-error-marker + (er-mk-tuple (list (er-mk-atom "badarg") name)))) + :else (do + (dict-set! (er-ets-tables) (get name :name) (list)) + name)))))) + +(define + er-ets-resolve + (fn + (id) + (cond + (not (er-atom? id)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (not (dict-has? (er-ets-tables) (get id :name))) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (get (er-ets-tables) (get id :name))))) + +(define + er-bif-ets-insert + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: ets:insert/2: arity") + :else (let + ((tab (er-ets-resolve (nth vs 0))) + (entry (nth vs 1))) + (cond + (not (er-tuple? entry)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (= (len (get entry :elements)) 0) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (do + (er-ets-replace-or-append! tab entry) + (er-mk-atom "true"))))))) + +(define + er-ets-replace-or-append! + (fn + (tab entry) + (let + ((key (nth (get entry :elements) 0)) + (replaced (list false))) + (for-each + (fn + (i) + (when + (er-equal? (nth (get (nth tab i) :elements) 0) key) + (set-nth! tab i entry) + (set-nth! replaced 0 true))) + (range 0 (len tab))) + (when (not (nth replaced 0)) (append! tab entry))))) + +(define + er-bif-ets-lookup + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: ets:lookup/2: arity") + :else (let + ((tab (er-ets-resolve (nth vs 0))) + (key (nth vs 1)) + (out (er-mk-nil))) + (for-each + (fn + (i) + (let + ((j (- (- (len tab) 1) i)) + (entry (nth tab (- (- (len tab) 1) i)))) + (when + (er-equal? (nth (get entry :elements) 0) key) + (set! out (er-mk-cons entry out))))) + (range 0 (len tab))) + out)))) + +(define + er-bif-ets-delete + (fn + (vs) + (cond + (= (len vs) 1) (er-ets-delete-table! (nth vs 0)) + (= (len vs) 2) (er-ets-delete-key! (nth vs 0) (nth vs 1)) + :else (error "Erlang: ets:delete: arity")))) + +(define + er-ets-delete-table! + (fn + (id) + (cond + (not (er-atom? id)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (not (dict-has? (er-ets-tables) (get id :name))) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (do + (dict-delete! (er-ets-tables) (get id :name)) + (er-mk-atom "true"))))) + +(define + er-ets-delete-key! + (fn + (id key) + (let + ((tab (er-ets-resolve id)) (out (list))) + (for-each + (fn + (i) + (let + ((entry (nth tab i))) + (when + (not (er-equal? (nth (get entry :elements) 0) key)) + (append! out entry)))) + (range 0 (len tab))) + (dict-set! (er-ets-tables) (get id :name) out) + (er-mk-atom "true")))) + +(define + er-bif-ets-tab2list + (fn + (vs) + (let + ((tab (er-ets-resolve (er-bif-arg1 vs "ets:tab2list"))) (out (er-mk-nil))) + (for-each + (fn + (i) + (let + ((j (- (- (len tab) 1) i))) + (set! out (er-mk-cons (nth tab j) out)))) + (range 0 (len tab))) + out))) + +(define + er-bif-ets-info + (fn + (vs) + (cond + (= (len vs) 2) + (let + ((tab (er-ets-resolve (nth vs 0))) (key (nth vs 1))) + (cond + (and (er-atom? key) (= (get key :name) "size")) (len tab) + :else (er-mk-atom "undefined"))) + :else (error "Erlang: ets:info: arity")))) + +(define + er-apply-ets-bif + (fn + (name vs) + (cond + (= name "new") (er-bif-ets-new vs) + (= name "insert") (er-bif-ets-insert vs) + (= name "lookup") (er-bif-ets-lookup vs) + (= name "delete") (er-bif-ets-delete vs) + (= name "tab2list") (er-bif-ets-tab2list vs) + (= name "info") (er-bif-ets-info vs) + :else (error + (str "Erlang: undefined 'ets:" name "/" (len vs) "'"))))) diff --git a/lib/erlang/scoreboard.json b/lib/erlang/scoreboard.json new file mode 100644 index 00000000..b2db94e0 --- /dev/null +++ b/lib/erlang/scoreboard.json @@ -0,0 +1,16 @@ +{ + "language": "erlang", + "total_pass": 530, + "total": 530, + "suites": [ + {"name":"tokenize","pass":62,"total":62,"status":"ok"}, + {"name":"parse","pass":52,"total":52,"status":"ok"}, + {"name":"eval","pass":346,"total":346,"status":"ok"}, + {"name":"runtime","pass":39,"total":39,"status":"ok"}, + {"name":"ring","pass":4,"total":4,"status":"ok"}, + {"name":"ping-pong","pass":4,"total":4,"status":"ok"}, + {"name":"bank","pass":8,"total":8,"status":"ok"}, + {"name":"echo","pass":7,"total":7,"status":"ok"}, + {"name":"fib","pass":8,"total":8,"status":"ok"} + ] +} diff --git a/lib/erlang/scoreboard.md b/lib/erlang/scoreboard.md new file mode 100644 index 00000000..bf9592fa --- /dev/null +++ b/lib/erlang/scoreboard.md @@ -0,0 +1,18 @@ +# Erlang-on-SX Scoreboard + +**Total: 530 / 530 tests passing** + +| | Suite | Pass | Total | +|---|---|---|---| +| ✅ | tokenize | 62 | 62 | +| ✅ | parse | 52 | 52 | +| ✅ | eval | 346 | 346 | +| ✅ | runtime | 39 | 39 | +| ✅ | ring | 4 | 4 | +| ✅ | ping-pong | 4 | 4 | +| ✅ | bank | 8 | 8 | +| ✅ | echo | 7 | 7 | +| ✅ | fib | 8 | 8 | + + +Generated by `lib/erlang/conformance.sh`. diff --git a/lib/erlang/test.sh b/lib/erlang/test.sh new file mode 100755 index 00000000..3149cbd0 --- /dev/null +++ b/lib/erlang/test.sh @@ -0,0 +1,260 @@ +#!/usr/bin/env bash +# lib/erlang/test.sh — smoke-test the Erlang runtime layer. +# Uses sx_server.exe epoch protocol. +# +# Usage: +# bash lib/erlang/test.sh +# bash lib/erlang/test.sh -v + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build" + exit 1 +fi + +VERBOSE="${1:-}" +PASS=0; FAIL=0; ERRORS="" +TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT + +cat > "$TMPFILE" << 'EPOCHS' +(epoch 1) +(load "lib/erlang/runtime.sx") + +;; --- Numeric tower --- +(epoch 10) +(eval "(er-is-integer? 42)") +(epoch 11) +(eval "(er-is-integer? 3.14)") +(epoch 12) +(eval "(er-is-float? 3.14)") +(epoch 13) +(eval "(er-is-float? 42)") +(epoch 14) +(eval "(er-is-number? 42)") +(epoch 15) +(eval "(er-is-number? 3.14)") +(epoch 16) +(eval "(er-float 5)") +(epoch 17) +(eval "(er-trunc 3.9)") +(epoch 18) +(eval "(er-round 3.5)") +(epoch 19) +(eval "(er-abs -7)") +(epoch 20) +(eval "(er-max 3 7)") +(epoch 21) +(eval "(er-min 3 7)") + +;; --- div + rem --- +(epoch 30) +(eval "(er-div 10 3)") +(epoch 31) +(eval "(er-div -10 3)") +(epoch 32) +(eval "(er-rem 10 3)") +(epoch 33) +(eval "(er-rem -10 3)") +(epoch 34) +(eval "(er-gcd 12 8)") + +;; --- Bitwise --- +(epoch 40) +(eval "(er-band 12 10)") +(epoch 41) +(eval "(er-bor 12 10)") +(epoch 42) +(eval "(er-bxor 12 10)") +(epoch 43) +(eval "(er-bnot 0)") +(epoch 44) +(eval "(er-bsl 1 4)") +(epoch 45) +(eval "(er-bsr 16 2)") + +;; --- Sets --- +(epoch 50) +(eval "(er-sets-is-set? (er-sets-new))") +(epoch 51) +(eval "(let ((s (er-sets-new))) (do (er-sets-add-element s 1) (er-sets-is-element s 1)))") +(epoch 52) +(eval "(er-sets-is-element (er-sets-new) 42)") +(epoch 53) +(eval "(er-sets-is-element (er-sets-from-list (list 1 2 3)) 2)") +(epoch 54) +(eval "(er-sets-size (er-sets-from-list (list 1 2 3)))") +(epoch 55) +(eval "(len (er-sets-to-list (er-sets-from-list (list 1 2 3))))") + +;; --- Regexp --- +(epoch 60) +(eval "(not (= (er-re-run \"hello\" \"ll\") nil))") +(epoch 61) +(eval "(= (er-re-run \"hello\" \"xyz\") nil)") +(epoch 62) +(eval "(get (er-re-run \"hello\" \"ll\") :match)") +(epoch 63) +(eval "(er-re-replace \"hello\" \"l\" \"r\")") +(epoch 64) +(eval "(er-re-replace-all \"hello\" \"l\" \"r\")") +(epoch 65) +(eval "(er-re-match-groups (er-re-run \"hello world\" \"(\\w+)\\s+(\\w+)\"))") +(epoch 66) +(eval "(len (er-re-split \"a,b,c\" \",\"))") + +;; --- List BIFs --- +(epoch 70) +(eval "(er-hd (list 1 2 3))") +(epoch 71) +(eval "(er-tl (list 1 2 3))") +(epoch 72) +(eval "(er-length (list 1 2 3))") +(epoch 73) +(eval "(er-lists-member 2 (list 1 2 3))") +(epoch 74) +(eval "(er-lists-member 9 (list 1 2 3))") +(epoch 75) +(eval "(er-lists-reverse (list 1 2 3))") +(epoch 76) +(eval "(er-lists-nth 2 (list 10 20 30))") +(epoch 77) +(eval "(er-lists-foldl + 0 (list 1 2 3 4 5))") +(epoch 78) +(eval "(er-lists-seq 1 5)") +(epoch 79) +(eval "(er-lists-flatten (list 1 (list 2 3) (list 4 (list 5))))") + +;; --- Type conversions --- +(epoch 80) +(eval "(er-integer-to-list 42)") +(epoch 81) +(eval "(er-list-to-integer \"42\")") +(epoch 82) +(eval "(er-integer-to-list-radix 255 16)") +(epoch 83) +(eval "(er-atom-to-list (make-symbol \"hello\"))") +(epoch 84) +(eval "(= (type-of (er-list-to-atom \"foo\")) \"symbol\")") + +;; --- ok/error tuples --- +(epoch 90) +(eval "(er-is-ok? (er-ok 42))") +(epoch 91) +(eval "(er-is-error? (er-error \"reason\"))") +(epoch 92) +(eval "(er-unwrap (er-ok 42))") +(epoch 93) +(eval "(er-is-ok? (er-error \"bad\"))") + +EPOCHS + +OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) + +check() { + local epoch="$1" desc="$2" expected="$3" + local actual + actual=$(echo "$OUTPUT" | grep -A1 "^(ok-len $epoch " | tail -1 || true) + if echo "$actual" | grep -q "^(ok-len"; then actual=""; fi + if [ -z "$actual" ]; then + actual=$(echo "$OUTPUT" | grep "^(ok $epoch " | head -1 || true) + fi + if [ -z "$actual" ]; then + actual=$(echo "$OUTPUT" | grep "^(error $epoch " | head -1 || true) + fi + [ -z "$actual" ] && actual="" + + if echo "$actual" | grep -qF -- "$expected"; then + PASS=$((PASS+1)) + [ "$VERBOSE" = "-v" ] && echo " ok $desc" + else + FAIL=$((FAIL+1)) + ERRORS+=" FAIL [$desc] (epoch $epoch) expected: $expected | actual: $actual +" + fi +} + +# Numeric tower +check 10 "is-integer? 42" "true" +check 11 "is-integer? float" "false" +check 12 "is-float? 3.14" "true" +check 13 "is-float? int" "false" +check 14 "is-number? int" "true" +check 15 "is-number? float" "true" +check 16 "float 5" "5" +check 17 "trunc 3.9" "3" +check 18 "round 3.5" "4" +check 19 "abs -7" "7" +check 20 "max 3 7" "7" +check 21 "min 3 7" "3" + +# div + rem +check 30 "div 10 3" "3" +check 31 "div -10 3" "-3" +check 32 "rem 10 3" "1" +check 33 "rem -10 3" "-1" +check 34 "gcd 12 8" "4" + +# Bitwise +check 40 "band 12 10" "8" +check 41 "bor 12 10" "14" +check 42 "bxor 12 10" "6" +check 43 "bnot 0" "-1" +check 44 "bsl 1 4" "16" +check 45 "bsr 16 2" "4" + +# Sets +check 50 "sets-new is-set?" "true" +check 51 "sets add+member" "true" +check 52 "member empty" "false" +check 53 "from-list member" "true" +check 54 "sets-size" "3" +check 55 "sets-to-list len" "3" + +# Regexp +check 60 "re-run match" "true" +check 61 "re-run no match" "true" +check 62 "re-run match text" '"ll"' +check 63 "re-replace first" '"herlo"' +check 64 "re-replace-all" '"herro"' +check 65 "re-match-groups" '"hello"' +check 66 "re-split count" "3" + +# List BIFs +check 70 "hd" "1" +check 71 "tl" "(2 3)" +check 72 "length" "3" +check 73 "member hit" "true" +check 74 "member miss" "false" +check 75 "reverse" "(3 2 1)" +check 76 "nth 2" "20" +check 77 "foldl sum" "15" +check 78 "seq 1..5" "(1 2 3 4 5)" +check 79 "flatten" "(1 2 3 4 5)" + +# Type conversions +check 80 "integer-to-list" '"42"' +check 81 "list-to-integer" "42" +check 82 "integer-to-list hex" '"ff"' +check 83 "atom-to-list" '"hello"' +check 84 "list-to-atom" "true" + +# ok/error +check 90 "ok? ok-tuple" "true" +check 91 "error? error-tuple" "true" +check 92 "unwrap ok" "42" +check 93 "ok? error-tuple" "false" + +TOTAL=$((PASS+FAIL)) +if [ $FAIL -eq 0 ]; then + echo "ok $PASS/$TOTAL lib/erlang tests passed" +else + echo "FAIL $PASS/$TOTAL passed, $FAIL failed:" + echo "$ERRORS" +fi +[ $FAIL -eq 0 ] diff --git a/lib/erlang/tests/eval.sx b/lib/erlang/tests/eval.sx new file mode 100644 index 00000000..a3056000 --- /dev/null +++ b/lib/erlang/tests/eval.sx @@ -0,0 +1,1130 @@ +;; Erlang evaluator tests — sequential expressions. + +(define er-eval-test-count 0) +(define er-eval-test-pass 0) +(define er-eval-test-fails (list)) + +(define + eev-deep= + (fn + (a b) + (cond + (and (= (type-of a) "dict") (= (type-of b) "dict")) + (let + ((ka (sort (keys a))) (kb (sort (keys b)))) + (and (= ka kb) (every? (fn (k) (eev-deep= (get a k) (get b k))) ka))) + (and (= (type-of a) "list") (= (type-of b) "list")) + (and + (= (len a) (len b)) + (every? (fn (i) (eev-deep= (nth a i) (nth b i))) (range 0 (len a)))) + :else (= a b)))) + +(define + er-eval-test + (fn + (name actual expected) + (set! er-eval-test-count (+ er-eval-test-count 1)) + (if + (eev-deep= actual expected) + (set! er-eval-test-pass (+ er-eval-test-pass 1)) + (append! er-eval-test-fails {:actual actual :expected expected :name name})))) + +(define ev erlang-eval-ast) +(define nm (fn (v) (get v :name))) + +;; ── literals ────────────────────────────────────────────────────── +(er-eval-test "int" (ev "42") 42) +(er-eval-test "zero" (ev "0") 0) +(er-eval-test "float" (ev "3.14") 3.14) +(er-eval-test "string" (ev "\"hi\"") "hi") +(er-eval-test "atom" (nm (ev "ok")) "ok") +(er-eval-test "atom true" (nm (ev "true")) "true") +(er-eval-test "atom false" (nm (ev "false")) "false") + +;; ── arithmetic ──────────────────────────────────────────────────── +(er-eval-test "add" (ev "1 + 2") 3) +(er-eval-test "sub" (ev "5 - 3") 2) +(er-eval-test "mul" (ev "4 * 3") 12) +(er-eval-test "div-real" (ev "10 / 4") 2.5) +(er-eval-test "div-int" (ev "10 div 3") 3) +(er-eval-test "rem" (ev "10 rem 3") 1) +(er-eval-test "div-neg" (ev "-10 div 3") -3) +(er-eval-test "precedence" (ev "1 + 2 * 3") 7) +(er-eval-test "parens" (ev "(1 + 2) * 3") 9) +(er-eval-test "unary-neg" (ev "-(1 + 2)") -3) +(er-eval-test "unary-neg int" (ev "-7") -7) + +;; ── comparison ──────────────────────────────────────────────────── +(er-eval-test "lt true" (nm (ev "1 < 2")) "true") +(er-eval-test "gt false" (nm (ev "1 > 2")) "false") +(er-eval-test "le equal" (nm (ev "2 =< 2")) "true") +(er-eval-test "ge equal" (nm (ev "2 >= 2")) "true") +(er-eval-test "eq" (nm (ev "2 == 2")) "true") +(er-eval-test "neq" (nm (ev "1 /= 2")) "true") +(er-eval-test "exact-eq same" (nm (ev "1 =:= 1")) "true") +(er-eval-test "exact-neq int" (nm (ev "1 =:= 2")) "false") +(er-eval-test "=/= true" (nm (ev "1 =/= 2")) "true") +(er-eval-test "atom-eq" (nm (ev "ok == ok")) "true") +(er-eval-test "atom-neq" (nm (ev "ok == error")) "false") + +;; ── logical ─────────────────────────────────────────────────────── +(er-eval-test "and tt" (nm (ev "true and true")) "true") +(er-eval-test "and tf" (nm (ev "true and false")) "false") +(er-eval-test "or tf" (nm (ev "true or false")) "true") +(er-eval-test + "andalso short" + (nm (ev "false andalso Neverref")) + "false") +(er-eval-test + "orelse short" + (nm (ev "true orelse Neverref")) + "true") +(er-eval-test "not true" (nm (ev "not true")) "false") +(er-eval-test "not false" (nm (ev "not false")) "true") + +;; ── tuples & lists ──────────────────────────────────────────────── +(er-eval-test "tuple tag" (get (ev "{1, 2, 3}") :tag) "tuple") +(er-eval-test "tuple len" (len (get (ev "{1, 2, 3}") :elements)) 3) +(er-eval-test "tuple elem" (nth (get (ev "{10, 20}") :elements) 1) 20) +(er-eval-test "empty tuple" (len (get (ev "{}") :elements)) 0) +(er-eval-test "nested tuple" + (nm (nth (get (ev "{ok, error}") :elements) 0)) "ok") +(er-eval-test "nil list" (get (ev "[]") :tag) "nil") +(er-eval-test "list head" (get (ev "[1, 2, 3]") :head) 1) +(er-eval-test + "list tail tail head" + (get (get (get (ev "[1, 2, 3]") :tail) :tail) :head) + 3) + +;; ── list ops ────────────────────────────────────────────────────── +(er-eval-test "++ head" (get (ev "[1, 2] ++ [3]") :head) 1) +(er-eval-test "++ last" + (get (get (get (ev "[1, 2] ++ [3]") :tail) :tail) :head) 3) + +;; ── block ───────────────────────────────────────────────────────── +(er-eval-test "block last wins" (ev "begin 1, 2, 3 end") 3) +(er-eval-test "bare body" (ev "1, 2, 99") 99) + +;; ── match + var ─────────────────────────────────────────────────── +(er-eval-test "match bind-and-use" (ev "X = 5, X + 1") 6) +(er-eval-test "match sequential" (ev "X = 1, Y = 2, X + Y") 3) +(er-eval-test + "rebind equal ok" + (ev "X = 5, X = 5, X") 5) + +;; ── if ──────────────────────────────────────────────────────────── +(er-eval-test "if picks first" (ev "if true -> 1; true -> 2 end") 1) +(er-eval-test + "if picks second" + (nm (ev "if 1 > 2 -> bad; true -> good end")) + "good") +(er-eval-test + "if with guard" + (ev "X = 5, if X > 0 -> 1; true -> 0 end") + 1) + +;; ── pattern matching ───────────────────────────────────────────── +(er-eval-test "match atom literal" (nm (ev "ok = ok, done")) "done") +(er-eval-test "match int literal" (ev "5 = 5, 42") 42) +(er-eval-test "match tuple bind" + (ev "{ok, V} = {ok, 99}, V") 99) +(er-eval-test "match tuple nested" + (ev "{A, {B, C}} = {1, {2, 3}}, A + B + C") 6) +(er-eval-test "match cons head" + (ev "[H|T] = [1, 2, 3], H") 1) +(er-eval-test "match cons tail head" + (ev "[_, H|_] = [1, 2, 3], H") 2) +(er-eval-test "match nil" + (ev "[] = [], 7") 7) +(er-eval-test "match wildcard always" + (ev "_ = 42, 7") 7) +(er-eval-test "match var reuse equal" + (ev "X = 5, X = 5, X") 5) + +;; ── case ───────────────────────────────────────────────────────── +(er-eval-test "case bind" (ev "case 5 of N -> N end") 5) +(er-eval-test "case tuple" + (ev "case {ok, 42} of {ok, V} -> V end") 42) +(er-eval-test "case cons" + (ev "case [1, 2, 3] of [H|_] -> H end") 1) +(er-eval-test "case fallthrough" + (ev "case error of ok -> 1; error -> 2 end") 2) +(er-eval-test "case wildcard" + (nm (ev "case x of ok -> ok; _ -> err end")) + "err") +(er-eval-test "case guard" + (ev "case 5 of N when N > 0 -> pos; _ -> neg end") + (er-mk-atom "pos")) +(er-eval-test "case guard fallthrough" + (ev "case -3 of N when N > 0 -> pos; _ -> neg end") + (er-mk-atom "neg")) +(er-eval-test "case bound re-match" + (ev "X = 5, case 5 of X -> same; _ -> diff end") + (er-mk-atom "same")) +(er-eval-test "case bound re-match fail" + (ev "X = 5, case 6 of X -> same; _ -> diff end") + (er-mk-atom "diff")) +(er-eval-test "case nested tuple" + (ev "case {ok, {value, 42}} of {ok, {value, V}} -> V end") + 42) +(er-eval-test "case multi-clause" + (ev "case 2 of 1 -> one; 2 -> two; _ -> other end") + (er-mk-atom "two")) +(er-eval-test "case leak binding" + (ev "case {ok, 7} of {ok, X} -> X end + 1") + 8) + +;; ── guard BIFs (is_*) ──────────────────────────────────────────── +(er-eval-test "is_integer 42" (nm (ev "is_integer(42)")) "true") +(er-eval-test "is_integer ok" (nm (ev "is_integer(ok)")) "false") +(er-eval-test "is_atom ok" (nm (ev "is_atom(ok)")) "true") +(er-eval-test "is_atom int" (nm (ev "is_atom(42)")) "false") +(er-eval-test "is_list cons" (nm (ev "is_list([1,2])")) "true") +(er-eval-test "is_list nil" (nm (ev "is_list([])")) "true") +(er-eval-test "is_list tuple" (nm (ev "is_list({1,2})")) "false") +(er-eval-test "is_tuple tuple" (nm (ev "is_tuple({ok,1})")) "true") +(er-eval-test "is_tuple list" (nm (ev "is_tuple([1])")) "false") +(er-eval-test "is_number int" (nm (ev "is_number(42)")) "true") +(er-eval-test "is_number atom" (nm (ev "is_number(foo)")) "false") +(er-eval-test "is_boolean true" (nm (ev "is_boolean(true)")) "true") +(er-eval-test "is_boolean false" (nm (ev "is_boolean(false)")) "true") +(er-eval-test "is_boolean atom" (nm (ev "is_boolean(foo)")) "false") + +;; ── guard BIFs wired into case / if ───────────────────────────── +(er-eval-test "guard is_integer pick" + (nm (ev "case 5 of N when is_integer(N) -> int; _ -> other end")) + "int") +(er-eval-test "guard is_integer reject" + (nm (ev "case foo of N when is_integer(N) -> int; _ -> other end")) + "other") +(er-eval-test "guard is_atom" + (nm (ev "case foo of X when is_atom(X) -> atom_yes; _ -> no end")) + "atom_yes") +(er-eval-test "guard conjunction" + (nm (ev "case 5 of N when is_integer(N), N > 0 -> pos; _ -> np end")) + "pos") +(er-eval-test "guard disjunction (if)" + (nm (ev "X = foo, if is_integer(X); is_atom(X) -> yes; true -> no end")) + "yes") +(er-eval-test "guard arith" + (nm (ev "case 3 of N when N * 2 > 5 -> big; _ -> small end")) + "big") + +;; ── BIFs: list + tuple ────────────────────────────────────────── +(er-eval-test "length empty" (ev "length([])") 0) +(er-eval-test "length 3" (ev "length([a, b, c])") 3) +(er-eval-test "length cons chain" (ev "length([1 | [2 | [3 | []]]])") 3) +(er-eval-test "hd" (ev "hd([10, 20, 30])") 10) +(er-eval-test "hd atom" + (nm (ev "hd([ok, err])")) "ok") +(er-eval-test "tl head" + (get (ev "tl([1, 2, 3])") :head) 2) +(er-eval-test "tl of single" (get (ev "tl([1])") :tag) "nil") +(er-eval-test "element 1" (nm (ev "element(1, {ok, value})")) "ok") +(er-eval-test "element 2" (ev "element(2, {ok, 42})") 42) +(er-eval-test "element 3" + (nm (ev "element(3, {a, b, c, d})")) "c") +(er-eval-test "tuple_size 2" (ev "tuple_size({a, b})") 2) +(er-eval-test "tuple_size 0" (ev "tuple_size({})") 0) + +;; ── BIFs: atom / list conversions ─────────────────────────────── +(er-eval-test "atom_to_list" (ev "atom_to_list(hello)") "hello") +(er-eval-test "list_to_atom roundtrip" + (nm (ev "list_to_atom(atom_to_list(foo))")) "foo") +(er-eval-test "list_to_atom fresh" + (nm (ev "list_to_atom(\"bar\")")) "bar") + +;; ── lists module ──────────────────────────────────────────────── +(er-eval-test "lists:reverse empty" + (get (ev "lists:reverse([])") :tag) "nil") +(er-eval-test "lists:reverse 3" + (ev "hd(lists:reverse([1, 2, 3]))") 3) +(er-eval-test "lists:reverse full" + (ev "lists:foldl(fun (X, Acc) -> Acc + X end, 0, lists:reverse([1, 2, 3]))") 6) + +;; ── funs + lists:map / lists:foldl ────────────────────────────── +(er-eval-test "fun call" (ev "F = fun (X) -> X + 1 end, F(10)") 11) +(er-eval-test "fun two-arg" + (ev "F = fun (X, Y) -> X * Y end, F(3, 4)") 12) +(er-eval-test "fun closure" + (ev "N = 100, F = fun (X) -> X + N end, F(5)") 105) +(er-eval-test "fun clauses" + (ev "F = fun (0) -> zero; (N) -> N end, element(1, {F(0), F(7)})") + (er-mk-atom "zero")) +(er-eval-test "fun multi-clause second" + (ev "F = fun (0) -> 0; (N) -> N * 2 end, F(5)") 10) +(er-eval-test "lists:map empty" + (get (ev "lists:map(fun (X) -> X end, [])") :tag) "nil") +(er-eval-test "lists:map double" + (ev "hd(lists:map(fun (X) -> X * 2 end, [1, 2, 3]))") 2) +(er-eval-test "lists:map sum-length" + (ev "length(lists:map(fun (X) -> X end, [a, b, c, d]))") 4) +(er-eval-test "lists:foldl sum" + (ev "lists:foldl(fun (X, Acc) -> X + Acc end, 0, [1, 2, 3, 4, 5])") 15) +(er-eval-test "lists:foldl product" + (ev "lists:foldl(fun (X, Acc) -> X * Acc end, 1, [1, 2, 3, 4])") 24) +(er-eval-test "lists:foldl as reverse" + (ev "hd(lists:foldl(fun (X, Acc) -> [X | Acc] end, [], [1, 2, 3]))") 3) + +;; ── io:format (via capture buffer) ────────────────────────────── +(er-eval-test "io:format plain" + (do (er-io-flush!) (ev "io:format(\"hello~n\")") (er-io-buffer-content)) + "hello\n") +(er-eval-test "io:format args" + (do (er-io-flush!) (ev "io:format(\"x=~p y=~p~n\", [42, hello])") (er-io-buffer-content)) + "x=42 y=hello\n") +(er-eval-test "io:format returns ok" + (nm (do (er-io-flush!) (ev "io:format(\"~n\")"))) "ok") +(er-eval-test "io:format tuple" + (do (er-io-flush!) (ev "io:format(\"~p\", [{ok, 1}])") (er-io-buffer-content)) + "{ok,1}") +(er-eval-test "io:format list" + (do (er-io-flush!) (ev "io:format(\"~p\", [[1,2,3]])") (er-io-buffer-content)) + "[1,2,3]") +(er-eval-test "io:format escape" + (do (er-io-flush!) (ev "io:format(\"50~~\")") (er-io-buffer-content)) + "50~") + +;; ── processes: self/0, spawn/1, is_pid ────────────────────────── +(er-eval-test "self tag" + (get (ev "self()") :tag) "pid") +(er-eval-test "is_pid self" + (nm (ev "is_pid(self())")) "true") +(er-eval-test "is_pid number" + (nm (ev "is_pid(42)")) "false") +(er-eval-test "is_pid atom" + (nm (ev "is_pid(ok)")) "false") +(er-eval-test "self equals self" + (nm (ev "Pid = self(), Pid =:= Pid")) "true") +(er-eval-test "self =:= self expr" + (nm (ev "self() == self()")) "true") +(er-eval-test "spawn returns pid" + (get (ev "spawn(fun () -> ok end)") :tag) "pid") +(er-eval-test "is_pid spawn" + (nm (ev "is_pid(spawn(fun () -> ok end))")) "true") +(er-eval-test "spawn new pid distinct" + (nm (ev "P1 = self(), P2 = spawn(fun () -> ok end), P1 =:= P2")) + "false") +(er-eval-test "two spawns distinct" + (nm (ev "P1 = spawn(fun () -> ok end), P2 = spawn(fun () -> ok end), P1 =:= P2")) + "false") +(er-eval-test "spawn then drain io" + (do + (er-io-flush!) + (ev "spawn(fun () -> io:format(\"child~n\") end), io:format(\"parent~n\")") + (er-io-buffer-content)) + "parent\nchild\n") +(er-eval-test "multiple spawn ordering" + (do + (er-io-flush!) + (ev "spawn(fun () -> io:format(\"a~n\") end), spawn(fun () -> io:format(\"b~n\") end), io:format(\"main~n\")") + (er-io-buffer-content)) + "main\na\nb\n") +(er-eval-test "child self is its own pid" + (do + (er-io-flush!) + (ev "P = spawn(fun () -> io:format(\"~p\", [is_pid(self())]) end), io:format(\"~p;\", [is_pid(P)])") + (er-io-buffer-content)) + "true;true") + +;; ── ! (send) + receive ────────────────────────────────────────── +(er-eval-test "self-send + receive" + (nm (ev "Me = self(), Me ! hello, receive Msg -> Msg end")) "hello") +(er-eval-test "send returns msg" + (nm (ev "Me = self(), Msg = Me ! ok, Me ! x, receive _ -> Msg end")) "ok") +(er-eval-test "receive int" + (ev "Me = self(), Me ! 42, receive N -> N + 1 end") 43) +(er-eval-test "receive with pattern" + (ev "Me = self(), Me ! {ok, 7}, receive {ok, V} -> V * 2 end") 14) +(er-eval-test "receive with guard" + (ev "Me = self(), Me ! 5, receive N when N > 0 -> positive end") + (er-mk-atom "positive")) +(er-eval-test "receive skips non-match" + (nm (ev "Me = self(), Me ! wrong, Me ! right, receive right -> ok end")) + "ok") +(er-eval-test "receive selective leaves others" + (nm (ev "Me = self(), Me ! a, Me ! b, receive b -> got_b end")) + "got_b") +(er-eval-test "two receives consume both" + (ev "Me = self(), Me ! 1, Me ! 2, X = receive A -> A end, Y = receive B -> B end, X + Y") 3) + +;; ── spawn + send + receive (real process communication) ───────── +(er-eval-test "spawn sends back" + (nm + (ev "Me = self(), spawn(fun () -> Me ! pong end), receive pong -> got_pong end")) + "got_pong") +(er-eval-test "ping-pong" + (do + (er-io-flush!) + (ev "Me = self(), Child = spawn(fun () -> receive {ping, From} -> From ! pong end end), Child ! {ping, Me}, receive pong -> io:format(\"pong~n\") end") + (er-io-buffer-content)) + "pong\n") +(er-eval-test "echo server" + (ev "Me = self(), Echo = spawn(fun () -> receive {From, Msg} -> From ! Msg end end), Echo ! {Me, 99}, receive R -> R end") 99) + +;; ── receive with multiple clauses ──────────────────────────────── +(er-eval-test "receive multi-clause" + (nm (ev "Me = self(), Me ! foo, receive ok -> a; foo -> b; bar -> c end")) + "b") +(er-eval-test "receive nested tuple" + (ev "Me = self(), Me ! {result, {ok, 42}}, receive {result, {ok, V}} -> V end") 42) + +;; ── receive ... after ... ─────────────────────────────────────── +(er-eval-test "after 0 empty mailbox" + (nm (ev "receive _ -> got after 0 -> timeout end")) + "timeout") +(er-eval-test "after 0 match wins" + (nm (ev "Me = self(), Me ! ok, receive ok -> got after 0 -> timeout end")) + "got") +(er-eval-test "after 0 non-match fires timeout" + (nm (ev "Me = self(), Me ! wrong, receive right -> got after 0 -> timeout end")) + "timeout") +(er-eval-test "after 0 leaves non-match" + (ev "Me = self(), Me ! wrong, receive right -> got after 0 -> to end, receive X -> X end") + (er-mk-atom "wrong")) +(er-eval-test "after Ms no sender — timeout fires" + (nm (ev "receive _ -> got after 100 -> timed_out end")) + "timed_out") +(er-eval-test "after Ms with sender — match wins" + (nm (ev "Me = self(), spawn(fun () -> Me ! hi end), receive hi -> got after 100 -> to end")) + "got") +(er-eval-test "after Ms computed" + (nm (ev "Ms = 50, receive _ -> got after Ms -> done end")) + "done") +(er-eval-test "after 0 body side effect" + (do (er-io-flush!) + (ev "receive _ -> ok after 0 -> io:format(\"to~n\") end") + (er-io-buffer-content)) + "to\n") +(er-eval-test "after zero poll selective" + (ev "Me = self(), Me ! first, Me ! second, X = receive second -> got_second after 0 -> to end, Y = receive first -> got_first after 0 -> to end, {X, Y}") + (er-mk-tuple (list (er-mk-atom "got_second") (er-mk-atom "got_first")))) + +;; ── exit/1 + process termination ───────────────────────────────── +(er-eval-test "exit normal returns nil" (ev "exit(normal)") nil) +(er-eval-test "exit normal reason" + (do (ev "exit(normal)") (nm (er-last-main-exit-reason))) "normal") +(er-eval-test "exit bye reason" + (do (ev "exit(bye)") (nm (er-last-main-exit-reason))) "bye") +(er-eval-test "exit tuple reason" + (do (ev "exit({shutdown, crash})") + (get (er-last-main-exit-reason) :tag)) + "tuple") +(er-eval-test "normal completion reason" + (do (ev "42") (nm (er-last-main-exit-reason))) "normal") +(er-eval-test "exit aborts subsequent" + (do (er-io-flush!) (ev "io:format(\"a~n\"), exit(bye), io:format(\"b~n\")") (er-io-buffer-content)) + "a\n") +(er-eval-test "child exit doesn't kill parent" + (do + (er-io-flush!) + (ev "spawn(fun () -> io:format(\"before~n\"), exit(quit), io:format(\"after~n\") end), io:format(\"main~n\")") + (er-io-buffer-content)) + "main\nbefore\n") +(er-eval-test "child exit reason recorded on child" + (do + (er-io-flush!) + (ev "P = spawn(fun () -> exit(child_bye) end), io:format(\"~p\", [is_pid(P)])") + (er-io-buffer-content)) + "true") +(er-eval-test "exit inside fn chain" + (do (ev "F = fun () -> exit(from_fn) end, F()") + (nm (er-last-main-exit-reason))) + "from_fn") + +;; ── refs / link / monitor ────────────────────────────────────── +(er-eval-test "make_ref tag" + (get (ev "make_ref()") :tag) "ref") +(er-eval-test "is_reference fresh" + (nm (ev "R = make_ref(), is_reference(R)")) "true") +(er-eval-test "is_reference pid" + (nm (ev "is_reference(self())")) "false") +(er-eval-test "is_reference number" + (nm (ev "is_reference(42)")) "false") +(er-eval-test "make_ref distinct" + (nm (ev "R1 = make_ref(), R2 = make_ref(), R1 =:= R2")) "false") +(er-eval-test "make_ref same id eq" + (nm (ev "R = make_ref(), R =:= R")) "true") + +(er-eval-test "link returns true" + (nm (ev "P = spawn(fun () -> ok end), link(P)")) "true") +(er-eval-test "self link returns true" + (nm (ev "link(self())")) "true") +(er-eval-test "unlink returns true" + (nm (ev "P = spawn(fun () -> ok end), link(P), unlink(P)")) "true") +(er-eval-test "unlink without link" + (nm (ev "P = spawn(fun () -> ok end), unlink(P)")) "true") + +(er-eval-test "monitor returns ref" + (get (ev "P = spawn(fun () -> ok end), monitor(process, P)") :tag) + "ref") +(er-eval-test "monitor refs distinct" + (nm (ev "P = spawn(fun () -> ok end), R1 = monitor(process, P), R2 = monitor(process, P), R1 =:= R2")) + "false") +(er-eval-test "demonitor returns true" + (nm (ev "P = spawn(fun () -> ok end), R = monitor(process, P), demonitor(R)")) + "true") + +;; Bidirectional link recorded on both sides. +(er-eval-test "link bidirectional" + (do + (ev "P = spawn(fun () -> receive forever -> ok end end), link(P)") + ;; After eval, check links on main + child via accessors. + (and + (= (len (er-proc-field (er-mk-pid 0) :links)) 1) + (= (len (er-proc-field (er-mk-pid 1) :links)) 1))) + true) + +;; unlink clears both sides. +(er-eval-test "unlink clears both" + (do + (ev "P = spawn(fun () -> receive forever -> ok end end), link(P), unlink(P)") + (and + (= (len (er-proc-field (er-mk-pid 0) :links)) 0) + (= (len (er-proc-field (er-mk-pid 1) :links)) 0))) + true) + +;; monitor adds entries to both lists. +(er-eval-test "monitor records both sides" + (do + (ev "P = spawn(fun () -> receive forever -> ok end end), monitor(process, P)") + (and + (= (len (er-proc-field (er-mk-pid 0) :monitors)) 1) + (= (len (er-proc-field (er-mk-pid 1) :monitored-by)) 1))) + true) + +;; demonitor clears both lists. +(er-eval-test "demonitor clears both" + (do + (ev "P = spawn(fun () -> receive forever -> ok end end), R = monitor(process, P), demonitor(R)") + (and + (= (len (er-proc-field (er-mk-pid 0) :monitors)) 0) + (= (len (er-proc-field (er-mk-pid 1) :monitored-by)) 0))) + true) + +;; ── exit-signal propagation + trap_exit ──────────────────────── +(er-eval-test "process_flag default false" + (nm (ev "process_flag(trap_exit, true)")) "false") +(er-eval-test "process_flag returns prev" + (nm (ev "process_flag(trap_exit, true), process_flag(trap_exit, false)")) + "true") + +;; Monitor fires on normal exit. +(er-eval-test "monitor DOWN normal" + (nm (ev "P = spawn(fun () -> ok end), monitor(process, P), receive {'DOWN', _, process, _, R} -> R end")) + "normal") + +;; Monitor fires on abnormal exit. +(er-eval-test "monitor DOWN abnormal" + (nm (ev "P = spawn(fun () -> exit(boom) end), monitor(process, P), receive {'DOWN', _, process, _, R} -> R end")) + "boom") + +;; Monitor's ref appears in DOWN message. +(er-eval-test "monitor DOWN ref matches" + (nm (ev "P = spawn(fun () -> exit(bye) end), Ref = monitor(process, P), receive {'DOWN', Ref, process, _, _} -> ok_match end")) + "ok_match") + +;; Two monitors -> both fire. +(er-eval-test "two monitors both fire" + (ev "P = spawn(fun () -> exit(crash) end), monitor(process, P), monitor(process, P), receive {'DOWN', _, _, _, _} -> ok end, receive {'DOWN', _, _, _, _} -> 2 end") + 2) + +;; trap_exit + link + abnormal exit -> {'EXIT', From, Reason} message. +(er-eval-test "trap_exit catches abnormal" + (nm (ev "process_flag(trap_exit, true), P = spawn(fun () -> exit(boom) end), link(P), receive {'EXIT', _, R} -> R end")) + "boom") + +;; trap_exit + link + normal exit -> {'EXIT', From, normal}. +(er-eval-test "trap_exit catches normal" + (nm (ev "process_flag(trap_exit, true), P = spawn(fun () -> ok end), link(P), receive {'EXIT', _, R} -> R end")) + "normal") + +;; Cascade exit: A links B, B dies abnormally, A dies with same reason. +(er-eval-test "cascade reason" + (do + (ev "A = spawn(fun () -> B = spawn(fun () -> exit(crash) end), link(B), receive forever -> ok end end), receive after 0 -> ok end") + (nm (er-proc-field (er-mk-pid 1) :exit-reason))) + "crash") + +;; Normal exit doesn't cascade (without trap_exit) — A's body returns +;; "survived" via the `after` clause and A dies normally. +(er-eval-test "normal exit no cascade" + (do + (ev "A = spawn(fun () -> B = spawn(fun () -> ok end), link(B), receive {'EXIT', _, _} -> got_exit after 50 -> survived end end), receive after 0 -> ok end") + (list + (nm (er-proc-field (er-mk-pid 1) :exit-reason)) + (nm (er-proc-field (er-mk-pid 1) :exit-result)))) + (list "normal" "survived")) + +;; Monitor without trap_exit: monitored proc abnormal doesn't kill the monitor. +(er-eval-test "monitor doesn't cascade" + (nm (ev "P = spawn(fun () -> exit(boom) end), monitor(process, P), receive {'DOWN', _, _, _, _} -> alive end")) + "alive") + +;; ── try / catch / of / after ───────────────────────────────── +(er-eval-test "try plain" + (ev "try 1 + 2 catch _ -> oops end") 3) + +(er-eval-test "try throw caught" + (nm (ev "try throw(boom) catch throw:X -> X end")) "boom") +(er-eval-test "try error caught" + (nm (ev "try error(crash) catch error:X -> X end")) "crash") +(er-eval-test "try exit caught" + (nm (ev "try exit(quit) catch exit:X -> X end")) "quit") + +(er-eval-test "default class is throw" + (nm (ev "try throw(bye) catch X -> X end")) "bye") +(er-eval-test "default class doesn't catch error" + (do + (ev "P = spawn(fun () -> try error(crash) catch X -> X end end), receive after 0 -> ok end") + (nm (er-proc-field (er-mk-pid 1) :exit-reason))) + "crash") + +;; of clauses +(er-eval-test "try of single" + (ev "try 42 of N -> N * 2 catch _ -> 0 end") 84) +(er-eval-test "try of multi" + (nm (ev "try ok of ok -> matched; _ -> nope catch _ -> oops end")) + "matched") +(er-eval-test "try of fallthrough" + (nm (ev "try x of ok -> a; error -> b; _ -> default catch _ -> oops end")) + "default") +(er-eval-test "try of with guard" + (nm (ev "try 5 of N when N > 0 -> pos; _ -> nonneg catch _ -> oops end")) + "pos") + +;; after clause +(er-eval-test "after on success" + (do (er-io-flush!) + (ev "try 7 after io:format(\"a\") end") + (er-io-buffer-content)) + "a") +(er-eval-test "after on caught" + (do (er-io-flush!) + (ev "try throw(b) catch throw:_ -> caught after io:format(\"x\") end") + (er-io-buffer-content)) + "x") +(er-eval-test "after returns body value" + (ev "try 99 after 0 end") 99) +(er-eval-test "try preserves catch result" + (nm (ev "try throw(x) catch throw:_ -> recovered after 0 end")) + "recovered") + +;; nested try +(er-eval-test "try nested catch outer" + (nm (ev "try (try throw(inner) catch error:_ -> bad end) catch throw:X -> X end")) + "inner") +(er-eval-test "try nested catch inner" + (nm (ev "try (try throw(inner) catch throw:X -> X end) catch _ -> outer end")) + "inner") + +;; class re-raise on no-match +(er-eval-test "throw without catch-throw escapes" + (do + (ev "P = spawn(fun () -> try throw(bye) catch error:_ -> nope end end), receive after 0 -> ok end") + (let ((reason (er-proc-field (er-mk-pid 1) :exit-reason))) + (and (er-tuple? reason) (nm (nth (get reason :elements) 0))))) + "nocatch") + +;; multi-clause catch +(er-eval-test "multi-clause catch picks throw" + (nm (ev "try throw(a) catch error:X -> e; throw:X -> t; exit:X -> x end")) + "t") +(er-eval-test "multi-clause catch picks exit" + (nm (ev "try exit(a) catch error:X -> e; throw:X -> t; exit:X -> x end")) + "x") + +;; ── modules: -module(M)., M:F/N cross-module calls ───────────── +(er-eval-test "load module returns name" + (nm (erlang-load-module "-module(m1). foo() -> 42.")) + "m1") + +(er-eval-test "cross-module zero-arity" + (do + (erlang-load-module "-module(m2). val() -> 7.") + (ev "m2:val()")) + 7) + +(er-eval-test "cross-module n-ary" + (do + (erlang-load-module "-module(m3). add(X, Y) -> X + Y.") + (ev "m3:add(3, 4)")) + 7) + +(er-eval-test "module recursive fn" + (do + (erlang-load-module "-module(m4). fact(0) -> 1; fact(N) -> N * fact(N-1).") + (ev "m4:fact(6)")) + 720) + +(er-eval-test "module sibling calls" + (do + (erlang-load-module "-module(m5). a(X) -> b(X) + 1. b(X) -> X * 10.") + (ev "m5:a(5)")) + 51) + +(er-eval-test "module multi-arity" + (do + (erlang-load-module + "-module(m6). f(X) -> X. f(X, Y) -> X + Y. f(X, Y, Z) -> X * Y + Z.") + (ev "{m6:f(1), m6:f(2, 3), m6:f(2, 3, 4)}")) + (er-mk-tuple (list 1 5 10))) + +(er-eval-test "module pattern match clauses" + (do + (erlang-load-module + "-module(m7). check(0) -> zero; check(N) when N > 0 -> pos; check(_) -> neg.") + (nm (ev "m7:check(-3)"))) + "neg") + +(er-eval-test "cross-module call within module" + (do + (erlang-load-module "-module(util1). dbl(X) -> X * 2.") + (erlang-load-module "-module(util2). quad(X) -> util1:dbl(X) * 2.") + (ev "util2:quad(5)")) + 20) + +(er-eval-test "module undefined fn raises" + (do + (erlang-load-module "-module(m8). foo() -> 1.") + (er-io-flush!) + (ev "P = spawn(fun () -> m8:bar() end), receive after 0 -> ok end") + (let ((reason (er-proc-field (er-mk-pid 1) :exit-reason))) + (and (er-tuple? reason) (nm (nth (get reason :elements) 0))))) + "undef") + +(er-eval-test "module function used in spawn" + (do + (erlang-load-module "-module(m9). work(P) -> P ! done.") + (ev "Me = self(), spawn(fun () -> m9:work(Me) end), receive done -> ok end")) + (er-mk-atom "ok")) + +;; ── gen_server (OTP-lite) ────────────────────────────────────── +(do + (er-load-gen-server!) + (erlang-load-module + "-module(ctr). + init(N) -> {ok, N}. + handle_call(get, _F, S) -> {reply, S, S}. + handle_call({set, V}, _F, _S) -> {reply, ok, V}. + handle_call({add, K}, _F, S) -> {reply, S + K, S + K}. + handle_cast(inc, S) -> {noreply, S + 1}. + handle_cast(dec, S) -> {noreply, S - 1}. + handle_cast({add, K}, S) -> {noreply, S + K}. + handle_info(_M, S) -> {noreply, S}.") + nil) + +(er-eval-test "gen_server start + call get" + (ev "P = gen_server:start_link(ctr, 10), gen_server:call(P, get)") + 10) + +(er-eval-test "gen_server cast then call" + (ev "P = gen_server:start_link(ctr, 0), gen_server:cast(P, inc), gen_server:cast(P, inc), gen_server:cast(P, inc), gen_server:call(P, get)") + 3) + +(er-eval-test "gen_server call returns reply" + (ev "P = gen_server:start_link(ctr, 5), gen_server:call(P, {add, 7})") + 12) + +(er-eval-test "gen_server state mutation" + (ev "P = gen_server:start_link(ctr, 5), gen_server:call(P, {set, 99}), gen_server:call(P, get)") + 99) + +(er-eval-test "gen_server stop returns ok" + (nm (ev "P = gen_server:start_link(ctr, 0), gen_server:stop(P)")) + "ok") + +(er-eval-test "gen_server cast returns ok immediately" + (nm (ev "P = gen_server:start_link(ctr, 0), gen_server:cast(P, inc)")) + "ok") + +(er-eval-test "gen_server multi-state mutations" + (ev "P = gen_server:start_link(ctr, 0), gen_server:cast(P, {add, 100}), gen_server:cast(P, dec), gen_server:cast(P, dec), gen_server:call(P, get)") + 98) + +;; Stack server — exercises a different state shape. +(do + (erlang-load-module + "-module(stk). + init(_) -> {ok, []}. + handle_call(pop, _F, []) -> {reply, empty, []}; + handle_call(pop, _F, [H | T]) -> {reply, {ok, H}, T}; + handle_call(peek, _F, []) -> {reply, empty, []}; + handle_call(peek, _F, [H | T]) -> {reply, {ok, H}, [H | T]}; + handle_call(size, _F, S) -> {reply, length(S), S}. + handle_cast({push, V}, S) -> {noreply, [V | S]}. + handle_info(_M, S) -> {noreply, S}.") + nil) + +(er-eval-test "stack push/pop" + (ev "P = gen_server:start_link(stk, ignored), gen_server:cast(P, {push, 1}), gen_server:cast(P, {push, 2}), gen_server:cast(P, {push, 3}), gen_server:call(P, size)") + 3) + +(er-eval-test "stack lifo" + (ev "P = gen_server:start_link(stk, ignored), gen_server:cast(P, {push, 1}), gen_server:cast(P, {push, 2}), gen_server:cast(P, {push, 3}), {ok, V} = gen_server:call(P, pop), V") + 3) + +(er-eval-test "stack empty pop" + (nm (ev "P = gen_server:start_link(stk, ignored), gen_server:call(P, pop)")) + "empty") + +;; ── supervisor (one-for-one) ──────────────────────────────────── +(do + (er-load-supervisor!) + (erlang-load-module + "-module(echoer). + start() -> spawn(fun () -> echoer:loop() end). + loop() -> + receive + {ping, From} -> From ! pong, echoer:loop(); + die -> exit(killed) + end.") + nil) + +(er-eval-test "sup starts children" + (do + (erlang-load-module + "-module(sup1). init(_) -> {ok, [{w1, fun () -> echoer:start() end}]}.") + (ev "Sup = supervisor:start_link(sup1, []), receive after 5 -> ok end, length(supervisor:which_children(Sup))")) + 1) + +(er-eval-test "sup multiple children" + (do + (erlang-load-module + "-module(sup2). + init(_) -> {ok, [ + {w1, fun () -> echoer:start() end}, + {w2, fun () -> echoer:start() end}, + {w3, fun () -> echoer:start() end} + ]}.") + (ev "Sup = supervisor:start_link(sup2, []), receive after 5 -> ok end, length(supervisor:which_children(Sup))")) + 3) + +(er-eval-test "sup child responds" + (do + (erlang-load-module + "-module(sup3). init(_) -> {ok, [{w1, fun () -> echoer:start() end}]}.") + (nm (ev "Sup = supervisor:start_link(sup3, []), receive after 5 -> ok end, [{_, _, P1} | _] = supervisor:which_children(Sup), P1 ! {ping, self()}, receive pong -> ok end"))) + "ok") + +(er-eval-test "sup restarts on exit" + (do + (erlang-load-module + "-module(sup4). init(_) -> {ok, [{w1, fun () -> echoer:start() end}]}.") + (nm + (ev "Sup = supervisor:start_link(sup4, []), receive after 5 -> ok end, [{_, _, P1} | _] = supervisor:which_children(Sup), P1 ! die, receive after 5 -> ok end, [{_, _, P2} | _] = supervisor:which_children(Sup), P1 =/= P2"))) + "true") + +(er-eval-test "sup restarted child works" + (do + (erlang-load-module + "-module(sup5). init(_) -> {ok, [{w1, fun () -> echoer:start() end}]}.") + (nm + (ev "Sup = supervisor:start_link(sup5, []), receive after 5 -> ok end, [{_, _, P1} | _] = supervisor:which_children(Sup), P1 ! die, receive after 5 -> ok end, [{_, _, P2} | _] = supervisor:which_children(Sup), P2 ! {ping, self()}, receive pong -> ok end"))) + "ok") + +(er-eval-test "sup one-for-one isolates failures" + (do + (erlang-load-module + "-module(sup6). + init(_) -> {ok, [ + {w1, fun () -> echoer:start() end}, + {w2, fun () -> echoer:start() end} + ]}.") + (nm + (ev "Sup = supervisor:start_link(sup6, []), receive after 5 -> ok end, [{_, _, P1}, {_, _, P2}] = supervisor:which_children(Sup), P1 ! die, receive after 5 -> ok end, [{_, _, _NewP1}, {_, _, P2Again}] = supervisor:which_children(Sup), P2 =:= P2Again"))) + "true") + +(er-eval-test "sup stop" + (nm + (do + (erlang-load-module + "-module(sup7). init(_) -> {ok, [{w1, fun () -> echoer:start() end}]}.") + (ev "Sup = supervisor:start_link(sup7, []), receive after 5 -> ok end, supervisor:stop(Sup)"))) + "ok") + +;; ── register / whereis / registered ───────────────────────────── +(er-eval-test "register returns true" + (nm (ev "register(me, self())")) "true") + +(er-eval-test "whereis registered self" + (nm (ev "register(me, self()), Pid = whereis(me), if Pid =:= self() -> matched; true -> nope end")) + "matched") + +(er-eval-test "whereis undefined" + (nm (ev "whereis(no_such)")) "undefined") + +(er-eval-test "send via registered atom" + (nm (ev "register(srv, self()), srv ! hello, receive M -> M end")) + "hello") + +(er-eval-test "send to spawned registered" + (nm + (ev "Me = self(), P = spawn(fun () -> receive {From, X} -> From ! {got, X} end end), register(child, P), child ! {Me, payload}, receive {got, V} -> V end")) + "payload") + +(er-eval-test "unregister returns true" + (nm (ev "register(a, self()), unregister(a)")) "true") + +(er-eval-test "unregister then whereis" + (nm (ev "register(a, self()), unregister(a), whereis(a)")) + "undefined") + +(er-eval-test "registered/0 lists names" + (ev "register(a, self()), register(b, self()), register(c, self()), length(registered())") + 3) + +(er-eval-test "register dup raises" + (do + (ev "P = spawn(fun () -> register(d, self()), register(d, self()) end), receive after 0 -> ok end") + (let ((reason (er-proc-field (er-mk-pid 1) :exit-reason))) + (nm (if (er-atom? reason) reason (nth (get reason :elements) 0))))) + "badarg") + +(er-eval-test "unregister missing raises" + (do + (ev "P = spawn(fun () -> unregister(no_such) end), receive after 0 -> ok end") + (let ((reason (er-proc-field (er-mk-pid 1) :exit-reason))) + (nm (if (er-atom? reason) reason (nth (get reason :elements) 0))))) + "badarg") + +(er-eval-test "dead process auto-unregisters" + ;; Register a child while it's alive (still in receive). Send `die` so + ;; it exits. After scheduler drains, whereis should return undefined. + (nm + (ev "P = spawn(fun () -> receive die -> exit(killed) end end), register(was_alive, P), P ! die, receive after 5 -> ok end, whereis(was_alive)")) + "undefined") + +(er-eval-test "send to unregistered name raises" + (do + (ev "P = spawn(fun () -> no_such ! oops end), receive after 0 -> ok end") + (let ((reason (er-proc-field (er-mk-pid 1) :exit-reason))) + (nm (if (er-atom? reason) reason (nth (get reason :elements) 0))))) + "badarg") + +;; ── list comprehensions ─────────────────────────────────────── +(er-eval-test "lc map double" + (ev "hd([X * 2 || X <- [1, 2, 3]])") 2) +(er-eval-test "lc map sum" + (ev "lists:foldl(fun (X, Acc) -> X + Acc end, 0, [X * 2 || X <- [1, 2, 3]])") + 12) +(er-eval-test "lc length" + (ev "length([X || X <- [1, 2, 3, 4, 5]])") 5) +(er-eval-test "lc filter sum" + (ev "lists:foldl(fun (X, Acc) -> X + Acc end, 0, [X || X <- [1, 2, 3, 4, 5], X rem 2 =:= 0])") + 6) +(er-eval-test "lc filter only" + (ev "length([X || X <- [1, 2, 3, 4, 5, 6, 7, 8, 9, 10], X > 5])") + 5) +(er-eval-test "lc empty source" + (get (ev "[X || X <- []]") :tag) "nil") +(er-eval-test "lc all filtered" + (get (ev "[X || X <- [1, 2, 3], X > 100]") :tag) "nil") +(er-eval-test "lc cartesian length" + (ev "length([{X, Y} || X <- [1, 2, 3], Y <- [a, b]])") + 6) +(er-eval-test "lc pattern match" + (ev "lists:foldl(fun (X, Acc) -> X + Acc end, 0, [V || {ok, V} <- [{ok, 1}, {error, x}, {ok, 2}, {ok, 3}]])") + 6) +(er-eval-test "lc nested generators" + (ev "length([{X, Y} || X <- [1, 2, 3], Y <- [10, 20, 30], X + Y > 12])") + 7) +(er-eval-test "lc squares" + (ev "lists:foldl(fun (X, Acc) -> X + Acc end, 0, [X*X || X <- [1, 2, 3, 4, 5]])") + 55) +;; First {ok, X} tuple: head of [{ok,a}, {ok,b}] is {ok, a}. +(er-eval-test "lc tuple capture" + (nm (nth (get (get (ev "[{ok, X} || X <- [a, b]]") :head) :elements) 0)) + "ok") + +;; ── binary literals / patterns ──────────────────────────────── +(er-eval-test "binary tag" + (get (ev "<<>>") :tag) "binary") +(er-eval-test "is_binary empty" (nm (ev "is_binary(<<>>)")) "true") +(er-eval-test "is_binary 3 bytes" + (nm (ev "is_binary(<<1, 2, 3>>)")) "true") +(er-eval-test "is_binary list" (nm (ev "is_binary([1, 2])")) "false") +(er-eval-test "byte_size 0" (ev "byte_size(<<>>)") 0) +(er-eval-test "byte_size 3" (ev "byte_size(<<1, 2, 3>>)") 3) +(er-eval-test "byte_size 16-bit" (ev "byte_size(<<256:16>>)") 2) +(er-eval-test "byte_size 32-bit" (ev "byte_size(<<999999:32>>)") 4) + +;; Match +(er-eval-test "match single byte" + (ev "<> = <<7>>, X") 7) +(er-eval-test "match X:8" + (ev "<> = <<200>>, X") 200) +(er-eval-test "match 16-bit decode" + (ev "<> = <<1, 0>>, X") 256) +(er-eval-test "match 16-bit hi byte" + (ev "<> = <<2, 1>>, X") 513) +(er-eval-test "match A:8 B:16" + (ev "<> = <<1, 0, 2>>, A + B") 3) +(er-eval-test "match three 8-bit" + (ev "<> = <<1, 2, 3>>, A + B + C") 6) + +;; Tail binary +(er-eval-test "tail rest size" + (ev "<<_:8, Rest/binary>> = <<1, 2, 3, 4>>, byte_size(Rest)") 3) +(er-eval-test "tail rest content" + (ev "<<_:8, Rest/binary>> = <<1, 2, 3, 4>>, <> = Rest, X") 2) + +;; Match failure +(er-eval-test "size mismatch fails" + (do + (ev "P = spawn(fun () -> <> = <<1>>, ok end), receive after 0 -> ok end") + (let ((reason (er-proc-field (er-mk-pid 1) :exit-reason))) + (cond + (er-tuple? reason) (nm (nth (get reason :elements) 0)) + (er-atom? reason) (get reason :name) + :else nil))) + "badmatch") + +;; Equality +(er-eval-test "binary =:= self" + (nm (ev "B = <<1, 2, 3>>, B =:= B")) "true") +(er-eval-test "binary =:= same" + (nm (ev "<<1, 2>> =:= <<1, 2>>")) "true") +(er-eval-test "binary =/= different" + (nm (ev "<<1, 2>> =:= <<1, 3>>")) "false") + +;; Construction with computed value +(er-eval-test "build with var" + (ev "X = 42, byte_size(<>)") 1) +(er-eval-test "build with size var" + (ev "X = 7, byte_size(<>)") 2) + +;; ── ETS-lite ────────────────────────────────────────────────── +(er-eval-test "ets:new returns name" + (nm (ev "ets:new(t1, [set])")) "t1") +(er-eval-test "ets:insert returns true" + (nm (ev "T = ets:new(t2, [set]), ets:insert(T, {foo, 1})")) "true") +(er-eval-test "ets:lookup hit" + (ev "T = ets:new(t3, [set]), ets:insert(T, {foo, 42}), [{foo, V}] = ets:lookup(T, foo), V") + 42) +(er-eval-test "ets:lookup miss returns []" + (get (ev "T = ets:new(t4, [set]), ets:lookup(T, no_such)") :tag) "nil") +(er-eval-test "ets:insert replaces (set semantics)" + (ev "T = ets:new(t5, [set]), ets:insert(T, {x, 1}), ets:insert(T, {x, 2}), ets:insert(T, {x, 3}), [{x, V}] = ets:lookup(T, x), V") + 3) +(er-eval-test "ets:info size grows" + (ev "T = ets:new(t6, [set]), ets:insert(T, {a, 1}), ets:insert(T, {b, 2}), ets:insert(T, {c, 3}), ets:info(T, size)") + 3) +(er-eval-test "ets:info size after delete" + (ev "T = ets:new(t7, [set]), ets:insert(T, {a, 1}), ets:insert(T, {b, 2}), ets:delete(T, a), ets:info(T, size)") + 1) +(er-eval-test "ets:tab2list length" + (ev "T = ets:new(t8, [set]), ets:insert(T, {a, 1}), ets:insert(T, {b, 2}), ets:insert(T, {c, 3}), length(ets:tab2list(T))") + 3) +(er-eval-test "ets:delete table returns true" + (nm (ev "T = ets:new(t9, [set]), ets:delete(T)")) "true") +(er-eval-test "ets:lookup after table delete" + (do + (ev "P = spawn(fun () -> T = ets:new(t10, [set]), ets:delete(T), ets:lookup(T, x) end), receive after 0 -> ok end") + (let ((reason (er-proc-field (er-mk-pid 1) :exit-reason))) + (cond + (er-atom? reason) (get reason :name) + :else (nm reason)))) + "badarg") + +;; Sum a column via lookup chain. +(er-eval-test "ets aggregate" + (ev "T = ets:new(t11, [set]), ets:insert(T, {a, 10}), ets:insert(T, {b, 20}), ets:insert(T, {c, 30}), [{a, A}] = ets:lookup(T, a), [{b, B}] = ets:lookup(T, b), [{c, C}] = ets:lookup(T, c), A + B + C") + 60) + +;; Tuple key (non-atom). +(er-eval-test "ets tuple key" + (nm + (ev "T = ets:new(t12, [set]), ets:insert(T, {{x, 1}, hello}), [{{x, 1}, V}] = ets:lookup(T, {x, 1}), V")) + "hello") + +;; Tables are independent. +(er-eval-test "ets two tables independent" + (ev "T1 = ets:new(t13, [set]), T2 = ets:new(t14, [set]), ets:insert(T1, {x, 1}), ets:insert(T2, {x, 99}), [{x, A}] = ets:lookup(T1, x), [{x, B}] = ets:lookup(T2, x), A + B") + 100) + +;; ── more BIFs ───────────────────────────────────────────────── +(er-eval-test "abs neg" (ev "abs(-7)") 7) +(er-eval-test "abs pos" (ev "abs(42)") 42) +(er-eval-test "abs zero" (ev "abs(0)") 0) + +(er-eval-test "min" (ev "min(3, 5)") 3) +(er-eval-test "min equal" (ev "min(7, 7)") 7) +(er-eval-test "max" (ev "max(3, 5)") 5) +(er-eval-test "max neg" (ev "max(-10, -2)") -2) + +(er-eval-test "tuple_to_list head" + (nm (ev "hd(tuple_to_list({a, b, c}))")) "a") +(er-eval-test "tuple_to_list len" + (ev "length(tuple_to_list({1, 2, 3, 4, 5}))") 5) +(er-eval-test "list_to_tuple roundtrip" + (ev "tuple_size(list_to_tuple([10, 20, 30]))") 3) + +(er-eval-test "integer_to_list" (ev "integer_to_list(42)") "42") +(er-eval-test "integer_to_list neg" (ev "integer_to_list(-99)") "-99") +(er-eval-test "list_to_integer" (ev "list_to_integer(\"123\")") 123) +(er-eval-test "list_to_integer roundtrip" + (ev "list_to_integer(integer_to_list(7))") 7) + +(er-eval-test "is_function fun" + (nm (ev "F = fun (X) -> X end, is_function(F)")) "true") +(er-eval-test "is_function not" + (nm (ev "is_function(42)")) "false") +(er-eval-test "is_function arity match" + (nm (ev "F = fun (X, Y) -> X + Y end, is_function(F, 2)")) "true") +(er-eval-test "is_function arity mismatch" + (nm (ev "F = fun (X) -> X end, is_function(F, 5)")) "false") + +;; lists module +(er-eval-test "lists:seq 1..5" + (ev "length(lists:seq(1, 5))") 5) +(er-eval-test "lists:seq head" + (ev "hd(lists:seq(10, 20))") 10) +(er-eval-test "lists:seq sum" + (ev "lists:sum(lists:seq(1, 100))") 5050) +(er-eval-test "lists:seq with step" + (ev "length(lists:seq(0, 20, 2))") 11) +(er-eval-test "lists:seq empty" + (get (ev "lists:seq(5, 1)") :tag) "nil") + +(er-eval-test "lists:sum empty" (ev "lists:sum([])") 0) +(er-eval-test "lists:sum 5" + (ev "lists:sum([1, 2, 3, 4, 5])") 15) + +(er-eval-test "lists:nth 1" (ev "lists:nth(1, [10, 20, 30])") 10) +(er-eval-test "lists:nth mid" + (nm (ev "lists:nth(2, [a, b, c])")) "b") +(er-eval-test "lists:last" + (nm (ev "lists:last([a, b, c, d])")) "d") +(er-eval-test "lists:last single" (ev "lists:last([42])") 42) + +(er-eval-test "lists:member yes" + (nm (ev "lists:member(3, [1, 2, 3, 4])")) "true") +(er-eval-test "lists:member no" + (nm (ev "lists:member(99, [1, 2, 3])")) "false") + +(er-eval-test "lists:append" + (ev "length(lists:append([1, 2], [3, 4, 5]))") 5) + +(er-eval-test "lists:filter" + (ev "length(lists:filter(fun (X) -> X > 2 end, [1, 2, 3, 4, 5]))") 3) +(er-eval-test "lists:filter sum" + (ev "lists:sum(lists:filter(fun (X) -> X rem 2 =:= 0 end, lists:seq(1, 20)))") 110) + +(er-eval-test "lists:any false" + (nm (ev "lists:any(fun (X) -> X > 100 end, [1, 2, 3])")) "false") +(er-eval-test "lists:any true" + (nm (ev "lists:any(fun (X) -> X > 2 end, [1, 2, 3])")) "true") +(er-eval-test "lists:all true" + (nm (ev "lists:all(fun (X) -> X > 0 end, [1, 2, 3])")) "true") +(er-eval-test "lists:all false" + (nm (ev "lists:all(fun (X) -> X > 1 end, [1, 2, 3])")) "false") + +(er-eval-test "lists:duplicate len" + (ev "length(lists:duplicate(5, foo))") 5) +(er-eval-test "lists:duplicate val" + (nm (ev "hd(lists:duplicate(3, marker))")) "marker") + +(define + er-eval-test-summary + (str "eval " er-eval-test-pass "/" er-eval-test-count)) diff --git a/lib/erlang/tests/programs/bank.sx b/lib/erlang/tests/programs/bank.sx new file mode 100644 index 00000000..a86b1f6d --- /dev/null +++ b/lib/erlang/tests/programs/bank.sx @@ -0,0 +1,159 @@ +;; Bank account server — stateful process, balance threaded through +;; recursive loop. Handles {deposit, Amt, From}, {withdraw, Amt, From}, +;; {balance, From}, stop. Tests stateful process patterns. + +(define er-bank-test-count 0) +(define er-bank-test-pass 0) +(define er-bank-test-fails (list)) + +(define + er-bank-test + (fn + (name actual expected) + (set! er-bank-test-count (+ er-bank-test-count 1)) + (if + (= actual expected) + (set! er-bank-test-pass (+ er-bank-test-pass 1)) + (append! er-bank-test-fails {:actual actual :expected expected :name name})))) + +(define bank-ev erlang-eval-ast) + +;; Server fun shared by all tests — threaded via the program string. +(define + er-bank-server-src + "Server = fun (Balance) -> + receive + {deposit, Amt, From} -> From ! ok, Server(Balance + Amt); + {withdraw, Amt, From} -> + if Amt > Balance -> From ! insufficient, Server(Balance); + true -> From ! ok, Server(Balance - Amt) + end; + {balance, From} -> From ! Balance, Server(Balance); + stop -> ok + end + end") + +;; Open account, deposit, check balance. +(er-bank-test + "deposit 100 -> balance 100" + (bank-ev + (str + er-bank-server-src + ", Me = self(), + Bank = spawn(fun () -> Server(0) end), + Bank ! {deposit, 100, Me}, + receive ok -> ok end, + Bank ! {balance, Me}, + receive B -> Bank ! stop, B end")) + 100) + +;; Multiple deposits accumulate. +(er-bank-test + "deposits accumulate" + (bank-ev + (str + er-bank-server-src + ", Me = self(), + Bank = spawn(fun () -> Server(0) end), + Bank ! {deposit, 50, Me}, receive ok -> ok end, + Bank ! {deposit, 25, Me}, receive ok -> ok end, + Bank ! {deposit, 10, Me}, receive ok -> ok end, + Bank ! {balance, Me}, + receive B -> Bank ! stop, B end")) + 85) + +;; Withdraw within balance succeeds; insufficient gets rejected. +(er-bank-test + "withdraw within balance" + (bank-ev + (str + er-bank-server-src + ", Me = self(), + Bank = spawn(fun () -> Server(100) end), + Bank ! {withdraw, 30, Me}, receive ok -> ok end, + Bank ! {balance, Me}, + receive B -> Bank ! stop, B end")) + 70) + +(er-bank-test + "withdraw insufficient" + (get + (bank-ev + (str + er-bank-server-src + ", Me = self(), + Bank = spawn(fun () -> Server(20) end), + Bank ! {withdraw, 100, Me}, + receive R -> Bank ! stop, R end")) + :name) + "insufficient") + +;; State preserved across an insufficient withdrawal. +(er-bank-test + "state preserved on rejection" + (bank-ev + (str + er-bank-server-src + ", Me = self(), + Bank = spawn(fun () -> Server(50) end), + Bank ! {withdraw, 1000, Me}, receive _ -> ok end, + Bank ! {balance, Me}, + receive B -> Bank ! stop, B end")) + 50) + +;; Mixed deposits and withdrawals. +(er-bank-test + "mixed transactions" + (bank-ev + (str + er-bank-server-src + ", Me = self(), + Bank = spawn(fun () -> Server(100) end), + Bank ! {deposit, 50, Me}, receive ok -> ok end, + Bank ! {withdraw, 30, Me}, receive ok -> ok end, + Bank ! {deposit, 10, Me}, receive ok -> ok end, + Bank ! {withdraw, 5, Me}, receive ok -> ok end, + Bank ! {balance, Me}, + receive B -> Bank ! stop, B end")) + 125) + +;; Server.stop terminates the bank cleanly — main can verify by +;; sending stop and then exiting normally. +(er-bank-test + "server stops cleanly" + (get + (bank-ev + (str + er-bank-server-src + ", Me = self(), + Bank = spawn(fun () -> Server(0) end), + Bank ! stop, + done")) + :name) + "done") + +;; Two clients sharing one bank — interleaved transactions. +(er-bank-test + "two clients share bank" + (bank-ev + (str + er-bank-server-src + ", Me = self(), + Bank = spawn(fun () -> Server(0) end), + Client = fun (Amt) -> + spawn(fun () -> + Bank ! {deposit, Amt, self()}, + receive ok -> Me ! deposited end + end) + end, + Client(40), + Client(60), + receive deposited -> ok end, + receive deposited -> ok end, + Bank ! {balance, Me}, + receive B -> Bank ! stop, B end")) + 100) + +(define + er-bank-test-summary + (str "bank " er-bank-test-pass "/" er-bank-test-count)) diff --git a/lib/erlang/tests/programs/echo.sx b/lib/erlang/tests/programs/echo.sx new file mode 100644 index 00000000..d8afb71e --- /dev/null +++ b/lib/erlang/tests/programs/echo.sx @@ -0,0 +1,140 @@ +;; Echo server — minimal classic Erlang server. Receives {From, Msg} +;; and sends Msg back to From, then loops. `stop` ends the server. + +(define er-echo-test-count 0) +(define er-echo-test-pass 0) +(define er-echo-test-fails (list)) + +(define + er-echo-test + (fn + (name actual expected) + (set! er-echo-test-count (+ er-echo-test-count 1)) + (if + (= actual expected) + (set! er-echo-test-pass (+ er-echo-test-pass 1)) + (append! er-echo-test-fails {:actual actual :expected expected :name name})))) + +(define echo-ev erlang-eval-ast) + +(define + er-echo-server-src + "EchoSrv = fun () -> + Loop = fun () -> + receive + {From, Msg} -> From ! Msg, Loop(); + stop -> ok + end + end, + Loop() + end") + +;; Single round-trip with an atom. +(er-echo-test + "atom round-trip" + (get + (echo-ev + (str + er-echo-server-src + ", Me = self(), + Echo = spawn(EchoSrv), + Echo ! {Me, hello}, + receive R -> Echo ! stop, R end")) + :name) + "hello") + +;; Number round-trip. +(er-echo-test + "number round-trip" + (echo-ev + (str + er-echo-server-src + ", Me = self(), + Echo = spawn(EchoSrv), + Echo ! {Me, 42}, + receive R -> Echo ! stop, R end")) + 42) + +;; Tuple round-trip — pattern-match the reply to extract V. +(er-echo-test + "tuple round-trip" + (echo-ev + (str + er-echo-server-src + ", Me = self(), + Echo = spawn(EchoSrv), + Echo ! {Me, {ok, 7}}, + receive {ok, V} -> Echo ! stop, V end")) + 7) + +;; List round-trip. +(er-echo-test + "list round-trip" + (echo-ev + (str + er-echo-server-src + ", Me = self(), + Echo = spawn(EchoSrv), + Echo ! {Me, [1, 2, 3]}, + receive [H | _] -> Echo ! stop, H end")) + 1) + +;; Multiple sequential round-trips. +(er-echo-test + "three round-trips" + (echo-ev + (str + er-echo-server-src + ", Me = self(), + Echo = spawn(EchoSrv), + Echo ! {Me, 10}, A = receive Ra -> Ra end, + Echo ! {Me, 20}, B = receive Rb -> Rb end, + Echo ! {Me, 30}, C = receive Rc -> Rc end, + Echo ! stop, + A + B + C")) + 60) + +;; Two clients sharing one echo server. Each gets its own reply. +(er-echo-test + "two clients" + (get + (echo-ev + (str + er-echo-server-src + ", Me = self(), + Echo = spawn(EchoSrv), + Client = fun (Tag) -> + spawn(fun () -> + Echo ! {self(), Tag}, + receive R -> Me ! {got, R} end + end) + end, + Client(a), + Client(b), + receive {got, _} -> ok end, + receive {got, _} -> ok end, + Echo ! stop, + finished")) + :name) + "finished") + +;; Echo via io trace — verify each message round-trips through. +(er-echo-test + "trace 4 messages" + (do + (er-io-flush!) + (echo-ev + (str + er-echo-server-src + ", Me = self(), + Echo = spawn(EchoSrv), + Send = fun (V) -> Echo ! {Me, V}, receive R -> io:format(\"~p \", [R]) end end, + Send(1), Send(2), Send(3), Send(4), + Echo ! stop, + done")) + (er-io-buffer-content)) + "1 2 3 4 ") + +(define + er-echo-test-summary + (str "echo " er-echo-test-pass "/" er-echo-test-count)) diff --git a/lib/erlang/tests/programs/fib_server.sx b/lib/erlang/tests/programs/fib_server.sx new file mode 100644 index 00000000..4d97e912 --- /dev/null +++ b/lib/erlang/tests/programs/fib_server.sx @@ -0,0 +1,152 @@ +;; Fib server — long-lived process that computes fibonacci numbers on +;; request. Tests recursive function evaluation inside a server loop. + +(define er-fib-test-count 0) +(define er-fib-test-pass 0) +(define er-fib-test-fails (list)) + +(define + er-fib-test + (fn + (name actual expected) + (set! er-fib-test-count (+ er-fib-test-count 1)) + (if + (= actual expected) + (set! er-fib-test-pass (+ er-fib-test-pass 1)) + (append! er-fib-test-fails {:actual actual :expected expected :name name})))) + +(define fib-ev erlang-eval-ast) + +;; Fib + server-loop source. Standalone so each test can chain queries. +(define + er-fib-server-src + "Fib = fun (0) -> 0; (1) -> 1; (N) -> Fib(N-1) + Fib(N-2) end, + FibSrv = fun () -> + Loop = fun () -> + receive + {fib, N, From} -> From ! Fib(N), Loop(); + stop -> ok + end + end, + Loop() + end") + +;; Base cases. +(er-fib-test + "fib(0)" + (fib-ev + (str + er-fib-server-src + ", Me = self(), + Srv = spawn(FibSrv), + Srv ! {fib, 0, Me}, + receive R -> Srv ! stop, R end")) + 0) + +(er-fib-test + "fib(1)" + (fib-ev + (str + er-fib-server-src + ", Me = self(), + Srv = spawn(FibSrv), + Srv ! {fib, 1, Me}, + receive R -> Srv ! stop, R end")) + 1) + +;; Larger values. +(er-fib-test + "fib(10) = 55" + (fib-ev + (str + er-fib-server-src + ", Me = self(), + Srv = spawn(FibSrv), + Srv ! {fib, 10, Me}, + receive R -> Srv ! stop, R end")) + 55) + +(er-fib-test + "fib(15) = 610" + (fib-ev + (str + er-fib-server-src + ", Me = self(), + Srv = spawn(FibSrv), + Srv ! {fib, 15, Me}, + receive R -> Srv ! stop, R end")) + 610) + +;; Multiple sequential queries to one server. Sum to avoid dict-equality. +(er-fib-test + "sequential fib(5..8) sum" + (fib-ev + (str + er-fib-server-src + ", Me = self(), + Srv = spawn(FibSrv), + Srv ! {fib, 5, Me}, A = receive Ra -> Ra end, + Srv ! {fib, 6, Me}, B = receive Rb -> Rb end, + Srv ! {fib, 7, Me}, C = receive Rc -> Rc end, + Srv ! {fib, 8, Me}, D = receive Rd -> Rd end, + Srv ! stop, + A + B + C + D")) + 47) + +;; Verify Fib obeys the recurrence — fib(n) = fib(n-1) + fib(n-2). +(er-fib-test + "fib recurrence at n=12" + (fib-ev + (str + er-fib-server-src + ", Me = self(), + Srv = spawn(FibSrv), + Srv ! {fib, 10, Me}, A = receive Ra -> Ra end, + Srv ! {fib, 11, Me}, B = receive Rb -> Rb end, + Srv ! {fib, 12, Me}, C = receive Rc -> Rc end, + Srv ! stop, + C - (A + B)")) + 0) + +;; Two clients each get their own answer; main sums the results. +(er-fib-test + "two clients sum" + (fib-ev + (str + er-fib-server-src + ", Me = self(), + Srv = spawn(FibSrv), + Client = fun (N) -> + spawn(fun () -> + Srv ! {fib, N, self()}, + receive R -> Me ! {result, R} end + end) + end, + Client(7), + Client(9), + {result, A} = receive M1 -> M1 end, + {result, B} = receive M2 -> M2 end, + Srv ! stop, + A + B")) + 47) + +;; Trace queries via io-buffer. +(er-fib-test + "trace fib 0..6" + (do + (er-io-flush!) + (fib-ev + (str + er-fib-server-src + ", Me = self(), + Srv = spawn(FibSrv), + Ask = fun (N) -> Srv ! {fib, N, Me}, receive R -> io:format(\"~p \", [R]) end end, + Ask(0), Ask(1), Ask(2), Ask(3), Ask(4), Ask(5), Ask(6), + Srv ! stop, + done")) + (er-io-buffer-content)) + "0 1 1 2 3 5 8 ") + +(define + er-fib-test-summary + (str "fib " er-fib-test-pass "/" er-fib-test-count)) diff --git a/lib/erlang/tests/programs/ping_pong.sx b/lib/erlang/tests/programs/ping_pong.sx new file mode 100644 index 00000000..02b0283d --- /dev/null +++ b/lib/erlang/tests/programs/ping_pong.sx @@ -0,0 +1,127 @@ +;; Ping-pong program — two processes exchange N messages, then signal +;; main via separate `ping_done` / `pong_done` notifications. + +(define er-pp-test-count 0) +(define er-pp-test-pass 0) +(define er-pp-test-fails (list)) + +(define + er-pp-test + (fn + (name actual expected) + (set! er-pp-test-count (+ er-pp-test-count 1)) + (if + (= actual expected) + (set! er-pp-test-pass (+ er-pp-test-pass 1)) + (append! er-pp-test-fails {:actual actual :expected expected :name name})))) + +(define pp-ev erlang-eval-ast) + +;; Three rounds of ping-pong, then stop. Main receives ping_done and +;; pong_done in arrival order (Ping finishes first because Pong exits +;; only after receiving stop). +(define + er-pp-program + "Me = self(), + Pong = spawn(fun () -> + Loop = fun () -> + receive + {ping, From} -> From ! pong, Loop(); + stop -> Me ! pong_done + end + end, + Loop() + end), + Ping = fun (Target, K) -> + if K =:= 0 -> Target ! stop, Me ! ping_done; + true -> Target ! {ping, self()}, receive pong -> Ping(Target, K - 1) end + end + end, + spawn(fun () -> Ping(Pong, 3) end), + receive ping_done -> ok end, + receive pong_done -> both_done end") + +(er-pp-test + "ping-pong 3 rounds" + (get (pp-ev er-pp-program) :name) + "both_done") + +;; Count exchanges via io-buffer — each pong trip prints "p". +(er-pp-test + "ping-pong 5 rounds trace" + (do + (er-io-flush!) + (pp-ev + "Me = self(), + Pong = spawn(fun () -> + Loop = fun () -> + receive + {ping, From} -> io:format(\"p\"), From ! pong, Loop(); + stop -> Me ! pong_done + end + end, + Loop() + end), + Ping = fun (Target, K) -> + if K =:= 0 -> Target ! stop, Me ! ping_done; + true -> Target ! {ping, self()}, receive pong -> Ping(Target, K - 1) end + end + end, + spawn(fun () -> Ping(Pong, 5) end), + receive ping_done -> ok end, + receive pong_done -> ok end") + (er-io-buffer-content)) + "ppppp") + +;; Main → Pong directly (no Ping process). Main plays the ping role. +(er-pp-test + "main-as-pinger 4 rounds" + (pp-ev + "Me = self(), + Pong = spawn(fun () -> + Loop = fun () -> + receive + {ping, From} -> From ! pong, Loop(); + stop -> ok + end + end, + Loop() + end), + Go = fun (K) -> + if K =:= 0 -> Pong ! stop, K; + true -> Pong ! {ping, Me}, receive pong -> Go(K - 1) end + end + end, + Go(4)") + 0) + +;; Ensure the processes really interleave — inject an id into each +;; ping and check we get them all back via trace (the order is +;; deterministic under our sync scheduler). +(er-pp-test + "ids round-trip" + (do + (er-io-flush!) + (pp-ev + "Me = self(), + Pong = spawn(fun () -> + Loop = fun () -> + receive + {ping, From, Id} -> From ! {pong, Id}, Loop(); + stop -> ok + end + end, + Loop() + end), + Go = fun (K) -> + if K =:= 0 -> Pong ! stop, done; + true -> Pong ! {ping, Me, K}, receive {pong, RId} -> io:format(\"~p \", [RId]), Go(K - 1) end + end + end, + Go(4)") + (er-io-buffer-content)) + "4 3 2 1 ") + +(define + er-pp-test-summary + (str "ping-pong " er-pp-test-pass "/" er-pp-test-count)) diff --git a/lib/erlang/tests/programs/ring.sx b/lib/erlang/tests/programs/ring.sx new file mode 100644 index 00000000..2ef1f1cd --- /dev/null +++ b/lib/erlang/tests/programs/ring.sx @@ -0,0 +1,132 @@ +;; Ring program — N processes in a ring, token passes M times. +;; +;; Each process waits for {setup, Next} so main can tie the knot +;; (can't reference a pid before spawning it). Once wired, main +;; injects the first token; each process forwards decrementing K +;; until it hits 0, at which point it signals `done` to main. + +(define er-ring-test-count 0) +(define er-ring-test-pass 0) +(define er-ring-test-fails (list)) + +(define + er-ring-test + (fn + (name actual expected) + (set! er-ring-test-count (+ er-ring-test-count 1)) + (if + (= actual expected) + (set! er-ring-test-pass (+ er-ring-test-pass 1)) + (append! er-ring-test-fails {:actual actual :expected expected :name name})))) + +(define ring-ev erlang-eval-ast) + +(define + er-ring-program-3-6 + "Me = self(), + Spawner = fun () -> + receive {setup, Next} -> + Loop = fun () -> + receive + {token, 0, Parent} -> Parent ! done; + {token, K, Parent} -> Next ! {token, K-1, Parent}, Loop() + end + end, + Loop() + end + end, + P1 = spawn(Spawner), + P2 = spawn(Spawner), + P3 = spawn(Spawner), + P1 ! {setup, P2}, + P2 ! {setup, P3}, + P3 ! {setup, P1}, + P1 ! {token, 5, Me}, + receive done -> finished end") + +(er-ring-test + "ring N=3 M=6" + (get (ring-ev er-ring-program-3-6) :name) + "finished") + +;; Two-node ring — token bounces twice between P1 and P2. +(er-ring-test + "ring N=2 M=4" + (get (ring-ev + "Me = self(), + Spawner = fun () -> + receive {setup, Next} -> + Loop = fun () -> + receive + {token, 0, Parent} -> Parent ! done; + {token, K, Parent} -> Next ! {token, K-1, Parent}, Loop() + end + end, + Loop() + end + end, + P1 = spawn(Spawner), + P2 = spawn(Spawner), + P1 ! {setup, P2}, + P2 ! {setup, P1}, + P1 ! {token, 3, Me}, + receive done -> done end") :name) + "done") + +;; Single-node "ring" — P sends to itself M times. +(er-ring-test + "ring N=1 M=5" + (get (ring-ev + "Me = self(), + Spawner = fun () -> + receive {setup, Next} -> + Loop = fun () -> + receive + {token, 0, Parent} -> Parent ! finished_loop; + {token, K, Parent} -> Next ! {token, K-1, Parent}, Loop() + end + end, + Loop() + end + end, + P = spawn(Spawner), + P ! {setup, P}, + P ! {token, 4, Me}, + receive finished_loop -> ok end") :name) + "ok") + +;; Confirm the token really went around — count hops via io-buffer. +(er-ring-test + "ring N=3 M=9 hop count" + (do + (er-io-flush!) + (ring-ev + "Me = self(), + Spawner = fun () -> + receive {setup, Next} -> + Loop = fun () -> + receive + {token, 0, Parent} -> Parent ! done; + {token, K, Parent} -> + io:format(\"~p \", [K]), + Next ! {token, K-1, Parent}, + Loop() + end + end, + Loop() + end + end, + P1 = spawn(Spawner), + P2 = spawn(Spawner), + P3 = spawn(Spawner), + P1 ! {setup, P2}, + P2 ! {setup, P3}, + P3 ! {setup, P1}, + P1 ! {token, 8, Me}, + receive done -> done end") + (er-io-buffer-content)) + "8 7 6 5 4 3 2 1 ") + +(define + er-ring-test-summary + (str "ring " er-ring-test-pass "/" er-ring-test-count)) diff --git a/lib/erlang/tests/runtime.sx b/lib/erlang/tests/runtime.sx new file mode 100644 index 00000000..95c20dce --- /dev/null +++ b/lib/erlang/tests/runtime.sx @@ -0,0 +1,139 @@ +;; Erlang runtime tests — scheduler + process-record primitives. + +(define er-rt-test-count 0) +(define er-rt-test-pass 0) +(define er-rt-test-fails (list)) + +(define + er-rt-test + (fn + (name actual expected) + (set! er-rt-test-count (+ er-rt-test-count 1)) + (if + (= actual expected) + (set! er-rt-test-pass (+ er-rt-test-pass 1)) + (append! er-rt-test-fails {:actual actual :expected expected :name name})))) + +;; ── queue ───────────────────────────────────────────────────────── +(er-rt-test "queue empty len" (er-q-len (er-q-new)) 0) +(er-rt-test "queue empty?" (er-q-empty? (er-q-new)) true) + +(define q1 (er-q-new)) +(er-q-push! q1 "a") +(er-q-push! q1 "b") +(er-q-push! q1 "c") +(er-rt-test "queue push len" (er-q-len q1) 3) +(er-rt-test "queue empty? after push" (er-q-empty? q1) false) +(er-rt-test "queue peek" (er-q-peek q1) "a") +(er-rt-test "queue pop 1" (er-q-pop! q1) "a") +(er-rt-test "queue pop 2" (er-q-pop! q1) "b") +(er-rt-test "queue len after pops" (er-q-len q1) 1) +(er-rt-test "queue pop 3" (er-q-pop! q1) "c") +(er-rt-test "queue empty again" (er-q-empty? q1) true) +(er-rt-test "queue pop empty" (er-q-pop! q1) nil) + +;; Queue FIFO under interleaved push/pop +(define q2 (er-q-new)) +(er-q-push! q2 1) +(er-q-push! q2 2) +(er-q-pop! q2) +(er-q-push! q2 3) +(er-rt-test "queue interleave peek" (er-q-peek q2) 2) +(er-rt-test "queue to-list" (er-q-to-list q2) (list 2 3)) + +;; ── scheduler init ───────────────────────────────────────────── +(er-sched-init!) +(er-rt-test "sched process count 0" (er-sched-process-count) 0) +(er-rt-test "sched runnable count 0" (er-sched-runnable-count) 0) +(er-rt-test "sched current nil" (er-sched-current-pid) nil) + +;; ── pid allocation ───────────────────────────────────────────── +(define pa (er-pid-new!)) +(define pb (er-pid-new!)) +(er-rt-test "pid tag" (get pa :tag) "pid") +(er-rt-test "pid ids distinct" (= (er-pid-id pa) (er-pid-id pb)) false) +(er-rt-test "pid? true" (er-pid? pa) true) +(er-rt-test "pid? false" (er-pid? 42) false) +(er-rt-test + "pid-equal same" + (er-pid-equal? pa (er-mk-pid (er-pid-id pa))) + true) +(er-rt-test "pid-equal diff" (er-pid-equal? pa pb) false) + +;; ── process lifecycle ────────────────────────────────────────── +(er-sched-init!) +(define p1 (er-proc-new! {})) +(define p2 (er-proc-new! {})) +(er-rt-test "proc count 2" (er-sched-process-count) 2) +(er-rt-test "runnable count 2" (er-sched-runnable-count) 2) +(er-rt-test + "proc state runnable" + (er-proc-field (get p1 :pid) :state) + "runnable") +(er-rt-test + "proc mailbox empty" + (er-proc-mailbox-size (get p1 :pid)) + 0) +(er-rt-test + "proc lookup" + (er-pid-equal? (get (er-proc-get (get p1 :pid)) :pid) (get p1 :pid)) + true) +(er-rt-test "proc exists" (er-proc-exists? (get p1 :pid)) true) +(er-rt-test + "proc no-such-pid" + (er-proc-exists? (er-mk-pid 9999)) + false) + +;; runnable queue dequeue order +(er-rt-test + "dequeue first" + (er-pid-equal? (er-sched-next-runnable!) (get p1 :pid)) + true) +(er-rt-test + "dequeue second" + (er-pid-equal? (er-sched-next-runnable!) (get p2 :pid)) + true) +(er-rt-test "dequeue empty" (er-sched-next-runnable!) nil) + +;; current-pid get/set +(er-sched-set-current! (get p1 :pid)) +(er-rt-test + "current pid set" + (er-pid-equal? (er-sched-current-pid) (get p1 :pid)) + true) + +;; ── mailbox push ────────────────────────────────────────────── +(er-proc-mailbox-push! (get p1 :pid) {:tag "atom" :name "ping"}) +(er-proc-mailbox-push! (get p1 :pid) 42) +(er-rt-test "mailbox size 2" (er-proc-mailbox-size (get p1 :pid)) 2) + +;; ── field update ────────────────────────────────────────────── +(er-proc-set! (get p1 :pid) :state "waiting") +(er-rt-test + "proc state waiting" + (er-proc-field (get p1 :pid) :state) + "waiting") +(er-proc-set! (get p1 :pid) :trap-exit true) +(er-rt-test + "proc trap-exit" + (er-proc-field (get p1 :pid) :trap-exit) + true) + +;; ── fresh scheduler ends in clean state ─────────────────────── +(er-sched-init!) +(er-rt-test + "sched init resets count" + (er-sched-process-count) + 0) +(er-rt-test + "sched init resets queue" + (er-sched-runnable-count) + 0) +(er-rt-test + "sched init resets current" + (er-sched-current-pid) + nil) + +(define + er-rt-test-summary + (str "runtime " er-rt-test-pass "/" er-rt-test-count)) diff --git a/lib/erlang/transpile.sx b/lib/erlang/transpile.sx new file mode 100644 index 00000000..ac2bf562 --- /dev/null +++ b/lib/erlang/transpile.sx @@ -0,0 +1,1913 @@ +;; Erlang sequential evaluator — tree-walking interpreter over the +;; parser AST. Phase 2 of plans/erlang-on-sx.md. +;; +;; Entry points: +;; (erlang-eval-ast SRC) -- parse body, eval, return last value +;; (er-eval-expr NODE ENV) -- evaluate one AST node +;; (er-eval-body NODES ENV) -- evaluate a comma-sequence, return last +;; +;; Runtime values: +;; integers / floats -> SX number +;; atoms -> {:tag "atom" :name } +;; booleans -> atoms 'true' / 'false' +;; strings -> SX string (char-list semantics deferred) +;; empty list -> {:tag "nil"} +;; cons cell -> {:tag "cons" :head V :tail V} +;; tuple -> {:tag "tuple" :elements (list V ...)} +;; +;; Environment: mutable dict from variable name (string) to value. + +;; ── value constructors / predicates ──────────────────────────────── +(define er-mk-atom (fn (name) {:name name :tag "atom"})) +(define er-atom-true (er-mk-atom "true")) +(define er-atom-false (er-mk-atom "false")) +(define er-mk-nil (fn () {:tag "nil"})) +(define er-mk-cons (fn (h t) {:tag "cons" :head h :tail t})) +(define er-mk-tuple (fn (elems) {:tag "tuple" :elements elems})) +(define er-mk-binary (fn (bytes) {:tag "binary" :bytes bytes})) +(define er-binary? (fn (v) (er-is-tagged? v "binary"))) +(define er-bool (fn (b) (if b er-atom-true er-atom-false))) + +(define + er-is-tagged? + (fn (v tag) (and (= (type-of v) "dict") (= (get v :tag) tag)))) +(define er-atom? (fn (v) (er-is-tagged? v "atom"))) +(define er-nil? (fn (v) (er-is-tagged? v "nil"))) +(define er-cons? (fn (v) (er-is-tagged? v "cons"))) +(define er-tuple? (fn (v) (er-is-tagged? v "tuple"))) + +(define + er-is-atom-named? + (fn (v name) (and (er-atom? v) (= (get v :name) name)))) +(define er-truthy? (fn (v) (er-is-atom-named? v "true"))) + +;; ── environment ─────────────────────────────────────────────────── +(define er-env-new (fn () {})) + +(define + er-env-lookup + (fn + (env name) + (if + (dict-has? env name) + (get env name) + (error (str "Erlang: unbound variable '" name "'"))))) + +(define er-env-bind! (fn (env name val) (dict-set! env name val))) + +;; ── entry ───────────────────────────────────────────────────────── +(define + erlang-eval-ast + (fn + (src) + (let + ((st (er-state-make (er-tokenize src)))) + (let + ((body (er-parse-body st))) + (er-sched-init!) + (let + ((env (er-env-new))) + (let + ((main-fun + (er-mk-fun + (list + {:patterns (list) + :body body + :guards (list) + :name nil}) + env))) + (let + ((main-proc (er-proc-new! env))) + (dict-set! main-proc :initial-fun main-fun) + (er-sched-run-all!) + (let + ((main-pid (get main-proc :pid))) + (if + (not (= (er-proc-field main-pid :state) "dead")) + (error + "Erlang: deadlock — main process never terminated") + (er-proc-field main-pid :exit-result)))))))))) + +(define + er-eval-body + (fn + (exprs env) + (let + ((last (list nil))) + (for-each + (fn (i) (set-nth! last 0 (er-eval-expr (nth exprs i) env))) + (range 0 (len exprs))) + (nth last 0)))) + +;; ── dispatch ────────────────────────────────────────────────────── +(define + er-eval-expr + (fn + (node env) + (let + ((ty (get node :type))) + (cond + (= ty "integer") (parse-number (get node :value)) + (= ty "float") (parse-number (get node :value)) + (= ty "atom") (er-mk-atom (get node :value)) + (= ty "string") (get node :value) + (= ty "nil") (er-mk-nil) + (= ty "var") (er-eval-var node env) + (= ty "tuple") (er-eval-tuple node env) + (= ty "cons") (er-eval-cons node env) + (= ty "op") (er-eval-op node env) + (= ty "unop") (er-eval-unop node env) + (= ty "block") (er-eval-body (get node :exprs) env) + (= ty "if") (er-eval-if node env) + (= ty "case") (er-eval-case node env) + (= ty "call") (er-eval-call node env) + (= ty "fun") (er-eval-fun node env) + (= ty "send") (er-eval-send node env) + (= ty "receive") (er-eval-receive node env) + (= ty "try") (er-eval-try node env) + (= ty "lc") (er-eval-lc node env) + (= ty "binary") (er-eval-binary node env) + (= ty "match") (er-eval-match node env) + :else (error (str "Erlang eval: unsupported node type '" ty "'")))))) + +(define + er-eval-var + (fn + (node env) + (let + ((name (get node :name))) + (if + (= name "_") + (error "Erlang: '_' cannot be used as a value") + (er-env-lookup env name))))) + +(define + er-eval-tuple + (fn + (node env) + (let + ((out (list))) + (for-each + (fn + (i) + (append! out (er-eval-expr (nth (get node :elements) i) env))) + (range 0 (len (get node :elements)))) + (er-mk-tuple out)))) + +(define + er-eval-cons + (fn + (node env) + (er-mk-cons + (er-eval-expr (get node :head) env) + (er-eval-expr (get node :tail) env)))) + +;; ── match expression ───────────────────────────────────────────── +(define + er-eval-match + (fn + (node env) + (let + ((lhs (get node :lhs)) + (rhs-val (er-eval-expr (get node :rhs) env))) + (if + (er-match! lhs rhs-val env) + rhs-val + (error "Erlang: badmatch"))))) + +;; ── pattern matching ───────────────────────────────────────────── +;; Unifies PAT against VAL, binding fresh vars into ENV. +;; Returns true on success, false otherwise. On failure ENV may hold +;; partial bindings — callers trying multiple clauses must snapshot +;; ENV and restore it between attempts. +(define + er-match! + (fn + (pat val env) + (let + ((ty (get pat :type))) + (cond + (= ty "var") (er-match-var pat val env) + (= ty "integer") + (and (= (type-of val) "number") (= (parse-number (get pat :value)) val)) + (= ty "float") + (and (= (type-of val) "number") (= (parse-number (get pat :value)) val)) + (= ty "atom") (and (er-atom? val) (= (get val :name) (get pat :value))) + (= ty "string") + (and (= (type-of val) "string") (= val (get pat :value))) + (= ty "nil") (er-nil? val) + (= ty "tuple") (er-match-tuple pat val env) + (= ty "cons") (er-match-cons pat val env) + (= ty "binary") (er-match-binary pat val env) + :else (error (str "Erlang match: unsupported pattern type '" ty "'")))))) + +(define + er-match-var + (fn + (pat val env) + (let + ((name (get pat :name))) + (cond + (= name "_") true + (dict-has? env name) (er-equal? (get env name) val) + :else (do (er-env-bind! env name val) true))))) + +(define + er-match-tuple + (fn + (pat val env) + (and + (er-tuple? val) + (let + ((ps (get pat :elements)) (vs (get val :elements))) + (if (not (= (len ps) (len vs))) false (er-match-all ps vs 0 env)))))) + +(define + er-match-all + (fn + (ps vs i env) + (if + (>= i (len ps)) + true + (if + (er-match! (nth ps i) (nth vs i) env) + (er-match-all ps vs (+ i 1) env) + false)))) + +(define + er-match-cons + (fn + (pat val env) + (and + (er-cons? val) + (and + (er-match! (get pat :head) (get val :head) env) + (er-match! (get pat :tail) (get val :tail) env))))) + +;; Match `<>` against a binary value. Walks the +;; segment list left-to-right, consuming bytes from the front of the +;; binary for each segment. Integer segments decode big-endian and +;; bind/check the pattern; binary-spec segments without size capture +;; the trailing bytes as a binary value. +(define + er-match-binary + (fn + (pat val env) + (and + (er-binary? val) + (let + ((segs (get pat :segments)) (cursor (list 0))) + (and + (er-match-binary-segs segs val env cursor 0) + (= (nth cursor 0) (len (get val :bytes)))))))) + +(define + er-match-binary-segs + (fn + (segs val env cursor i) + (cond + (>= i (len segs)) true + :else (let + ((seg (nth segs i))) + (let + ((spec (get seg :spec)) + (size-node (get seg :size))) + (cond + (= spec "integer") + (er-match-binary-int seg val env cursor segs i) + (= spec "binary") + (er-match-binary-tail seg val env cursor segs i) + :else false)))))) + +(define + er-match-binary-int + (fn + (seg val env cursor segs i) + (let + ((bits (cond + (= (get seg :size) nil) 8 + :else (er-eval-expr (get seg :size) env)))) + (cond + (or (not (= (remainder bits 8) 0)) (<= bits 0)) false + :else (let + ((nbytes (truncate (/ bits 8))) (bytes (get val :bytes)) (start (nth cursor 0))) + (cond + (> (+ start nbytes) (len bytes)) false + :else (let + ((decoded (er-decode-int bytes start nbytes))) + (set-nth! cursor 0 (+ start nbytes)) + (and + (er-match! (get seg :value) decoded env) + (er-match-binary-segs segs val env cursor (+ i 1)))))))))) + +(define + er-decode-int + (fn + (bytes start nbytes) + (let + ((acc (list 0))) + (for-each + (fn + (j) + (set-nth! + acc + 0 + (+ (* (nth acc 0) 256) (nth bytes (+ start j))))) + (range 0 nbytes)) + (nth acc 0)))) + +(define + er-match-binary-tail + (fn + (seg val env cursor segs i) + (cond + (not (= (get seg :size) nil)) false + (not (= (+ i 1) (len segs))) false + :else (let + ((bytes (get val :bytes)) + (start (nth cursor 0)) + (rest-bytes (list))) + (for-each + (fn (k) (append! rest-bytes (nth bytes k))) + (range start (len bytes))) + (set-nth! cursor 0 (len bytes)) + (er-match! (get seg :value) (er-mk-binary rest-bytes) env))))) + +;; ── env snapshot / restore ──────────────────────────────────────── +(define + er-env-copy + (fn + (env) + (let + ((out {})) + (for-each (fn (k) (dict-set! out k (get env k))) (keys env)) + out))) + +(define + er-env-restore! + (fn + (env snap) + (for-each (fn (k) (dict-delete! env k)) (keys env)) + (for-each (fn (k) (dict-set! env k (get snap k))) (keys snap)))) + +;; ── case ───────────────────────────────────────────────────────── +(define + er-eval-case + (fn + (node env) + (let + ((subject (er-eval-expr (get node :expr) env))) + (er-eval-case-clauses (get node :clauses) 0 subject env)))) + +(define + er-eval-case-clauses + (fn + (clauses i subject env) + (if + (>= i (len clauses)) + (error "Erlang: case_clause: no matching clause") + (let + ((c (nth clauses i)) (snap (er-env-copy env))) + (if + (and + (er-match! (get c :pattern) subject env) + (er-eval-guards (get c :guards) env)) + (er-eval-body (get c :body) env) + (do + (er-env-restore! env snap) + (er-eval-case-clauses clauses (+ i 1) subject env))))))) + +;; ── operators ───────────────────────────────────────────────────── +(define + er-eval-op + (fn + (node env) + (let + ((op (get node :op)) (args (get node :args))) + (cond + (= op "andalso") (er-eval-andalso args env) + (= op "orelse") (er-eval-orelse args env) + :else (er-apply-binop + op + (er-eval-expr (nth args 0) env) + (er-eval-expr (nth args 1) env)))))) + +(define + er-eval-andalso + (fn + (args env) + (let + ((a (er-eval-expr (nth args 0) env))) + (if (er-truthy? a) (er-eval-expr (nth args 1) env) a)))) + +(define + er-eval-orelse + (fn + (args env) + (let + ((a (er-eval-expr (nth args 0) env))) + (if (er-truthy? a) a (er-eval-expr (nth args 1) env))))) + +(define + er-apply-binop + (fn + (op a b) + (cond + (= op "+") (+ a b) + (= op "-") (- a b) + (= op "*") (* a b) + (= op "/") (/ a b) + (= op "div") (truncate (/ a b)) + (= op "rem") (remainder a b) + (= op "==") (er-bool (er-equal? a b)) + (= op "/=") (er-bool (not (er-equal? a b))) + (= op "=:=") (er-bool (er-exact-equal? a b)) + (= op "=/=") (er-bool (not (er-exact-equal? a b))) + (= op "<") (er-bool (er-lt? a b)) + (= op ">") (er-bool (er-lt? b a)) + (= op "=<") (er-bool (not (er-lt? b a))) + (= op ">=") (er-bool (not (er-lt? a b))) + (= op "++") (er-list-append a b) + (= op "and") (er-bool (and (er-truthy? a) (er-truthy? b))) + (= op "or") (er-bool (or (er-truthy? a) (er-truthy? b))) + :else (error (str "Erlang eval: unsupported operator '" op "'"))))) + +(define + er-eval-unop + (fn + (node env) + (let + ((op (get node :op)) (a (er-eval-expr (get node :arg) env))) + (cond + (= op "-") (- 0 a) + (= op "+") a + (= op "not") (er-bool (not (er-truthy? a))) + :else (error (str "Erlang eval: unsupported unary '" op "'")))))) + +;; ── equality / comparison ───────────────────────────────────────── +(define + er-equal? + (fn + (a b) + (cond + (and (= (type-of a) "number") (= (type-of b) "number")) (= a b) + (and (er-atom? a) (er-atom? b)) (= (get a :name) (get b :name)) + (and (er-nil? a) (er-nil? b)) true + (and (er-cons? a) (er-cons? b)) + (and + (er-equal? (get a :head) (get b :head)) + (er-equal? (get a :tail) (get b :tail))) + (and (er-tuple? a) (er-tuple? b)) + (let + ((ea (get a :elements)) (eb (get b :elements))) + (and + (= (len ea) (len eb)) + (every? + (fn (i) (er-equal? (nth ea i) (nth eb i))) + (range 0 (len ea))))) + (and (= (type-of a) "string") (= (type-of b) "string")) (= a b) + (and (er-pid? a) (er-pid? b)) (= (get a :id) (get b :id)) + (and (er-ref? a) (er-ref? b)) (= (get a :id) (get b :id)) + (and (er-binary? a) (er-binary? b)) + (let + ((ba (get a :bytes)) (bb (get b :bytes))) + (and + (= (len ba) (len bb)) + (every? (fn (i) (= (nth ba i) (nth bb i))) (range 0 (len ba))))) + :else false))) + +;; Exact equality: 1 =/= 1.0 in Erlang. +(define + er-exact-equal? + (fn + (a b) + (if + (and (= (type-of a) "number") (= (type-of b) "number")) + (and (= (integer? a) (integer? b)) (= a b)) + (er-equal? a b)))) + +(define + er-lt? + (fn + (a b) + (cond + (and (= (type-of a) "number") (= (type-of b) "number")) (< a b) + (and (er-atom? a) (er-atom? b)) (< (get a :name) (get b :name)) + (and (= (type-of a) "string") (= (type-of b) "string")) (< a b) + :else (< (er-type-order a) (er-type-order b))))) + +(define + er-type-order + (fn + (v) + (cond + (= (type-of v) "number") 0 + (er-atom? v) 1 + (er-tuple? v) 2 + (er-nil? v) 3 + (er-cons? v) 3 + (= (type-of v) "string") 4 + (er-pid? v) 5 + :else 6))) + +(define + er-list-append + (fn + (a b) + (cond + (er-nil? a) b + (er-cons? a) + (er-mk-cons (get a :head) (er-list-append (get a :tail) b)) + :else (error "Erlang: ++ left argument is not a proper list")))) + +;; ── if ──────────────────────────────────────────────────────────── +(define er-eval-if (fn (node env) (er-eval-if-clauses (get node :clauses) 0 env))) + +(define + er-eval-if-clauses + (fn + (clauses i env) + (if + (>= i (len clauses)) + (error "Erlang: if: no clause matched") + (let + ((c (nth clauses i))) + (if + (er-eval-guards (get c :guards) env) + (er-eval-body (get c :body) env) + (er-eval-if-clauses clauses (+ i 1) env)))))) + +;; Guards: outer list = OR, inner list = AND. Empty outer = always pass. +(define + er-eval-guards + (fn + (alts env) + (if (= (len alts) 0) true (er-eval-guards-any alts 0 env)))) + +(define + er-eval-guards-any + (fn + (alts i env) + (if + (>= i (len alts)) + false + (if + (er-eval-guard-conj (nth alts i) env) + true + (er-eval-guards-any alts (+ i 1) env))))) + +(define er-eval-guard-conj (fn (conj env) (er-eval-guard-conj-iter conj 0 env))) + +(define + er-eval-guard-conj-iter + (fn + (conj i env) + (if + (>= i (len conj)) + true + (if + (er-truthy? (er-eval-expr (nth conj i) env)) + (er-eval-guard-conj-iter conj (+ i 1) env) + false)))) + +;; ── function calls ─────────────────────────────────────────────── +(define + er-eval-call + (fn + (node env) + (let + ((fun-node (get node :fun)) (args (get node :args))) + (cond + (= (get fun-node :type) "atom") + (let + ((name (get fun-node :value)) (vs (er-eval-args args env))) + (cond + (and (dict-has? env name) (er-fun? (get env name))) + (er-apply-fun (get env name) vs) + :else (er-apply-bif name vs))) + (= (get fun-node :type) "remote") + (let + ((mod-name (er-resolve-call-name (get fun-node :mod) env "module")) + (fn-name (er-resolve-call-name (get fun-node :fun) env "function"))) + (er-apply-remote-bif mod-name fn-name (er-eval-args args env))) + :else + (let + ((fv (er-eval-expr fun-node env))) + (if + (er-fun? fv) + (er-apply-fun fv (er-eval-args args env)) + (error "Erlang: not a function"))))))) + +(define + er-eval-args + (fn + (args env) + (let + ((out (list))) + (for-each + (fn (i) (append! out (er-eval-expr (nth args i) env))) + (range 0 (len args))) + out))) + +;; Resolve a remote call's module/function reference into a string. +;; Atom AST nodes use their `:value` directly. For any other shape +;; (typically a var or another expression), evaluate it and require +;; the result to be an atom. +(define + er-resolve-call-name + (fn + (node env kind) + (cond + (= (get node :type) "atom") (get node :value) + :else (let + ((v (er-eval-expr node env))) + (if + (er-atom? v) + (get v :name) + (error + (str "Erlang: call " kind " must be an atom, got " (er-format-value v)))))))) + +;; ── fun values ─────────────────────────────────────────────────── +(define + er-mk-fun + (fn (clauses env) {:env env :clauses clauses :tag "fun"})) +(define er-fun? (fn (v) (er-is-tagged? v "fun"))) + +(define + er-eval-fun + (fn (node env) (er-mk-fun (get node :clauses) env))) + +(define + er-apply-fun + (fn + (fv vs) + (er-apply-fun-clauses (get fv :clauses) vs (get fv :env) 0))) + +(define + er-apply-fun-clauses + (fn + (clauses vs closure-env i) + (if + (>= i (len clauses)) + (error "Erlang: function_clause: no matching fun clause") + (let + ((c (nth clauses i)) + (ps (get c :patterns)) + (call-env (er-env-copy closure-env))) + (if + (not (= (len ps) (len vs))) + (er-apply-fun-clauses clauses vs closure-env (+ i 1)) + (if + (and + (er-match-all ps vs 0 call-env) + (er-eval-guards (get c :guards) call-env)) + (er-eval-body (get c :body) call-env) + (er-apply-fun-clauses clauses vs closure-env (+ i 1)))))))) + +;; ── BIFs ───────────────────────────────────────────────────────── +(define er-atom-ok (er-mk-atom "ok")) + +(define + er-apply-bif + (fn + (name vs) + (cond + (= name "is_integer") (er-bif-is-integer vs) + (= name "is_atom") (er-bif-is-atom vs) + (= name "is_list") (er-bif-is-list vs) + (= name "is_tuple") (er-bif-is-tuple vs) + (= name "is_number") (er-bif-is-number vs) + (= name "is_float") (er-bif-is-float vs) + (= name "is_boolean") (er-bif-is-boolean vs) + (= name "length") (er-bif-length vs) + (= name "hd") (er-bif-hd vs) + (= name "tl") (er-bif-tl vs) + (= name "element") (er-bif-element vs) + (= name "tuple_size") (er-bif-tuple-size vs) + (= name "atom_to_list") (er-bif-atom-to-list vs) + (= name "list_to_atom") (er-bif-list-to-atom vs) + (= name "is_pid") (er-bif-is-pid vs) + (= name "is_reference") (er-bif-is-reference vs) + (= name "is_binary") (er-bif-is-binary vs) + (= name "byte_size") (er-bif-byte-size vs) + (= name "abs") (er-bif-abs vs) + (= name "min") (er-bif-min vs) + (= name "max") (er-bif-max vs) + (= name "tuple_to_list") (er-bif-tuple-to-list vs) + (= name "list_to_tuple") (er-bif-list-to-tuple vs) + (= name "integer_to_list") (er-bif-integer-to-list vs) + (= name "list_to_integer") (er-bif-list-to-integer vs) + (= name "is_function") (er-bif-is-function vs) + (= name "self") (er-bif-self vs) + (= name "spawn") (er-bif-spawn vs) + (= name "exit") (er-bif-exit vs) + (= name "make_ref") (er-bif-make-ref vs) + (= name "link") (er-bif-link vs) + (= name "unlink") (er-bif-unlink vs) + (= name "monitor") (er-bif-monitor vs) + (= name "demonitor") (er-bif-demonitor vs) + (= name "process_flag") (er-bif-process-flag vs) + (= name "register") (er-bif-register vs) + (= name "unregister") (er-bif-unregister vs) + (= name "whereis") (er-bif-whereis vs) + (= name "registered") (er-bif-registered vs) + (= name "throw") (raise (er-mk-throw-marker (er-bif-arg1 vs "throw"))) + (= name "error") (raise (er-mk-error-marker (er-bif-arg1 vs "error"))) + :else (error + (str "Erlang: undefined function '" name "/" (len vs) "'"))))) + +(define + er-apply-remote-bif + (fn + (mod name vs) + (cond + (dict-has? (er-modules-get) mod) + (er-apply-user-module mod name vs) + (= mod "lists") (er-apply-lists-bif name vs) + (= mod "io") (er-apply-io-bif name vs) + (= mod "erlang") (er-apply-bif name vs) + (= mod "ets") (er-apply-ets-bif name vs) + :else (error + (str "Erlang: undefined module '" mod "'"))))) + +(define + er-apply-lists-bif + (fn + (name vs) + (cond + (= name "reverse") (er-bif-lists-reverse vs) + (= name "map") (er-bif-lists-map vs) + (= name "foldl") (er-bif-lists-foldl vs) + (= name "seq") (er-bif-lists-seq vs) + (= name "sum") (er-bif-lists-sum vs) + (= name "nth") (er-bif-lists-nth vs) + (= name "last") (er-bif-lists-last vs) + (= name "member") (er-bif-lists-member vs) + (= name "append") (er-bif-lists-append vs) + (= name "filter") (er-bif-lists-filter vs) + (= name "any") (er-bif-lists-any vs) + (= name "all") (er-bif-lists-all vs) + (= name "duplicate") (er-bif-lists-duplicate vs) + :else (error + (str "Erlang: undefined 'lists:" name "/" (len vs) "'"))))) + +(define + er-apply-io-bif + (fn + (name vs) + (cond + (= name "format") (er-bif-io-format vs) + :else (error + (str "Erlang: undefined 'io:" name "/" (len vs) "'"))))) + +(define + er-bif-arg1 + (fn + (vs name) + (if + (= (len vs) 1) + (nth vs 0) + (error (str "Erlang: " name ": wrong arity"))))) + +(define + er-bif-is-integer + (fn + (vs) + (let + ((v (er-bif-arg1 vs "is_integer"))) + (er-bool (and (= (type-of v) "number") (integer? v)))))) + +(define + er-bif-is-atom + (fn (vs) (er-bool (er-atom? (er-bif-arg1 vs "is_atom"))))) + +(define + er-bif-is-list + (fn + (vs) + (let + ((v (er-bif-arg1 vs "is_list"))) + (er-bool (or (er-nil? v) (er-cons? v)))))) + +(define + er-bif-is-tuple + (fn (vs) (er-bool (er-tuple? (er-bif-arg1 vs "is_tuple"))))) + +(define + er-bif-is-number + (fn + (vs) + (er-bool (= (type-of (er-bif-arg1 vs "is_number")) "number")))) + +(define + er-bif-is-float + (fn + (vs) + (let + ((v (er-bif-arg1 vs "is_float"))) + (er-bool (and (= (type-of v) "number") (not (integer? v))))))) + +(define + er-bif-is-boolean + (fn + (vs) + (let + ((v (er-bif-arg1 vs "is_boolean"))) + (er-bool + (or (er-is-atom-named? v "true") (er-is-atom-named? v "false")))))) + +(define + er-bif-is-binary + (fn (vs) (er-bool (er-binary? (er-bif-arg1 vs "is_binary"))))) + +(define + er-bif-byte-size + (fn + (vs) + (let + ((v (er-bif-arg1 vs "byte_size"))) + (cond + (er-binary? v) (len (get v :bytes)) + :else (raise (er-mk-error-marker (er-mk-atom "badarg"))))))) + +;; ── list / tuple BIFs ──────────────────────────────────────────── +(define er-bif-length (fn (vs) (er-list-length (er-bif-arg1 vs "length")))) + +(define + er-list-length + (fn + (v) + (cond + (er-nil? v) 0 + (er-cons? v) (+ 1 (er-list-length (get v :tail))) + :else (error "Erlang: length: not a proper list")))) + +(define + er-bif-hd + (fn + (vs) + (let + ((v (er-bif-arg1 vs "hd"))) + (if + (er-cons? v) + (get v :head) + (error "Erlang: hd: empty list or non-list"))))) + +(define + er-bif-tl + (fn + (vs) + (let + ((v (er-bif-arg1 vs "tl"))) + (if + (er-cons? v) + (get v :tail) + (error "Erlang: tl: empty list or non-list"))))) + +(define + er-bif-element + (fn + (vs) + (if + (not (= (len vs) 2)) + (error "Erlang: element: arity") + (let + ((i (nth vs 0)) (t (nth vs 1))) + (if + (and (= (type-of i) "number") (er-tuple? t)) + (let + ((elems (get t :elements))) + (if + (and (>= i 1) (<= i (len elems))) + (nth elems (- i 1)) + (error "Erlang: element: badarg (index out of range)"))) + (error "Erlang: element: badarg")))))) + +(define + er-bif-tuple-size + (fn + (vs) + (let + ((v (er-bif-arg1 vs "tuple_size"))) + (if + (er-tuple? v) + (len (get v :elements)) + (error "Erlang: tuple_size: not a tuple"))))) + +(define + er-bif-atom-to-list + (fn + (vs) + (let + ((v (er-bif-arg1 vs "atom_to_list"))) + (if + (er-atom? v) + (get v :name) + (error "Erlang: atom_to_list: not an atom"))))) + +(define + er-bif-list-to-atom + (fn + (vs) + (let + ((v (er-bif-arg1 vs "list_to_atom"))) + (if + (= (type-of v) "string") + (er-mk-atom v) + (error "Erlang: list_to_atom: not a string"))))) + +;; ── lists module ───────────────────────────────────────────────── +(define + er-bif-lists-reverse + (fn + (vs) + (er-list-reverse-iter (er-bif-arg1 vs "lists:reverse") (er-mk-nil)))) + +(define + er-list-reverse-iter + (fn + (v acc) + (cond + (er-nil? v) acc + (er-cons? v) + (er-list-reverse-iter (get v :tail) (er-mk-cons (get v :head) acc)) + :else (error "Erlang: lists:reverse: not a list")))) + +(define + er-bif-lists-map + (fn + (vs) + (if + (not (= (len vs) 2)) + (error "Erlang: lists:map: arity") + (er-list-reverse-iter + (er-map-iter (nth vs 0) (nth vs 1) (er-mk-nil)) + (er-mk-nil))))) + +(define + er-map-iter + (fn + (f lst acc) + (cond + (er-nil? lst) acc + (er-cons? lst) + (er-map-iter + f + (get lst :tail) + (er-mk-cons (er-apply-fun f (list (get lst :head))) acc)) + :else (error "Erlang: lists:map: not a list")))) + +(define + er-bif-lists-foldl + (fn + (vs) + (if + (not (= (len vs) 3)) + (error "Erlang: lists:foldl: arity") + (er-foldl-iter (nth vs 0) (nth vs 1) (nth vs 2))))) + +(define + er-foldl-iter + (fn + (f acc lst) + (cond + (er-nil? lst) acc + (er-cons? lst) + (er-foldl-iter + f + (er-apply-fun f (list (get lst :head) acc)) + (get lst :tail)) + :else (error "Erlang: lists:foldl: not a list")))) + +;; ── io module ──────────────────────────────────────────────────── +(define er-io-buffer (list "")) +(define er-io-flush! (fn () (set-nth! er-io-buffer 0 ""))) +(define er-io-buffer-content (fn () (nth er-io-buffer 0))) + +(define + er-bif-io-format + (fn + (vs) + (let + ((s + (cond + (= (len vs) 1) (er-format-string (nth vs 0) (list)) + (= (len vs) 2) + (er-format-string (nth vs 0) (er-list-to-sx-list (nth vs 1))) + :else (error "Erlang: io:format: arity")))) + (set-nth! er-io-buffer 0 (str (nth er-io-buffer 0) s)) + er-atom-ok))) + +(define + er-list-to-sx-list + (fn + (lst) + (let + ((out (list))) + (er-list-to-sx-collect lst out) + out))) + +(define + er-list-to-sx-collect + (fn + (lst out) + (cond + (er-nil? lst) nil + (er-cons? lst) + (do + (append! out (get lst :head)) + (er-list-to-sx-collect (get lst :tail) out)) + :else (error "Erlang: expected proper list")))) + +;; ── format string rendering (~n, ~~, ~p, ~w, ~s) ──────────────── +(define + er-format-string + (fn (fmt args) (er-format-walk fmt 0 args 0 ""))) + +(define + er-format-walk + (fn + (fmt i args ai out) + (if + (>= i (len fmt)) + out + (let + ((c (char-at fmt i))) + (cond + (and (= c "~") (< (+ i 1) (len fmt))) + (let + ((d (char-at fmt (+ i 1)))) + (cond + (= d "n") + (er-format-walk fmt (+ i 2) args ai (str out "\n")) + (= d "~") (er-format-walk fmt (+ i 2) args ai (str out "~")) + (or (= d "p") (= d "w") (= d "s")) + (er-format-walk + fmt + (+ i 2) + args + (+ ai 1) + (str out (er-format-value (nth args ai)))) + :else (er-format-walk + fmt + (+ i 2) + args + ai + (str out "~" d)))) + :else (er-format-walk fmt (+ i 1) args ai (str out c))))))) + +(define + er-format-value + (fn + (v) + (cond + (= (type-of v) "number") (str v) + (= (type-of v) "string") (str "\"" v "\"") + (er-atom? v) (get v :name) + (er-nil? v) "[]" + (er-cons? v) (str "[" (er-format-list-elems v) "]") + (er-tuple? v) (str "{" (er-format-tuple-elems (get v :elements)) "}") + (er-fun? v) "#Fun" + (er-pid? v) (str "") + (er-ref? v) (str "#Ref<" (get v :id) ">") + (er-binary? v) (str "<<" (er-format-bytes (get v :bytes)) ">>") + :else (str v)))) + +(define + er-format-bytes + (fn + (bs) + (cond + (= (len bs) 0) "" + :else (let + ((out (list (str (nth bs 0))))) + (for-each + (fn (i) (append! out ",") (append! out (str (nth bs i)))) + (range 1 (len bs))) + (reduce str "" out))))) + +(define + er-format-list-elems + (fn + (v) + (cond + (er-nil? v) "" + (and (er-cons? v) (er-nil? (get v :tail))) + (er-format-value (get v :head)) + (er-cons? v) + (str + (er-format-value (get v :head)) + "," + (er-format-list-elems (get v :tail))) + :else (str "|" (er-format-value v))))) + +(define + er-format-tuple-elems + (fn + (elems) + (if + (= (len elems) 0) + "" + (let + ((out (list (er-format-value (nth elems 0))))) + (for-each + (fn + (i) + (append! out ",") + (append! out (er-format-value (nth elems i)))) + (range 1 (len elems))) + (reduce str "" out))))) + +;; ── send: Pid ! Msg ────────────────────────────────────────────── +;; Target may be a pid or a registered atom name. Atom resolution +;; goes through the scheduler's `:registered` table. +(define + er-eval-send + (fn + (node env) + (let + ((to-val (er-eval-expr (get node :to) env)) + (msg-val (er-eval-expr (get node :msg) env))) + (let + ((pid (er-resolve-send-target to-val))) + (when + (er-proc-exists? pid) + (er-proc-mailbox-push! pid msg-val) + (when + (= (er-proc-field pid :state) "waiting") + (er-proc-set! pid :state "runnable") + (er-sched-enqueue! pid))) + msg-val)))) + +(define + er-resolve-send-target + (fn + (v) + (cond + (er-pid? v) v + (er-atom? v) + (let + ((name (get v :name))) + (if + (dict-has? (er-registered) name) + (get (er-registered) name) + (raise + (er-mk-error-marker + (er-mk-tuple + (list (er-mk-atom "badarg") v)))))) + :else (raise + (er-mk-error-marker + (er-mk-tuple (list (er-mk-atom "badarg") v))))))) + +;; ── receive (selective, delimited-continuation suspension) ────── +(define + er-eval-receive + (fn + (node env) + (let + ((pid (er-sched-current-pid)) + (after-node (get node :after-ms))) + (if + (= after-node nil) + (er-eval-receive-loop node pid env) + (er-eval-receive-with-after node pid env after-node))))) + +(define + er-eval-receive-loop + (fn + (node pid env) + (let + ((r (er-try-receive (get node :clauses) pid env))) + (if + (get r :matched) + (get r :value) + (do + (call/cc + (fn + (k) + (er-proc-set! pid :continuation k) + (er-proc-set! pid :state "waiting") + (raise er-suspend-marker))) + (er-eval-receive-loop node pid env)))))) + +(define + er-eval-receive-with-after + (fn + (node pid env after-node) + (let + ((ms (er-eval-expr after-node env))) + (cond + (and (er-atom? ms) (= (get ms :name) "infinity")) + (er-eval-receive-loop node pid env) + (= ms 0) (er-eval-receive-poll node pid env) + :else (er-eval-receive-timed node pid env))))) + +;; after 0 — poll once; on no match, run the after-body immediately. +(define + er-eval-receive-poll + (fn + (node pid env) + (let + ((r (er-try-receive (get node :clauses) pid env))) + (if + (get r :matched) + (get r :value) + (er-eval-body (get node :after-body) env))))) + +;; after Ms — suspend; on resume check :timed-out. When the scheduler +;; runs out of other work it fires one pending timeout per round. +(define + er-eval-receive-timed + (fn + (node pid env) + (let + ((r (er-try-receive (get node :clauses) pid env))) + (if + (get r :matched) + (get r :value) + (do + (er-proc-set! pid :has-timeout true) + (call/cc + (fn + (k) + (er-proc-set! pid :continuation k) + (er-proc-set! pid :state "waiting") + (raise er-suspend-marker))) + (if + (er-proc-field pid :timed-out) + (do + (er-proc-set! pid :timed-out false) + (er-proc-set! pid :has-timeout false) + (er-eval-body (get node :after-body) env)) + (er-eval-receive-timed node pid env))))))) + +;; Scan mailbox in arrival order. For each msg, try every clause. +;; On first match: remove that msg from mailbox and return body value. +(define + er-try-receive + (fn + (clauses pid env) + (let + ((mbox (er-proc-field pid :mailbox))) + (er-try-receive-loop clauses mbox env 0)))) + +(define + er-try-receive-loop + (fn + (clauses mbox env i) + (if + (>= i (er-q-len mbox)) + {:matched false} + (let + ((msg (er-q-nth mbox i)) + (cr (er-try-receive-clauses clauses msg env 0))) + (if + (get cr :matched) + (do + (er-q-delete-at! mbox i) + {:value (er-eval-body (get cr :body) env) :matched true}) + (er-try-receive-loop clauses mbox env (+ i 1))))))) + +;; Try clauses against a message. On match: bind vars into env and +;; return `{:matched true :body }` WITHOUT evaluating the +;; body — the caller must remove the message from the mailbox first, +;; otherwise a recursive `receive` inside the body would re-match the +;; same msg and loop forever. +(define + er-try-receive-clauses + (fn + (clauses msg env i) + (if + (>= i (len clauses)) + {:matched false} + (let + ((c (nth clauses i)) (snap (er-env-copy env))) + (if + (and + (er-match! (get c :pattern) msg env) + (er-eval-guards (get c :guards) env)) + {:body (get c :body) :matched true} + (do + (er-env-restore! env snap) + (er-try-receive-clauses clauses msg env (+ i 1)))))))) + +;; ── try/of/catch/after ──────────────────────────────────────────── +;; The outer guard captures any exception so the `after` body is +;; guaranteed to run, then re-raises. The inner guard runs the +;; expression body, optional `of` clauses on success, and `catch` +;; clauses on a thrown/erred/exited condition. If no catch clause +;; matches the raised class+pattern, the inner guard's clause +;; re-raises by returning nothing (handled via re-raise marker). +(define + er-eval-try + (fn + (node env) + (let + ((after-body (get node :after)) + (saved-exc (list nil)) + (result-ref (list nil))) + (guard + (c (:else (do (set-nth! saved-exc 0 c) nil))) + (set-nth! result-ref 0 (er-eval-try-inner node env))) + (when + (> (len after-body) 0) + (er-eval-body after-body env)) + (if + (= (nth saved-exc 0) nil) + (nth result-ref 0) + (raise (nth saved-exc 0)))))) + +(define + er-eval-try-inner + (fn + (node env) + (let + ((catch-clauses (get node :catch-clauses)) + (of-clauses (get node :of-clauses)) + (caught-ref (list false)) + (result-ref (list nil)) + (re-raise-ref (list nil))) + (guard + (c + ((er-thrown? c) + (er-eval-try-catch + catch-clauses "throw" (get c :reason) env + caught-ref result-ref re-raise-ref)) + ((er-errored? c) + (er-eval-try-catch + catch-clauses "error" (get c :reason) env + caught-ref result-ref re-raise-ref)) + ((er-exited? c) + (er-eval-try-catch + catch-clauses "exit" (get c :reason) env + caught-ref result-ref re-raise-ref))) + (let + ((r (er-eval-body (get node :exprs) env))) + (if + (= (len of-clauses) 0) + (set-nth! result-ref 0 r) + (set-nth! + result-ref + 0 + (er-eval-of-clauses of-clauses r env 0))))) + (when (not (= (nth re-raise-ref 0) nil)) + (raise (nth re-raise-ref 0))) + (nth result-ref 0)))) + +;; Try catch-clauses against (Class, Reason). If a clause matches, +;; runs its body and writes to result-ref. If none match, queues a +;; re-raise marker. +(define + er-eval-try-catch + (fn + (clauses class-name reason env caught-ref result-ref re-raise-ref) + (er-eval-try-catch-iter + clauses class-name reason env 0 caught-ref result-ref re-raise-ref))) + +(define + er-eval-try-catch-iter + (fn + (clauses class-name reason env i caught-ref result-ref re-raise-ref) + (if + (>= i (len clauses)) + (set-nth! + re-raise-ref + 0 + (er-mk-class-marker class-name reason)) + (let + ((c (nth clauses i)) + (snap (er-env-copy env)) + (clause-class (get (get c :class) :value))) + (cond + (not (= clause-class class-name)) + (er-eval-try-catch-iter + clauses class-name reason env (+ i 1) + caught-ref result-ref re-raise-ref) + :else + (if + (and + (er-match! (get c :pattern) reason env) + (er-eval-guards (get c :guards) env)) + (do + (set-nth! caught-ref 0 true) + (set-nth! + result-ref + 0 + (er-eval-body (get c :body) env))) + (do + (er-env-restore! env snap) + (er-eval-try-catch-iter + clauses class-name reason env (+ i 1) + caught-ref result-ref re-raise-ref)))))))) + +(define + er-mk-class-marker + (fn + (class-name reason) + (cond + (= class-name "throw") (er-mk-throw-marker reason) + (= class-name "error") (er-mk-error-marker reason) + (= class-name "exit") (er-mk-exit-marker reason) + :else (er-mk-error-marker reason)))) + +(define + er-eval-of-clauses + (fn + (clauses subject env i) + (if + (>= i (len clauses)) + (raise + (er-mk-error-marker + (er-mk-tuple + (list (er-mk-atom "try_clause") subject)))) + (let + ((c (nth clauses i)) (snap (er-env-copy env))) + (if + (and + (er-match! (get c :pattern) subject env) + (er-eval-guards (get c :guards) env)) + (er-eval-body (get c :body) env) + (do + (er-env-restore! env snap) + (er-eval-of-clauses clauses subject env (+ i 1)))))))) + +;; ── list comprehensions ───────────────────────────────────────── +;; `[E || Pat <- Source, FilterExpr, ...]`. Walk qualifiers in order: +;; generators iterate their source list and bind the pattern (with +;; env snapshot/restore so each iteration starts from the same +;; baseline); filters skip when falsy. At the end of the qualifier +;; chain, evaluate `head` and append to the accumulator. Build the +;; final cons chain in O(n) with a single right-fold. +(define + er-eval-lc + (fn + (node env) + (let + ((acc (list))) + (er-lc-walk (get node :qualifiers) 0 (get node :head) env acc) + (er-list-from-sx-list acc)))) + +(define + er-lc-walk + (fn + (quals i head env acc) + (if + (>= i (len quals)) + (append! acc (er-eval-expr head env)) + (let + ((q (nth quals i))) + (cond + (= (get q :kind) "gen") + (let + ((src (er-eval-expr (get q :source) env))) + (er-lc-iter-gen + src + (get q :pattern) + quals + i + head + env + acc)) + (= (get q :kind) "filter") + (when + (er-truthy? (er-eval-expr (get q :expr) env)) + (er-lc-walk quals (+ i 1) head env acc)) + :else (error "Erlang LC: unknown qualifier")))))) + +(define + er-lc-iter-gen + (fn + (src pat quals i head env acc) + (cond + (er-nil? src) nil + (er-cons? src) + (let + ((snap (er-env-copy env))) + (when + (er-match! pat (get src :head) env) + (er-lc-walk quals (+ i 1) head env acc)) + (er-env-restore! env snap) + (er-lc-iter-gen + (get src :tail) + pat + quals + i + head + env + acc)) + :else (error "Erlang LC: generator source is not a list")))) + +(define + er-list-from-sx-list + (fn + (xs) + (let + ((acc (list (er-mk-nil)))) + (for-each + (fn + (i) + (let + ((j (- (- (len xs) 1) i))) + (set-nth! acc 0 (er-mk-cons (nth xs j) (nth acc 0))))) + (range 0 (len xs))) + (nth acc 0)))) + +;; ── binaries ──────────────────────────────────────────────────── +;; Each segment is `Value : Size / Spec`. Supported specs: `integer` +;; (default; size in bits, must be multiple of 8 — 8/16/24/32 typical) +;; and `binary` (concatenate the segment's binary value into the +;; result). Default size for `integer` segments is 8 bits. +(define + er-eval-binary + (fn + (node env) + (let + ((segs (get node :segments)) (out (list))) + (for-each + (fn (i) (er-eval-binary-segment (nth segs i) env out)) + (range 0 (len segs))) + (er-mk-binary out)))) + +(define + er-eval-binary-segment + (fn + (seg env out) + (let + ((spec (get seg :spec)) + (val (er-eval-expr (get seg :value) env)) + (size (er-eval-binary-size (get seg :size) env))) + (cond + (= spec "integer") + (let + ((bits (if (= size nil) 8 size))) + (er-emit-int! out val bits)) + (= spec "binary") + (cond + (er-binary? val) + (for-each + (fn (i) (append! out (nth (get val :bytes) i))) + (range 0 (len (get val :bytes)))) + :else (raise + (er-mk-error-marker (er-mk-atom "badarg")))) + :else (error + (str "Erlang: binary spec '" spec "' not supported")))))) + +(define + er-eval-binary-size + (fn + (node env) + (cond + (= node nil) nil + :else (er-eval-expr node env)))) + +;; Big-endian byte emission for an N-bit integer (N must be multiple +;; of 8). For bits=8 this is just `(append! out (mod v 256))`. +(define + er-emit-int! + (fn + (out v bits) + (cond + (or (not (= (remainder bits 8) 0)) (<= bits 0)) + (error + (str "Erlang: binary integer size must be a positive multiple of 8 (got " bits ")")) + :else (let + ((nbytes (truncate (/ bits 8)))) + (for-each + (fn + (i) + (let + ((shift (* 8 (- (- nbytes 1) i)))) + (append! + out + (remainder (truncate (/ v (er-int-pow 2 shift))) 256)))) + (range 0 nbytes)))))) + +(define + er-int-pow + (fn + (b e) + (cond + (= e 0) 1 + :else (* b (er-int-pow b (- e 1)))))) + +;; ── extra erlang BIFs ─────────────────────────────────────────── +(define + er-bif-abs + (fn + (vs) + (let + ((v (er-bif-arg1 vs "abs"))) + (cond + (not (= (type-of v) "number")) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (< v 0) (- 0 v) + :else v)))) + +(define + er-bif-min + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: min/2: arity") + :else (let + ((a (nth vs 0)) (b (nth vs 1))) + (if (er-lt? b a) b a))))) + +(define + er-bif-max + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: max/2: arity") + :else (let + ((a (nth vs 0)) (b (nth vs 1))) + (if (er-lt? a b) b a))))) + +(define + er-bif-tuple-to-list + (fn + (vs) + (let + ((v (er-bif-arg1 vs "tuple_to_list"))) + (cond + (not (er-tuple? v)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (let + ((elems (get v :elements)) (out (er-mk-nil))) + (for-each + (fn + (i) + (let + ((j (- (- (len elems) 1) i))) + (set! out (er-mk-cons (nth elems j) out)))) + (range 0 (len elems))) + out))))) + +(define + er-bif-list-to-tuple + (fn + (vs) + (let + ((v (er-bif-arg1 vs "list_to_tuple")) (elems (list))) + (er-list-to-elem-list v elems) + (er-mk-tuple elems)))) + +(define + er-list-to-elem-list + (fn + (lst out) + (cond + (er-nil? lst) nil + (er-cons? lst) + (do + (append! out (get lst :head)) + (er-list-to-elem-list (get lst :tail) out)) + :else (raise (er-mk-error-marker (er-mk-atom "badarg")))))) + +(define + er-bif-integer-to-list + (fn + (vs) + (let + ((v (er-bif-arg1 vs "integer_to_list"))) + (cond + (not (= (type-of v) "number")) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (str v))))) + +(define + er-bif-list-to-integer + (fn + (vs) + (let + ((v (er-bif-arg1 vs "list_to_integer"))) + (cond + (not (= (type-of v) "string")) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (let + ((n (parse-number v))) + (cond + (= n nil) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else n)))))) + +(define + er-bif-is-function + (fn + (vs) + (cond + (= (len vs) 1) (er-bool (er-fun? (nth vs 0))) + (= (len vs) 2) + (let + ((v (nth vs 0)) (n (nth vs 1))) + (cond + (not (er-fun? v)) (er-bool false) + :else (er-bool (er-fun-has-arity? v n)))) + :else (error "Erlang: is_function: arity")))) + +(define + er-fun-has-arity? + (fn + (fv n) + (let + ((clauses (get fv :clauses)) (found (list false))) + (for-each + (fn + (i) + (when + (= (len (get (nth clauses i) :patterns)) n) + (set-nth! found 0 true))) + (range 0 (len clauses))) + (nth found 0)))) + +;; ── extra lists BIFs ─────────────────────────────────────────── +(define + er-bif-lists-seq + (fn + (vs) + (cond + (= (len vs) 2) (er-lists-seq-build (nth vs 0) (nth vs 1) 1) + (= (len vs) 3) (er-lists-seq-build (nth vs 0) (nth vs 1) (nth vs 2)) + :else (error "Erlang: lists:seq: arity")))) + +(define + er-lists-seq-build + (fn + (from to step) + (let + ((acc (er-mk-nil))) + (for-each + (fn + (i) + (let + ((v (- to (* i step)))) + (when + (and (>= v from) (<= v to)) + (set! acc (er-mk-cons v acc))))) + (range 0 (+ 1 (truncate (/ (- to from) step))))) + acc))) + +(define + er-bif-lists-sum + (fn + (vs) + (let + ((lst (er-bif-arg1 vs "lists:sum"))) + (er-lists-sum-iter lst 0)))) + +(define + er-lists-sum-iter + (fn + (lst acc) + (cond + (er-nil? lst) acc + (er-cons? lst) + (er-lists-sum-iter (get lst :tail) (+ acc (get lst :head))) + :else (raise (er-mk-error-marker (er-mk-atom "badarg")))))) + +(define + er-bif-lists-nth + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: lists:nth: arity") + :else (er-lists-nth-iter (nth vs 1) (nth vs 0))))) + +(define + er-lists-nth-iter + (fn + (lst i) + (cond + (or (<= i 0) (er-nil? lst)) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + (= i 1) (get lst :head) + :else (er-lists-nth-iter (get lst :tail) (- i 1))))) + +(define + er-bif-lists-last + (fn + (vs) + (let + ((lst (er-bif-arg1 vs "lists:last"))) + (cond + (er-nil? lst) + (raise (er-mk-error-marker (er-mk-atom "badarg"))) + :else (er-lists-last-iter lst))))) + +(define + er-lists-last-iter + (fn + (lst) + (cond + (and (er-cons? lst) (er-nil? (get lst :tail))) (get lst :head) + (er-cons? lst) (er-lists-last-iter (get lst :tail)) + :else (raise (er-mk-error-marker (er-mk-atom "badarg")))))) + +(define + er-bif-lists-member + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: lists:member: arity") + :else (er-bool (er-lists-member-iter (nth vs 0) (nth vs 1)))))) + +(define + er-lists-member-iter + (fn + (target lst) + (cond + (er-nil? lst) false + (er-cons? lst) + (cond + (er-equal? target (get lst :head)) true + :else (er-lists-member-iter target (get lst :tail))) + :else false))) + +(define + er-bif-lists-append + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: lists:append: arity") + :else (er-list-append (nth vs 0) (nth vs 1))))) + +(define + er-bif-lists-filter + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: lists:filter: arity") + :else (er-lists-filter-build + (nth vs 0) + (nth vs 1) + (er-mk-nil))))) + +(define + er-lists-filter-build + (fn + (pred lst acc) + (cond + (er-nil? lst) (er-list-reverse-iter acc (er-mk-nil)) + (er-cons? lst) + (let + ((kept + (cond + (er-truthy? (er-apply-fun pred (list (get lst :head)))) + (er-mk-cons (get lst :head) acc) + :else acc))) + (er-lists-filter-build pred (get lst :tail) kept)) + :else (raise (er-mk-error-marker (er-mk-atom "badarg")))))) + +(define + er-bif-lists-any + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: lists:any: arity") + :else (er-bool (er-lists-any-iter (nth vs 0) (nth vs 1)))))) + +(define + er-lists-any-iter + (fn + (pred lst) + (cond + (er-nil? lst) false + (er-cons? lst) + (cond + (er-truthy? (er-apply-fun pred (list (get lst :head)))) true + :else (er-lists-any-iter pred (get lst :tail))) + :else false))) + +(define + er-bif-lists-all + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: lists:all: arity") + :else (er-bool (er-lists-all-iter (nth vs 0) (nth vs 1)))))) + +(define + er-lists-all-iter + (fn + (pred lst) + (cond + (er-nil? lst) true + (er-cons? lst) + (cond + (er-truthy? (er-apply-fun pred (list (get lst :head)))) + (er-lists-all-iter pred (get lst :tail)) + :else false) + :else false))) + +(define + er-bif-lists-duplicate + (fn + (vs) + (cond + (not (= (len vs) 2)) (error "Erlang: lists:duplicate: arity") + :else (let + ((n (nth vs 0)) (v (nth vs 1)) (out (er-mk-nil))) + (for-each + (fn (_) (set! out (er-mk-cons v out))) + (range 0 n)) + out)))) diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 54078477..4bab957c 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -1,433 +1,175 @@ -;; Forth runtime — state, stacks, dictionary, output buffer. -;; Data stack: mutable SX list, TOS = first. -;; Return stack: separate mutable list. -;; Dictionary: SX dict {lowercased-name -> word-record}. -;; Word record: {"kind" "body" "immediate?"}; kind is "primitive" or "colon-def". -;; Output buffer: mutable string appended to by `.`, `EMIT`, `CR`, etc. -;; Compile-mode flag: "compiling" on the state. +;; lib/forth/runtime.sx — Forth primitives on SX +;; +;; Provides Forth-idiomatic wrappers over SX built-ins. +;; Primitives used: +;; bitwise-and/or/xor/not/arithmetic-shift/bit-count (Phase 7) +;; make-bytevector/bytevector-u8-ref/u8-set!/... (Phase 20) +;; quotient/remainder/modulo (Phase 15 / builtin) +;; +;; Naming: SX identifiers can't include @ or !-alone, so Forth words are: +;; C@ → forth-cfetch C! → forth-cstore +;; @ → forth-fetch ! → forth-store + +;; --------------------------------------------------------------------------- +;; 1. Bitwise operations — Forth core words +;; Forth TRUE = -1 (all bits set), FALSE = 0. +;; All ops coerce to integer via truncate. +;; --------------------------------------------------------------------------- + +(define (forth-and a b) (bitwise-and (truncate a) (truncate b))) +(define (forth-or a b) (bitwise-or (truncate a) (truncate b))) +(define (forth-xor a b) (bitwise-xor (truncate a) (truncate b))) + +;; INVERT — bitwise NOT (Forth NOT is logical; INVERT is bitwise) +(define (forth-invert a) (bitwise-not (truncate a))) + +;; LSHIFT RSHIFT — n bit — shift a by n positions +(define (forth-lshift a n) (arithmetic-shift (truncate a) (truncate n))) +(define + (forth-rshift a n) + (arithmetic-shift (truncate a) (- 0 (truncate n)))) + +;; 2* 2/ — multiply/divide by 2 via bit shift +(define (forth-2* a) (arithmetic-shift (truncate a) 1)) +(define (forth-2/ a) (arithmetic-shift (truncate a) -1)) + +;; BIT-COUNT — number of set bits (Kernighan popcount) +(define (forth-bit-count a) (bit-count (truncate a))) + +;; INTEGER-LENGTH — index of highest set bit (0 for zero) +(define (forth-integer-length a) (integer-length (truncate a))) + +;; WITHIN — ( u ul uh -- flag ) true if ul <= u < uh +(define (forth-within u ul uh) (and (>= u ul) (< u uh))) + +;; Arithmetic complements commonly used alongside bitwise ops +(define (forth-negate a) (- 0 (truncate a))) +(define (forth-abs a) (abs (truncate a))) +(define (forth-min a b) (if (< a b) a b)) +(define (forth-max a b) (if (> a b) a b)) +(define (forth-mod a b) (modulo (truncate a) (truncate b))) + +;; /MOD — ( n1 n2 -- rem quot ) returns list (remainder quotient) +(define + (forth-divmod a b) + (list + (remainder (truncate a) (truncate b)) + (quotient (truncate a) (truncate b)))) + +;; --------------------------------------------------------------------------- +;; 2. String buffer — word-definition / string accumulation +;; EMIT appends one char; TYPE appends a string. +;; Value is retrieved with forth-sb-value. +;; --------------------------------------------------------------------------- (define - forth-make-state - (fn - () - (let - ((s (dict))) - (dict-set! s "dstack" (list)) - (dict-set! s "rstack" (list)) - (dict-set! s "dict" (dict)) - (dict-set! s "output" "") - (dict-set! s "compiling" false) - (dict-set! s "current-def" nil) - (dict-set! s "base" 10) - (dict-set! s "vars" (dict)) - s))) + (forth-sb-new) + (let + ((sb (dict))) + (dict-set! sb "_forth_sb" true) + (dict-set! sb "_chars" (list)) + sb)) + +(define (forth-sb? v) (and (dict? v) (dict-has? v "_forth_sb"))) + +;; EMIT — append one character +(define + (forth-sb-emit! sb c) + (dict-set! sb "_chars" (append (get sb "_chars") (list c))) + sb) + +;; TYPE — append a string +(define + (forth-sb-type! sb s) + (dict-set! sb "_chars" (append (get sb "_chars") (string->list s))) + sb) + +(define (forth-sb-value sb) (list->string (get sb "_chars"))) + +(define (forth-sb-length sb) (len (get sb "_chars"))) + +(define (forth-sb-clear! sb) (dict-set! sb "_chars" (list)) sb) + +;; Emit integer as decimal digits +(define (forth-sb-emit-int! sb n) (forth-sb-type! sb (str (truncate n)))) + +;; --------------------------------------------------------------------------- +;; 3. Memory / Bytevectors — Forth raw memory model +;; ALLOT allocates a bytevector. Byte and cell (32-bit LE) access. +;; --------------------------------------------------------------------------- + +;; ALLOT — allocate n bytes zero-initialised +(define (forth-mem-new n) (make-bytevector (truncate n) 0)) + +(define (forth-mem? v) (bytevector? v)) + +(define (forth-mem-size v) (bytevector-length v)) + +;; C@ C! — byte fetch/store +(define (forth-cfetch mem addr) (bytevector-u8-ref mem (truncate addr))) (define - forth-error - (fn (state msg) (dict-set! state "error" msg) (raise msg))) + (forth-cstore mem addr val) + (bytevector-u8-set! + mem + (truncate addr) + (modulo (truncate val) 256)) + mem) + +;; @ ! — 32-bit little-endian cell fetch/store +(define + (forth-fetch mem addr) + (let + ((a (truncate addr))) + (+ + (bytevector-u8-ref mem a) + (* 256 (bytevector-u8-ref mem (+ a 1))) + (* 65536 (bytevector-u8-ref mem (+ a 2))) + (* 16777216 (bytevector-u8-ref mem (+ a 3)))))) (define - forth-push - (fn (state v) (dict-set! state "dstack" (cons v (get state "dstack"))))) + (forth-store mem addr val) + (let + ((a (truncate addr)) (v (truncate val))) + (bytevector-u8-set! mem a (modulo v 256)) + (bytevector-u8-set! + mem + (+ a 1) + (modulo (quotient v 256) 256)) + (bytevector-u8-set! + mem + (+ a 2) + (modulo (quotient v 65536) 256)) + (bytevector-u8-set! + mem + (+ a 3) + (modulo (quotient v 16777216) 256))) + mem) +;; MOVE — copy count bytes from src[src-addr] to dst[dst-addr] (define - forth-pop - (fn - (state) - (let - ((st (get state "dstack"))) - (if - (= (len st) 0) - (forth-error state "stack underflow") - (let ((top (first st))) (dict-set! state "dstack" (rest st)) top))))) + (forth-move! src src-addr dst dst-addr count) + (letrec + ((go (fn (i) (when (< i (truncate count)) (bytevector-u8-set! dst (+ (truncate dst-addr) i) (bytevector-u8-ref src (+ (truncate src-addr) i))) (go (+ i 1)))))) + (go 0)) + dst) +;; FILL — fill count bytes at addr with byte value (define - forth-peek - (fn - (state) - (let - ((st (get state "dstack"))) - (if (= (len st) 0) (forth-error state "stack underflow") (first st))))) - -(define forth-depth (fn (state) (len (get state "dstack")))) + (forth-fill! mem addr count byte) + (letrec + ((go (fn (i) (when (< i (truncate count)) (bytevector-u8-set! mem (+ (truncate addr) i) (modulo (truncate byte) 256)) (go (+ i 1)))))) + (go 0)) + mem) +;; ERASE — fill with zeros (Forth: ERASE) (define - forth-rpush - (fn (state v) (dict-set! state "rstack" (cons v (get state "rstack"))))) + (forth-erase! mem addr count) + (forth-fill! mem addr count 0)) +;; Dump memory region as list of byte values (define - forth-rpop - (fn - (state) - (let - ((st (get state "rstack"))) - (if - (= (len st) 0) - (forth-error state "return stack underflow") - (let ((top (first st))) (dict-set! state "rstack" (rest st)) top))))) - -(define - forth-rpeek - (fn - (state) - (let - ((st (get state "rstack"))) - (if - (= (len st) 0) - (forth-error state "return stack underflow") - (first st))))) - -(define - forth-emit-str - (fn (state s) (dict-set! state "output" (str (get state "output") s)))) - -(define - forth-make-word - (fn - (kind body immediate?) - (let - ((w (dict))) - (dict-set! w "kind" kind) - (dict-set! w "body" body) - (dict-set! w "immediate?" immediate?) - w))) - -(define - forth-def-prim! - (fn - (state name body) - (dict-set! - (get state "dict") - (downcase name) - (forth-make-word "primitive" body false)))) - -(define - forth-def-prim-imm! - (fn - (state name body) - (dict-set! - (get state "dict") - (downcase name) - (forth-make-word "primitive" body true)))) - -(define - forth-lookup - (fn (state name) (get (get state "dict") (downcase name)))) - -(define - forth-binop - (fn - (op) - (fn - (state) - (let - ((b (forth-pop state)) (a (forth-pop state))) - (forth-push state (op a b)))))) - -(define - forth-unop - (fn - (op) - (fn (state) (let ((a (forth-pop state))) (forth-push state (op a)))))) - -(define - forth-cmp - (fn - (op) - (fn - (state) - (let - ((b (forth-pop state)) (a (forth-pop state))) - (forth-push state (if (op a b) -1 0)))))) - -(define - forth-cmp0 - (fn - (op) - (fn - (state) - (let ((a (forth-pop state))) (forth-push state (if (op a) -1 0)))))) - -(define - forth-trunc - (fn (x) (if (< x 0) (- 0 (floor (- 0 x))) (floor x)))) - -(define - forth-div - (fn - (a b) - (if (= b 0) (raise "division by zero") (forth-trunc (/ a b))))) - -(define - forth-mod - (fn - (a b) - (if (= b 0) (raise "division by zero") (- a (* b (forth-div a b)))))) - -(define forth-bits-width 32) - -(define - forth-to-unsigned - (fn (n w) (let ((m (pow 2 w))) (mod (+ (mod n m) m) m)))) - -(define - forth-from-unsigned - (fn - (n w) - (let ((half (pow 2 (- w 1)))) (if (>= n half) (- n (pow 2 w)) n)))) - -(define - forth-bitwise-step - (fn - (op ua ub out place i w) - (if - (>= i w) - out - (let - ((da (mod ua 2)) (db (mod ub 2))) - (forth-bitwise-step - op - (floor (/ ua 2)) - (floor (/ ub 2)) - (+ out (* place (op da db))) - (* place 2) - (+ i 1) - w))))) - -(define - forth-bitwise-uu - (fn - (op) - (fn - (a b) - (let - ((ua (forth-to-unsigned a forth-bits-width)) - (ub (forth-to-unsigned b forth-bits-width))) - (forth-from-unsigned - (forth-bitwise-step op ua ub 0 1 0 forth-bits-width) - forth-bits-width))))) - -(define - forth-bit-and - (forth-bitwise-uu (fn (x y) (if (and (= x 1) (= y 1)) 1 0)))) - -(define - forth-bit-or - (forth-bitwise-uu (fn (x y) (if (or (= x 1) (= y 1)) 1 0)))) - -(define forth-bit-xor (forth-bitwise-uu (fn (x y) (if (= x y) 0 1)))) - -(define forth-bit-invert (fn (a) (- 0 (+ a 1)))) - -(define - forth-install-primitives! - (fn - (state) - (forth-def-prim! state "DUP" (fn (s) (forth-push s (forth-peek s)))) - (forth-def-prim! state "DROP" (fn (s) (forth-pop s))) - (forth-def-prim! - state - "SWAP" - (fn - (s) - (let - ((b (forth-pop s)) (a (forth-pop s))) - (forth-push s b) - (forth-push s a)))) - (forth-def-prim! - state - "OVER" - (fn - (s) - (let - ((b (forth-pop s)) (a (forth-pop s))) - (forth-push s a) - (forth-push s b) - (forth-push s a)))) - (forth-def-prim! - state - "ROT" - (fn - (s) - (let - ((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s))) - (forth-push s b) - (forth-push s c) - (forth-push s a)))) - (forth-def-prim! - state - "-ROT" - (fn - (s) - (let - ((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s))) - (forth-push s c) - (forth-push s a) - (forth-push s b)))) - (forth-def-prim! - state - "NIP" - (fn (s) (let ((b (forth-pop s))) (forth-pop s) (forth-push s b)))) - (forth-def-prim! - state - "TUCK" - (fn - (s) - (let - ((b (forth-pop s)) (a (forth-pop s))) - (forth-push s b) - (forth-push s a) - (forth-push s b)))) - (forth-def-prim! - state - "?DUP" - (fn - (s) - (let ((a (forth-peek s))) (when (not (= a 0)) (forth-push s a))))) - (forth-def-prim! state "DEPTH" (fn (s) (forth-push s (forth-depth s)))) - (forth-def-prim! - state - "PICK" - (fn - (s) - (let - ((n (forth-pop s)) (st (get s "dstack"))) - (if - (or (< n 0) (>= n (len st))) - (forth-error s "PICK out of range") - (forth-push s (nth st n)))))) - (forth-def-prim! - state - "ROLL" - (fn - (s) - (let - ((n (forth-pop s)) (st (get s "dstack"))) - (if - (or (< n 0) (>= n (len st))) - (forth-error s "ROLL out of range") - (let - ((taken (nth st n)) - (before (take st n)) - (after (drop st (+ n 1)))) - (dict-set! s "dstack" (concat before after)) - (forth-push s taken)))))) - (forth-def-prim! - state - "2DUP" - (fn - (s) - (let - ((b (forth-pop s)) (a (forth-pop s))) - (forth-push s a) - (forth-push s b) - (forth-push s a) - (forth-push s b)))) - (forth-def-prim! state "2DROP" (fn (s) (forth-pop s) (forth-pop s))) - (forth-def-prim! - state - "2SWAP" - (fn - (s) - (let - ((d (forth-pop s)) - (c (forth-pop s)) - (b (forth-pop s)) - (a (forth-pop s))) - (forth-push s c) - (forth-push s d) - (forth-push s a) - (forth-push s b)))) - (forth-def-prim! - state - "2OVER" - (fn - (s) - (let - ((d (forth-pop s)) - (c (forth-pop s)) - (b (forth-pop s)) - (a (forth-pop s))) - (forth-push s a) - (forth-push s b) - (forth-push s c) - (forth-push s d) - (forth-push s a) - (forth-push s b)))) - (forth-def-prim! state "+" (forth-binop (fn (a b) (+ a b)))) - (forth-def-prim! state "-" (forth-binop (fn (a b) (- a b)))) - (forth-def-prim! state "*" (forth-binop (fn (a b) (* a b)))) - (forth-def-prim! state "/" (forth-binop forth-div)) - (forth-def-prim! state "MOD" (forth-binop forth-mod)) - (forth-def-prim! - state - "/MOD" - (fn - (s) - (let - ((b (forth-pop s)) (a (forth-pop s))) - (forth-push s (forth-mod a b)) - (forth-push s (forth-div a b))))) - (forth-def-prim! state "NEGATE" (forth-unop (fn (a) (- 0 a)))) - (forth-def-prim! state "ABS" (forth-unop abs)) - (forth-def-prim! - state - "MIN" - (forth-binop (fn (a b) (if (< a b) a b)))) - (forth-def-prim! - state - "MAX" - (forth-binop (fn (a b) (if (> a b) a b)))) - (forth-def-prim! state "1+" (forth-unop (fn (a) (+ a 1)))) - (forth-def-prim! state "1-" (forth-unop (fn (a) (- a 1)))) - (forth-def-prim! state "2+" (forth-unop (fn (a) (+ a 2)))) - (forth-def-prim! state "2-" (forth-unop (fn (a) (- a 2)))) - (forth-def-prim! state "2*" (forth-unop (fn (a) (* a 2)))) - (forth-def-prim! state "2/" (forth-unop (fn (a) (floor (/ a 2))))) - (forth-def-prim! state "=" (forth-cmp (fn (a b) (= a b)))) - (forth-def-prim! state "<>" (forth-cmp (fn (a b) (not (= a b))))) - (forth-def-prim! state "<" (forth-cmp (fn (a b) (< a b)))) - (forth-def-prim! state ">" (forth-cmp (fn (a b) (> a b)))) - (forth-def-prim! state "<=" (forth-cmp (fn (a b) (<= a b)))) - (forth-def-prim! state ">=" (forth-cmp (fn (a b) (>= a b)))) - (forth-def-prim! state "0=" (forth-cmp0 (fn (a) (= a 0)))) - (forth-def-prim! state "0<>" (forth-cmp0 (fn (a) (not (= a 0))))) - (forth-def-prim! state "0<" (forth-cmp0 (fn (a) (< a 0)))) - (forth-def-prim! state "0>" (forth-cmp0 (fn (a) (> a 0)))) - (forth-def-prim! state "AND" (forth-binop forth-bit-and)) - (forth-def-prim! state "OR" (forth-binop forth-bit-or)) - (forth-def-prim! state "XOR" (forth-binop forth-bit-xor)) - (forth-def-prim! state "INVERT" (forth-unop forth-bit-invert)) - (forth-def-prim! - state - "." - (fn (s) (forth-emit-str s (str (forth-pop s) " ")))) - (forth-def-prim! - state - ".S" - (fn - (s) - (let - ((st (reverse (get s "dstack")))) - (forth-emit-str s "<") - (forth-emit-str s (str (len st))) - (forth-emit-str s "> ") - (for-each (fn (v) (forth-emit-str s (str v " "))) st)))) - (forth-def-prim! - state - "EMIT" - (fn (s) (forth-emit-str s (code-char (forth-pop s))))) - (forth-def-prim! state "CR" (fn (s) (forth-emit-str s "\n"))) - (forth-def-prim! state "SPACE" (fn (s) (forth-emit-str s " "))) - (forth-def-prim! - state - "SPACES" - (fn - (s) - (let - ((n (forth-pop s))) - (when - (> n 0) - (for-each (fn (_) (forth-emit-str s " ")) (range 0 n)))))) - (forth-def-prim! state "BL" (fn (s) (forth-push s 32))) - state)) + (forth-mem->list mem addr count) + (letrec + ((go (fn (i acc) (if (= i 0) acc (go (- i 1) (cons (bytevector-u8-ref mem (+ (truncate addr) (- i 1))) acc)))))) + (go (truncate count) (list)))) diff --git a/lib/forth/test.sh b/lib/forth/test.sh new file mode 100755 index 00000000..edb884d7 --- /dev/null +++ b/lib/forth/test.sh @@ -0,0 +1,62 @@ +#!/usr/bin/env bash +# lib/forth/test.sh — smoke-test the Forth runtime layer. + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found." + exit 1 +fi + +TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT + +cat > "$TMPFILE" << 'EPOCHS' +(epoch 1) +(load "lib/forth/runtime.sx") +(epoch 2) +(load "lib/forth/tests/runtime.sx") +(epoch 3) +(eval "(list forth-test-pass forth-test-fail)") +EPOCHS + +OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) + +LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}') +if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok 3 //; s/\)$//') +fi +if [ -z "$LINE" ]; then + echo "ERROR: could not extract summary" + echo "$OUTPUT" | tail -20 + exit 1 +fi + +P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/') +F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/') +TOTAL=$((P + F)) + +if [ "$F" -eq 0 ]; then + echo "ok $P/$TOTAL lib/forth tests passed" +else + echo "FAIL $P/$TOTAL passed, $F failed" + TMPFILE2=$(mktemp) + cat > "$TMPFILE2" << 'EPOCHS2' +(epoch 1) +(load "lib/forth/runtime.sx") +(epoch 2) +(load "lib/forth/tests/runtime.sx") +(epoch 3) +(eval "(map (fn (f) (list (get f :name) (get f :got) (get f :expected))) forth-test-fails)") +EPOCHS2 + FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>/dev/null | grep -E '^\(ok-len 3' -A1 | tail -1 || true) + echo " Details: $FAILS" + rm -f "$TMPFILE2" +fi + +[ "$F" -eq 0 ] diff --git a/lib/forth/tests/runtime.sx b/lib/forth/tests/runtime.sx new file mode 100644 index 00000000..5edf10bd --- /dev/null +++ b/lib/forth/tests/runtime.sx @@ -0,0 +1,201 @@ +;; lib/forth/tests/runtime.sx — Tests for lib/forth/runtime.sx + +(define forth-test-pass 0) +(define forth-test-fail 0) +(define forth-test-fails (list)) + +(define + (forth-test name got expected) + (if + (= got expected) + (set! forth-test-pass (+ forth-test-pass 1)) + (begin + (set! forth-test-fail (+ forth-test-fail 1)) + (set! forth-test-fails (append forth-test-fails (list {:got got :expected expected :name name})))))) + +;; --------------------------------------------------------------------------- +;; 1. Bitwise operations +;; --------------------------------------------------------------------------- + +;; AND +(forth-test "and 0b1100 0b1010" (forth-and 12 10) 8) +(forth-test "and 0xFF 0x0F" (forth-and 255 15) 15) +(forth-test "and 0 any" (forth-and 0 42) 0) + +;; OR +(forth-test "or 0b1100 0b1010" (forth-or 12 10) 14) +(forth-test "or 0 x" (forth-or 0 7) 7) + +;; XOR +(forth-test "xor 0b1100 0b1010" (forth-xor 12 10) 6) +(forth-test "xor x x" (forth-xor 42 42) 0) + +;; INVERT +(forth-test "invert 0" (forth-invert 0) -1) +(forth-test "invert -1" (forth-invert -1) 0) +(forth-test "invert 1" (forth-invert 1) -2) + +;; LSHIFT RSHIFT +(forth-test "lshift 1 3" (forth-lshift 1 3) 8) +(forth-test "lshift 3 2" (forth-lshift 3 2) 12) +(forth-test "rshift 8 3" (forth-rshift 8 3) 1) +(forth-test "rshift 16 2" (forth-rshift 16 2) 4) + +;; 2* 2/ +(forth-test "2* 5" (forth-2* 5) 10) +(forth-test "2/ 10" (forth-2/ 10) 5) +(forth-test "2/ 7" (forth-2/ 7) 3) + +;; BIT-COUNT +(forth-test "bit-count 0" (forth-bit-count 0) 0) +(forth-test "bit-count 1" (forth-bit-count 1) 1) +(forth-test "bit-count 7" (forth-bit-count 7) 3) +(forth-test "bit-count 255" (forth-bit-count 255) 8) +(forth-test "bit-count 256" (forth-bit-count 256) 1) + +;; INTEGER-LENGTH +(forth-test "integer-length 0" (forth-integer-length 0) 0) +(forth-test "integer-length 1" (forth-integer-length 1) 1) +(forth-test "integer-length 4" (forth-integer-length 4) 3) +(forth-test "integer-length 255" (forth-integer-length 255) 8) + +;; WITHIN +(forth-test + "within 5 0 10" + (forth-within 5 0 10) + true) +(forth-test + "within 0 0 10" + (forth-within 0 0 10) + true) +(forth-test + "within 10 0 10" + (forth-within 10 0 10) + false) +(forth-test + "within -1 0 10" + (forth-within -1 0 10) + false) + +;; Arithmetic ops +(forth-test "negate 5" (forth-negate 5) -5) +(forth-test "negate -3" (forth-negate -3) 3) +(forth-test "abs -7" (forth-abs -7) 7) +(forth-test "min 3 5" (forth-min 3 5) 3) +(forth-test "max 3 5" (forth-max 3 5) 5) +(forth-test "mod 7 3" (forth-mod 7 3) 1) +(forth-test + "divmod 7 3" + (forth-divmod 7 3) + (list 1 2)) +(forth-test + "divmod 10 5" + (forth-divmod 10 5) + (list 0 2)) + +;; --------------------------------------------------------------------------- +;; 2. String buffer +;; --------------------------------------------------------------------------- + +(define sb1 (forth-sb-new)) +(forth-test "sb? new" (forth-sb? sb1) true) +(forth-test "sb? non-sb" (forth-sb? 42) false) +(forth-test "sb value empty" (forth-sb-value sb1) "") +(forth-test "sb length empty" (forth-sb-length sb1) 0) + +(forth-sb-type! sb1 "HELLO") +(forth-test "sb type" (forth-sb-value sb1) "HELLO") +(forth-test "sb length after type" (forth-sb-length sb1) 5) + +;; EMIT one char +(define sb2 (forth-sb-new)) +(forth-sb-emit! sb2 (nth (string->list "A") 0)) +(forth-sb-emit! sb2 (nth (string->list "B") 0)) +(forth-sb-emit! sb2 (nth (string->list "C") 0)) +(forth-test "sb emit chars" (forth-sb-value sb2) "ABC") + +;; Emit integer +(define sb3 (forth-sb-new)) +(forth-sb-type! sb3 "n=") +(forth-sb-emit-int! sb3 42) +(forth-test "sb emit-int" (forth-sb-value sb3) "n=42") + +(forth-sb-clear! sb1) +(forth-test "sb clear" (forth-sb-value sb1) "") +(forth-test "sb length after clear" (forth-sb-length sb1) 0) + +;; Build a word definition-style name +(define sb4 (forth-sb-new)) +(forth-sb-type! sb4 ": ") +(forth-sb-type! sb4 "SQUARE") +(forth-sb-type! sb4 " DUP * ;") +(forth-test "sb word def" (forth-sb-value sb4) ": SQUARE DUP * ;") + +;; --------------------------------------------------------------------------- +;; 3. Memory / Bytevectors +;; --------------------------------------------------------------------------- + +(define m1 (forth-mem-new 8)) +(forth-test "mem? yes" (forth-mem? m1) true) +(forth-test "mem? no" (forth-mem? 42) false) +(forth-test "mem size" (forth-mem-size m1) 8) +(forth-test "mem cfetch zero" (forth-cfetch m1 0) 0) + +;; C! C@ +(forth-cstore m1 0 65) +(forth-cstore m1 1 66) +(forth-test "mem cstore/cfetch 0" (forth-cfetch m1 0) 65) +(forth-test "mem cstore/cfetch 1" (forth-cfetch m1 1) 66) +(forth-cstore m1 2 256) +(forth-test + "mem cstore wraps 256→0" + (forth-cfetch m1 2) + 0) +(forth-cstore m1 2 257) +(forth-test + "mem cstore wraps 257→1" + (forth-cfetch m1 2) + 1) + +;; @ ! (32-bit LE cell) +(define m2 (forth-mem-new 8)) +(forth-store m2 0 305419896) +(forth-test "mem store/fetch" (forth-fetch m2 0) 305419896) +(forth-store m2 4 1) +(forth-test "mem fetch byte 4" (forth-cfetch m2 4) 1) +(forth-test "mem fetch byte 5" (forth-cfetch m2 5) 0) + +;; FILL ERASE +(define m3 (forth-mem-new 4)) +(forth-fill! m3 0 4 42) +(forth-test + "mem fill" + (forth-mem->list m3 0 4) + (list 42 42 42 42)) +(forth-erase! m3 1 2) +(forth-test + "mem erase middle" + (forth-mem->list m3 0 4) + (list 42 0 0 42)) + +;; MOVE +(define m4 (forth-mem-new 4)) +(forth-cstore m4 0 1) +(forth-cstore m4 1 2) +(forth-cstore m4 2 3) +(define m5 (forth-mem-new 4)) +(forth-move! m4 0 m5 0 3) +(forth-test + "mem move" + (forth-mem->list m5 0 3) + (list 1 2 3)) + +;; mem->list +(define m6 (forth-mem-new 3)) +(forth-cstore m6 0 10) +(forth-cstore m6 1 20) +(forth-cstore m6 2 30) +(forth-test + "mem->list" + (forth-mem->list m6 0 3) + (list 10 20 30)) diff --git a/lib/haskell/runtime.sx b/lib/haskell/runtime.sx new file mode 100644 index 00000000..0d4aca8e --- /dev/null +++ b/lib/haskell/runtime.sx @@ -0,0 +1,507 @@ +;; lib/haskell/runtime.sx — Haskell-on-SX runtime layer +;; +;; Covers the Haskell primitives now reachable via SX spec: +;; 1. Numeric type class helpers (Num / Integral / Fractional) +;; 2. Rational numbers (dict-based: {:_rational true :num n :den d}) +;; 3. Lazy evaluation — hk-force for promises created by delay +;; 4. Char utilities (Data.Char) +;; 5. Data.Set wrappers +;; 6. Data.List utilities +;; 7. Maybe / Either ADTs +;; 8. Tuples (lists, since list->vector unreliable in sx_server) +;; 9. String helpers (words/lines/isPrefixOf/etc.) +;; 10. Show helper + +;; =========================================================================== +;; 1. Numeric type class helpers +;; =========================================================================== + +(define hk-is-integer? integer?) +(define hk-is-float? float?) +(define hk-is-num? number?) + +;; fromIntegral — coerce integer to Float +(define (hk-to-float x) (exact->inexact x)) + +;; truncate / round toward zero +(define hk-to-integer truncate) +(define hk-from-integer (fn (n) n)) + +;; Haskell div: floor division (rounds toward -inf) +(define + (hk-div a b) + (let + ((q (quotient a b)) (r (remainder a b))) + (if + (and + (not (= r 0)) + (or + (and (< a 0) (> b 0)) + (and (> a 0) (< b 0)))) + (- q 1) + q))) + +;; Haskell mod: result has same sign as divisor +(define hk-mod modulo) + +;; Haskell rem: result has same sign as dividend +(define hk-rem remainder) + +;; Haskell quot: truncation division +(define hk-quot quotient) + +;; divMod and quotRem return pairs (lists) +(define (hk-div-mod a b) (list (hk-div a b) (hk-mod a b))) +(define (hk-quot-rem a b) (list (hk-quot a b) (hk-rem a b))) + +(define (hk-abs x) (if (< x 0) (- 0 x) x)) +(define + (hk-signum x) + (cond + ((> x 0) 1) + ((< x 0) -1) + (else 0))) + +(define hk-gcd gcd) +(define hk-lcm lcm) + +(define (hk-even? n) (= (modulo n 2) 0)) +(define (hk-odd? n) (not (= (modulo n 2) 0))) + +;; =========================================================================== +;; 2. Rational numbers (dict implementation — no built-in rational in sx_server) +;; =========================================================================== + +(define + (hk-make-rational n d) + (let + ((g (gcd (hk-abs n) (hk-abs d)))) + (if (< d 0) {:num (quotient (- 0 n) g) :den (quotient (- 0 d) g) :_rational true} {:num (quotient n g) :den (quotient d g) :_rational true}))) + +(define + (hk-rational? x) + (and (dict? x) (not (= (get x :_rational) nil)))) +(define (hk-numerator r) (get r :num)) +(define (hk-denominator r) (get r :den)) + +(define + (hk-rational-add r1 r2) + (hk-make-rational + (+ + (* (hk-numerator r1) (hk-denominator r2)) + (* (hk-numerator r2) (hk-denominator r1))) + (* (hk-denominator r1) (hk-denominator r2)))) + +(define + (hk-rational-sub r1 r2) + (hk-make-rational + (- + (* (hk-numerator r1) (hk-denominator r2)) + (* (hk-numerator r2) (hk-denominator r1))) + (* (hk-denominator r1) (hk-denominator r2)))) + +(define + (hk-rational-mul r1 r2) + (hk-make-rational + (* (hk-numerator r1) (hk-numerator r2)) + (* (hk-denominator r1) (hk-denominator r2)))) + +(define + (hk-rational-div r1 r2) + (hk-make-rational + (* (hk-numerator r1) (hk-denominator r2)) + (* (hk-denominator r1) (hk-numerator r2)))) + +(define + (hk-rational-to-float r) + (exact->inexact (/ (hk-numerator r) (hk-denominator r)))) + +(define (hk-show-rational r) (str (hk-numerator r) "%" (hk-denominator r))) + +;; =========================================================================== +;; 3. Lazy evaluation — promises (created via SX delay) +;; =========================================================================== + +(define + (hk-force p) + (if + (and (dict? p) (not (= (get p :_promise) nil))) + (if (get p :forced) (get p :value) ((get p :thunk))) + p)) + +;; =========================================================================== +;; 4. Char utilities (Data.Char) +;; =========================================================================== + +(define hk-ord char->integer) +(define hk-chr integer->char) + +;; Inline ASCII predicates — char-alphabetic?/char-numeric? unreliable in sx_server +(define + (hk-is-alpha? c) + (let + ((n (char->integer c))) + (or + (and (>= n 65) (<= n 90)) + (and (>= n 97) (<= n 122))))) + +(define + (hk-is-digit? c) + (let ((n (char->integer c))) (and (>= n 48) (<= n 57)))) + +(define + (hk-is-alnum? c) + (let + ((n (char->integer c))) + (or + (and (>= n 48) (<= n 57)) + (and (>= n 65) (<= n 90)) + (and (>= n 97) (<= n 122))))) + +(define + (hk-is-upper? c) + (let ((n (char->integer c))) (and (>= n 65) (<= n 90)))) + +(define + (hk-is-lower? c) + (let ((n (char->integer c))) (and (>= n 97) (<= n 122)))) + +(define + (hk-is-space? c) + (let + ((n (char->integer c))) + (or + (= n 32) + (= n 9) + (= n 10) + (= n 13) + (= n 12) + (= n 11)))) + +(define hk-to-upper char-upcase) +(define hk-to-lower char-downcase) + +;; digitToInt: '0'-'9' → 0-9, 'a'-'f'/'A'-'F' → 10-15 +(define + (hk-digit-to-int c) + (let + ((n (char->integer c))) + (cond + ((and (>= n 48) (<= n 57)) (- n 48)) + ((and (>= n 65) (<= n 70)) (- n 55)) + ((and (>= n 97) (<= n 102)) (- n 87)) + (else (error (str "hk-digit-to-int: not a hex digit: " c)))))) + +;; intToDigit: 0-15 → char +(define + (hk-int-to-digit n) + (cond + ((and (>= n 0) (<= n 9)) + (integer->char (+ n 48))) + ((and (>= n 10) (<= n 15)) + (integer->char (+ n 87))) + (else (error (str "hk-int-to-digit: out of range: " n))))) + +;; =========================================================================== +;; 5. Data.Set wrappers +;; =========================================================================== + +(define (hk-set-empty) (make-set)) +(define hk-set? set?) +(define hk-set-member? set-member?) + +(define (hk-set-insert x s) (begin (set-add! s x) s)) + +(define (hk-set-delete x s) (begin (set-remove! s x) s)) + +(define hk-set-union set-union) +(define hk-set-intersection set-intersection) +(define hk-set-difference set-difference) +(define hk-set-from-list list->set) +(define hk-set-to-list set->list) +(define (hk-set-null? s) (= (len (set->list s)) 0)) +(define (hk-set-size s) (len (set->list s))) + +(define (hk-set-singleton x) (let ((s (make-set))) (set-add! s x) s)) + +;; =========================================================================== +;; 6. Data.List utilities +;; =========================================================================== + +(define hk-head first) +(define hk-tail rest) +(define (hk-null? lst) (= (len lst) 0)) +(define hk-length len) + +(define + (hk-take n lst) + (if + (or (= n 0) (= (len lst) 0)) + (list) + (cons (first lst) (hk-take (- n 1) (rest lst))))) + +(define + (hk-drop n lst) + (if + (or (= n 0) (= (len lst) 0)) + lst + (hk-drop (- n 1) (rest lst)))) + +(define + (hk-take-while pred lst) + (if + (or (= (len lst) 0) (not (pred (first lst)))) + (list) + (cons (first lst) (hk-take-while pred (rest lst))))) + +(define + (hk-drop-while pred lst) + (if + (or (= (len lst) 0) (not (pred (first lst)))) + lst + (hk-drop-while pred (rest lst)))) + +(define + (hk-zip a b) + (if + (or (= (len a) 0) (= (len b) 0)) + (list) + (cons (list (first a) (first b)) (hk-zip (rest a) (rest b))))) + +(define + (hk-zip-with f a b) + (if + (or (= (len a) 0) (= (len b) 0)) + (list) + (cons (f (first a) (first b)) (hk-zip-with f (rest a) (rest b))))) + +(define + (hk-unzip pairs) + (list + (map (fn (p) (first p)) pairs) + (map (fn (p) (nth p 1)) pairs))) + +(define + (hk-elem x lst) + (cond + ((= (len lst) 0) false) + ((= x (first lst)) true) + (else (hk-elem x (rest lst))))) + +(define (hk-not-elem x lst) (not (hk-elem x lst))) + +(define + (hk-nub lst) + (letrec + ((go (fn (seen acc items) (if (= (len items) 0) (reverse acc) (let ((h (first items)) (t (rest items))) (if (hk-elem h seen) (go seen acc t) (go (cons h seen) (cons h acc) t))))))) + (go (list) (list) lst))) + +(define (hk-sum lst) (reduce + 0 lst)) +(define (hk-product lst) (reduce * 1 lst)) + +(define + (hk-maximum lst) + (reduce (fn (a b) (if (> a b) a b)) (first lst) (rest lst))) + +(define + (hk-minimum lst) + (reduce (fn (a b) (if (< a b) a b)) (first lst) (rest lst))) + +(define (hk-concat lsts) (reduce append (list) lsts)) + +(define (hk-concat-map f lst) (hk-concat (map f lst))) + +(define hk-sort sort) + +(define + (hk-span pred lst) + (list (hk-take-while pred lst) (hk-drop-while pred lst))) + +(define (hk-break pred lst) (hk-span (fn (x) (not (pred x))) lst)) + +(define + (hk-foldl f acc lst) + (if + (= (len lst) 0) + acc + (hk-foldl f (f acc (first lst)) (rest lst)))) + +(define + (hk-foldr f z lst) + (if + (= (len lst) 0) + z + (f (first lst) (hk-foldr f z (rest lst))))) + +(define + (hk-scanl f acc lst) + (if + (= (len lst) 0) + (list acc) + (cons acc (hk-scanl f (f acc (first lst)) (rest lst))))) + +(define + (hk-replicate n x) + (if (= n 0) (list) (cons x (hk-replicate (- n 1) x)))) + +(define + (hk-intersperse sep lst) + (if + (or (= (len lst) 0) (= (len lst) 1)) + lst + (cons (first lst) (cons sep (hk-intersperse sep (rest lst)))))) + +;; =========================================================================== +;; 7. Maybe / Either ADTs +;; =========================================================================== + +(define hk-nothing {:_maybe true :_tag "nothing"}) +(define (hk-just x) {:_maybe true :value x :_tag "just"}) +(define (hk-is-nothing? m) (= (get m :_tag) "nothing")) +(define (hk-is-just? m) (= (get m :_tag) "just")) +(define (hk-from-just m) (get m :value)) +(define (hk-from-maybe def m) (if (hk-is-nothing? m) def (hk-from-just m))) +(define + (hk-maybe def f m) + (if (hk-is-nothing? m) def (f (hk-from-just m)))) + +(define (hk-left x) {:value x :_either true :_tag "left"}) +(define (hk-right x) {:value x :_either true :_tag "right"}) +(define (hk-is-left? e) (= (get e :_tag) "left")) +(define (hk-is-right? e) (= (get e :_tag) "right")) +(define (hk-from-left e) (get e :value)) +(define (hk-from-right e) (get e :value)) +(define + (hk-either f g e) + (if (hk-is-left? e) (f (hk-from-left e)) (g (hk-from-right e)))) + +;; =========================================================================== +;; 8. Tuples (lists — list->vector unreliable in sx_server) +;; =========================================================================== + +(define (hk-pair a b) (list a b)) +(define hk-fst first) +(define (hk-snd t) (nth t 1)) + +(define (hk-triple a b c) (list a b c)) +(define hk-fst3 first) +(define (hk-snd3 t) (nth t 1)) +(define (hk-thd3 t) (nth t 2)) + +(define (hk-curry f) (fn (a) (fn (b) (f a b)))) +(define (hk-uncurry f) (fn (p) (f (hk-fst p) (hk-snd p)))) + +;; =========================================================================== +;; 9. String helpers (Data.List / Data.Char for strings) +;; =========================================================================== + +;; words: split on whitespace +(define + (hk-words s) + (letrec + ((slen (len s)) + (skip-ws + (fn + (i) + (if + (>= i slen) + (list) + (let + ((c (substring s i (+ i 1)))) + (if + (or (= c " ") (= c "\t") (= c "\n")) + (skip-ws (+ i 1)) + (collect-word i (+ i 1))))))) + (collect-word + (fn + (start i) + (if + (>= i slen) + (list (substring s start i)) + (let + ((c (substring s i (+ i 1)))) + (if + (or (= c " ") (= c "\t") (= c "\n")) + (cons (substring s start i) (skip-ws (+ i 1))) + (collect-word start (+ i 1)))))))) + (skip-ws 0))) + +;; unwords: join with spaces +(define + (hk-unwords lst) + (if + (= (len lst) 0) + "" + (reduce (fn (a b) (str a " " b)) (first lst) (rest lst)))) + +;; lines: split on newline +(define + (hk-lines s) + (letrec + ((slen (len s)) + (go + (fn + (start i acc) + (if + (>= i slen) + (reverse (cons (substring s start i) acc)) + (if + (= (substring s i (+ i 1)) "\n") + (go + (+ i 1) + (+ i 1) + (cons (substring s start i) acc)) + (go start (+ i 1) acc)))))) + (if (= slen 0) (list) (go 0 0 (list))))) + +;; unlines: join, each with trailing newline +(define (hk-unlines lst) (reduce (fn (a b) (str a b "\n")) "" lst)) + +;; isPrefixOf +(define + (hk-is-prefix-of pre s) + (and (<= (len pre) (len s)) (= pre (substring s 0 (len pre))))) + +;; isSuffixOf +(define + (hk-is-suffix-of suf s) + (let + ((sl (len suf)) (tl (len s))) + (and (<= sl tl) (= suf (substring s (- tl sl) tl))))) + +;; isInfixOf — linear scan +(define + (hk-is-infix-of pat s) + (let + ((plen (len pat)) (slen (len s))) + (letrec + ((go (fn (i) (if (> (+ i plen) slen) false (if (= pat (substring s i (+ i plen))) true (go (+ i 1))))))) + (if (= plen 0) true (go 0))))) + +;; =========================================================================== +;; 10. Show helper +;; =========================================================================== + +(define + (hk-show x) + (cond + ((= x nil) "Nothing") + ((= x true) "True") + ((= x false) "False") + ((hk-rational? x) (hk-show-rational x)) + ((integer? x) (str x)) + ((float? x) (str x)) + ((= (type-of x) "string") (str "\"" x "\"")) + ((= (type-of x) "char") (str "'" (str x) "'")) + ((list? x) + (str + "[" + (if + (= (len x) 0) + "" + (reduce + (fn (a b) (str a "," (hk-show b))) + (hk-show (first x)) + (rest x))) + "]")) + (else (str x)))) diff --git a/lib/haskell/test.sh b/lib/haskell/test.sh index 892194d4..3ea6d249 100755 --- a/lib/haskell/test.sh +++ b/lib/haskell/test.sh @@ -46,6 +46,7 @@ for FILE in "${FILES[@]}"; do cat > "$TMPFILE" < "$TMPFILE2" <char 65)) 65) +(hk-test "chr 65" (hk-ord (hk-chr 65)) 65) +(hk-test "is-alpha? A" (hk-is-alpha? (integer->char 65)) true) +(hk-test "is-alpha? 0" (hk-is-alpha? (integer->char 48)) false) +(hk-test "is-digit? 5" (hk-is-digit? (integer->char 53)) true) +(hk-test "is-digit? A" (hk-is-digit? (integer->char 65)) false) +(hk-test "is-upper? A" (hk-is-upper? (integer->char 65)) true) +(hk-test "is-upper? a" (hk-is-upper? (integer->char 97)) false) +(hk-test "is-lower? a" (hk-is-lower? (integer->char 97)) true) +(hk-test "is-space? spc" (hk-is-space? (integer->char 32)) true) +(hk-test "is-space? A" (hk-is-space? (integer->char 65)) false) +(hk-test + "to-upper a" + (hk-ord (hk-to-upper (integer->char 97))) + 65) +(hk-test + "to-lower A" + (hk-ord (hk-to-lower (integer->char 65))) + 97) +(hk-test + "digit-to-int 0" + (hk-digit-to-int (integer->char 48)) + 0) +(hk-test + "digit-to-int 9" + (hk-digit-to-int (integer->char 57)) + 9) +(hk-test + "digit-to-int a" + (hk-digit-to-int (integer->char 97)) + 10) +(hk-test + "digit-to-int F" + (hk-digit-to-int (integer->char 70)) + 15) +(hk-test "int-to-digit 0" (hk-ord (hk-int-to-digit 0)) 48) +(hk-test "int-to-digit 10" (hk-ord (hk-int-to-digit 10)) 97) + +;; --------------------------------------------------------------------------- +;; 5. Data.Set +;; --------------------------------------------------------------------------- + +(hk-test "set-empty is set?" (hk-set? (hk-set-empty)) true) +(hk-test "set-null? empty" (hk-set-null? (hk-set-empty)) true) + +(let + ((s (hk-set-singleton 42))) + (do + (hk-test "singleton member" (hk-set-member? 42 s) true) + (hk-test "singleton size" (hk-set-size s) 1))) + +(let + ((s (hk-set-from-list (list 1 2 3)))) + (do + (hk-test "from-list member" (hk-set-member? 2 s) true) + (hk-test "from-list absent" (hk-set-member? 9 s) false) + (hk-test "from-list size" (hk-set-size s) 3))) + +;; --------------------------------------------------------------------------- +;; 6. Data.List +;; --------------------------------------------------------------------------- + +(hk-test "head" (hk-head (list 1 2 3)) 1) +(hk-test + "tail length" + (len (hk-tail (list 1 2 3))) + 2) +(hk-test "null? empty" (hk-null? (list)) true) +(hk-test "null? non-empty" (hk-null? (list 1)) false) +(hk-test + "length" + (hk-length (list 1 2 3)) + 3) + +(hk-test + "take 2" + (hk-take 2 (list 1 2 3)) + (list 1 2)) +(hk-test "take 0" (hk-take 0 (list 1 2)) (list)) +(hk-test + "take overflow" + (hk-take 5 (list 1 2)) + (list 1 2)) +(hk-test + "drop 1" + (hk-drop 1 (list 1 2 3)) + (list 2 3)) +(hk-test + "drop 0" + (hk-drop 0 (list 1 2)) + (list 1 2)) + +(hk-test + "take-while" + (hk-take-while + (fn (x) (< x 3)) + (list 1 2 3 4)) + (list 1 2)) +(hk-test + "drop-while" + (hk-drop-while + (fn (x) (< x 3)) + (list 1 2 3 4)) + (list 3 4)) + +(hk-test + "zip" + (hk-zip (list 1 2) (list 3 4)) + (list (list 1 3) (list 2 4))) +(hk-test + "zip uneven" + (hk-zip + (list 1 2 3) + (list 4 5)) + (list (list 1 4) (list 2 5))) + +(hk-test + "zip-with +" + (hk-zip-with + + + (list 1 2 3) + (list 10 20 30)) + (list 11 22 33)) + +(hk-test + "unzip fst" + (first + (hk-unzip + (list (list 1 3) (list 2 4)))) + (list 1 2)) +(hk-test + "unzip snd" + (nth + (hk-unzip + (list (list 1 3) (list 2 4))) + 1) + (list 3 4)) + +(hk-test + "elem hit" + (hk-elem 2 (list 1 2 3)) + true) +(hk-test + "elem miss" + (hk-elem 9 (list 1 2 3)) + false) +(hk-test + "not-elem" + (hk-not-elem 9 (list 1 2 3)) + true) + +(hk-test + "nub" + (hk-nub (list 1 2 1 3 2)) + (list 1 2 3)) + +(hk-test + "sum" + (hk-sum (list 1 2 3 4)) + 10) +(hk-test + "product" + (hk-product (list 1 2 3 4)) + 24) +(hk-test + "maximum" + (hk-maximum (list 3 1 4 1 5)) + 5) +(hk-test + "minimum" + (hk-minimum (list 3 1 4 1 5)) + 1) + +(hk-test + "concat" + (hk-concat + (list (list 1 2) (list 3 4))) + (list 1 2 3 4)) +(hk-test + "concat-map" + (hk-concat-map + (fn (x) (list x (* x x))) + (list 1 2 3)) + (list 1 1 2 4 3 9)) + +(hk-test + "sort" + (hk-sort (list 3 1 4 1 5)) + (list 1 1 3 4 5)) +(hk-test + "replicate" + (hk-replicate 3 0) + (list 0 0 0)) +(hk-test "replicate 0" (hk-replicate 0 99) (list)) + +(hk-test + "intersperse" + (hk-intersperse 0 (list 1 2 3)) + (list 1 0 2 0 3)) +(hk-test + "intersperse 1" + (hk-intersperse 0 (list 1)) + (list 1)) +(hk-test "intersperse empty" (hk-intersperse 0 (list)) (list)) + +(hk-test + "span" + (hk-span + (fn (x) (< x 3)) + (list 1 2 3 4)) + (list (list 1 2) (list 3 4))) +(hk-test + "break" + (hk-break + (fn (x) (>= x 3)) + (list 1 2 3 4)) + (list (list 1 2) (list 3 4))) + +(hk-test + "foldl" + (hk-foldl + (fn (a b) (- a b)) + 10 + (list 1 2 3)) + 4) +(hk-test + "foldr" + (hk-foldr cons (list) (list 1 2 3)) + (list 1 2 3)) + +(hk-test + "scanl" + (hk-scanl + 0 (list 1 2 3)) + (list 0 1 3 6)) + +;; --------------------------------------------------------------------------- +;; 7. Maybe / Either +;; --------------------------------------------------------------------------- + +(hk-test "nothing is-nothing?" (hk-is-nothing? hk-nothing) true) +(hk-test "nothing is-just?" (hk-is-just? hk-nothing) false) +(hk-test "just is-just?" (hk-is-just? (hk-just 42)) true) +(hk-test "just is-nothing?" (hk-is-nothing? (hk-just 42)) false) +(hk-test "from-just" (hk-from-just (hk-just 99)) 99) +(hk-test + "from-maybe nothing" + (hk-from-maybe 0 hk-nothing) + 0) +(hk-test + "from-maybe just" + (hk-from-maybe 0 (hk-just 42)) + 42) +(hk-test + "maybe nothing" + (hk-maybe 0 (fn (x) (* x 2)) hk-nothing) + 0) +(hk-test + "maybe just" + (hk-maybe 0 (fn (x) (* x 2)) (hk-just 5)) + 10) + +(hk-test "left is-left?" (hk-is-left? (hk-left "e")) true) +(hk-test "right is-right?" (hk-is-right? (hk-right 42)) true) +(hk-test "from-right" (hk-from-right (hk-right 7)) 7) +(hk-test + "either left" + (hk-either (fn (x) (str "L" x)) (fn (x) (str "R" x)) (hk-left "err")) + "Lerr") +(hk-test + "either right" + (hk-either + (fn (x) (str "L" x)) + (fn (x) (str "R" x)) + (hk-right 42)) + "R42") + +;; --------------------------------------------------------------------------- +;; 8. Tuples +;; --------------------------------------------------------------------------- + +(hk-test "pair" (hk-pair 1 2) (list 1 2)) +(hk-test "fst" (hk-fst (hk-pair 3 4)) 3) +(hk-test "snd" (hk-snd (hk-pair 3 4)) 4) +(hk-test + "triple" + (hk-triple 1 2 3) + (list 1 2 3)) +(hk-test + "fst3" + (hk-fst3 (hk-triple 7 8 9)) + 7) +(hk-test + "thd3" + (hk-thd3 (hk-triple 7 8 9)) + 9) + +(hk-test "curry" ((hk-curry +) 3 4) 7) +(hk-test + "uncurry" + ((hk-uncurry (fn (a b) (* a b))) (list 3 4)) + 12) + +;; --------------------------------------------------------------------------- +;; 9. String helpers +;; --------------------------------------------------------------------------- + +(hk-test "words" (hk-words "hello world") (list "hello" "world")) +(hk-test "words leading ws" (hk-words " foo bar") (list "foo" "bar")) +(hk-test "words empty" (hk-words "") (list)) +(hk-test "unwords" (hk-unwords (list "a" "b" "c")) "a b c") +(hk-test "unwords single" (hk-unwords (list "x")) "x") + +(hk-test "lines" (hk-lines "a\nb\nc") (list "a" "b" "c")) +(hk-test "lines single" (hk-lines "hello") (list "hello")) +(hk-test "unlines" (hk-unlines (list "a" "b")) "a\nb\n") + +(hk-test "is-prefix-of yes" (hk-is-prefix-of "he" "hello") true) +(hk-test "is-prefix-of no" (hk-is-prefix-of "wo" "hello") false) +(hk-test "is-prefix-of eq" (hk-is-prefix-of "hi" "hi") true) +(hk-test "is-prefix-of empty" (hk-is-prefix-of "" "hi") true) + +(hk-test "is-suffix-of yes" (hk-is-suffix-of "lo" "hello") true) +(hk-test "is-suffix-of no" (hk-is-suffix-of "he" "hello") false) +(hk-test "is-suffix-of empty" (hk-is-suffix-of "" "hi") true) + +(hk-test "is-infix-of yes" (hk-is-infix-of "ell" "hello") true) +(hk-test "is-infix-of no" (hk-is-infix-of "xyz" "hello") false) +(hk-test "is-infix-of empty" (hk-is-infix-of "" "hello") true) + +;; --------------------------------------------------------------------------- +;; 10. Show +;; --------------------------------------------------------------------------- + +(hk-test "show nil" (hk-show nil) "Nothing") +(hk-test "show true" (hk-show true) "True") +(hk-test "show false" (hk-show false) "False") +(hk-test "show int" (hk-show 42) "42") +(hk-test "show string" (hk-show "hi") "\"hi\"") +(hk-test + "show list" + (hk-show (list 1 2 3)) + "[1,2,3]") +(hk-test "show empty list" (hk-show (list)) "[]") + +;; --------------------------------------------------------------------------- +;; Summary (required by test.sh — last expression is the return value) +;; --------------------------------------------------------------------------- + +(list hk-test-pass hk-test-fail) diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx index 1e22f874..752d2d0b 100644 --- a/lib/hyperscript/compiler.sx +++ b/lib/hyperscript/compiler.sx @@ -48,6 +48,15 @@ prop value)) (list (quote hs-query-all) (nth base-ast 1)))) + ((and (list? base-ast) (= (first base-ast) (quote query))) + (list + (quote dom-set-prop) + (list + (quote hs-named-target) + (nth base-ast 1) + (list (quote hs-query-first) (nth base-ast 1))) + prop + value)) ((and (list? base-ast) (= (first base-ast) dot-sym) (let ((inner (nth base-ast 1))) (and (list? inner) (= (first inner) (quote query)) (let ((s (nth inner 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) ".")))))) (let ((inner (nth base-ast 1)) @@ -146,6 +155,14 @@ (nth prop-ast 1) value) (list (quote set!) (hs-to-sx target) value)))))) + ((= th (quote query)) + (list + (quote hs-set-inner-html!) + (list + (quote hs-named-target) + (nth target 1) + (list (quote hs-query-first) (nth target 1))) + value)) (true (list (quote set!) (hs-to-sx target) value))))))) (define emit-on @@ -274,17 +291,33 @@ ((name (nth ast 1)) (rest-parts (rest (rest ast)))) (cond ((and (= (len ast) 4) (list? (nth ast 2)) (= (first (nth ast 2)) (quote dict))) - (list - (quote dom-dispatch) - (hs-to-sx (nth ast 3)) - name - (hs-to-sx (nth ast 2)))) + (let + ((tgt-ast (nth ast 3))) + (list + (quote dom-dispatch) + (if + (and (list? tgt-ast) (= (first tgt-ast) (quote query))) + (list + (quote hs-named-target) + (nth tgt-ast 1) + (list (quote hs-query-first) (nth tgt-ast 1))) + (hs-to-sx tgt-ast)) + name + (hs-to-sx (nth ast 2))))) ((= (len ast) 3) - (list - (quote dom-dispatch) - (hs-to-sx (nth ast 2)) - name - (list (quote dict) "sender" (quote me)))) + (let + ((tgt-ast (nth ast 2))) + (list + (quote dom-dispatch) + (if + (and (list? tgt-ast) (= (first tgt-ast) (quote query))) + (list + (quote hs-named-target) + (nth tgt-ast 1) + (list (quote hs-query-first) (nth tgt-ast 1))) + (hs-to-sx tgt-ast)) + name + (list (quote dict) "sender" (quote me))))) (true (list (quote dom-dispatch) @@ -706,6 +739,33 @@ (quote fn) (cons (quote me) (map make-symbol params)) (cons (quote do) (map hs-to-sx body))))))) + (define + hs-safe-obj + (fn + (obj-ast) + (if + (and (list? obj-ast) (= (first obj-ast) (quote ref))) + (list (quote host-global) (nth obj-ast 1)) + (if + (and (list? obj-ast) (= (first obj-ast) dot-sym)) + (let + ((inner (nth obj-ast 1)) (prop (nth obj-ast 2))) + (list (quote host-get) (hs-safe-obj inner) prop)) + (hs-to-sx obj-ast))))) + (define + hs-chain-name + (fn + (obj-ast) + (if + (and (list? obj-ast) (= (first obj-ast) (quote ref))) + (nth obj-ast 1) + (if + (and (list? obj-ast) (= (first obj-ast) dot-sym)) + (str (hs-chain-name (nth obj-ast 1)) "." (nth obj-ast 2)) + (if + (and (list? obj-ast) (= (first obj-ast) (quote query))) + (nth obj-ast 1) + nil))))) (fn (ast) (cond @@ -1226,12 +1286,21 @@ (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list - (quote for-each) + (quote let) (list - (quote fn) - (list (quote _el)) - (list (quote dom-add-class) (quote _el) (nth ast 1))) - (list (quote hs-query-all) (nth raw-tgt 1))) + (list + (quote _tgt) + (list (quote hs-query-named-all) (nth raw-tgt 1)))) + (list + (quote for-each) + (list + (quote fn) + (list (quote _el)) + (list + (quote dom-add-class) + (quote _el) + (nth ast 1))) + (quote _tgt))) (list (quote dom-add-class) (hs-to-sx raw-tgt) @@ -1244,14 +1313,20 @@ (nth ast 2))) ((= head (quote set-styles)) (let - ((pairs (nth ast 1)) (tgt (hs-to-sx (nth ast 2)))) - (cons - (quote do) - (map - (fn - (p) - (list (quote dom-set-style) tgt (first p) (nth p 1))) - pairs)))) + ((pairs (nth ast 1)) (tgt-ast (nth ast 2))) + (let + ((tgt (if (and (list? tgt-ast) (= (first tgt-ast) (quote query))) (list (quote hs-named-target) (nth tgt-ast 1) (list (quote hs-query-first) (nth tgt-ast 1))) (hs-to-sx tgt-ast)))) + (cons + (quote do) + (map + (fn + (p) + (list + (quote dom-set-style) + tgt + (first p) + (nth p 1))) + pairs))))) ((= head (quote multi-add-class)) (let ((target (hs-to-sx (nth ast 1))) @@ -1349,15 +1424,21 @@ (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list - (quote for-each) + (quote let) (list - (quote fn) - (list (quote _el)) (list - (quote dom-remove-class) - (quote _el) - (nth ast 1))) - (list (quote hs-query-all) (nth raw-tgt 1))) + (quote _tgt) + (list (quote hs-query-named-all) (nth raw-tgt 1)))) + (list + (quote for-each) + (list + (quote fn) + (list (quote _el)) + (list + (quote dom-remove-class) + (quote _el) + (nth ast 1))) + (quote _tgt))) (list (quote dom-remove-class) (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) @@ -1401,15 +1482,32 @@ ((tgt (nth ast 3))) (list (quote hs-set-attr!) - (hs-to-sx tgt) + (if + (and (list? tgt) (= (first tgt) (quote query))) + (list + (quote hs-named-target) + (nth tgt 1) + (list (quote hs-query-first) (nth tgt 1))) + (hs-to-sx tgt)) (nth ast 1) (hs-to-sx (nth ast 2))))) ((= head (quote remove-value)) (let - ((val (hs-to-sx (nth ast 1))) (tgt (nth ast 2))) + ((val (hs-to-sx (nth ast 1))) (raw-tgt (nth ast 2))) (emit-set - tgt - (list (quote hs-remove-from!) val (hs-to-sx tgt))))) + raw-tgt + (list + (quote hs-remove-from!) + val + (if + (and + (list? raw-tgt) + (= (first raw-tgt) (quote query))) + (list + (quote hs-named-target) + (nth raw-tgt 1) + (list (quote hs-query-first) (nth raw-tgt 1))) + (hs-to-sx raw-tgt)))))) ((= head (quote empty-target)) (let ((tgt (nth ast 1))) @@ -1440,8 +1538,19 @@ (hs-to-sx (nth ast 2)))) ((= head (quote remove-attr)) (let - ((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2))))) - (list (quote dom-remove-attr) tgt (nth ast 1)))) + ((raw-tgt (nth ast 2))) + (list + (quote dom-remove-attr) + (if + (and + (list? raw-tgt) + (= (first raw-tgt) (quote query))) + (list + (quote hs-named-target) + (nth raw-tgt 1) + (list (quote hs-query-first) (nth raw-tgt 1))) + (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))) + (nth ast 1)))) ((= head (quote remove-css)) (let ((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2)))) @@ -1452,10 +1561,20 @@ (fn (p) (list (quote dom-set-style) tgt p "")) props)))) ((= head (quote toggle-class)) - (list - (quote hs-toggle-class!) - (hs-to-sx (nth ast 2)) - (nth ast 1))) + (let + ((tgt-ast (nth ast 2))) + (list + (quote hs-toggle-class!) + (if + (and + (list? tgt-ast) + (= (first tgt-ast) (quote query))) + (list + (quote hs-named-target) + (nth tgt-ast 1) + (list (quote hs-query-first) (nth tgt-ast 1))) + (hs-to-sx tgt-ast)) + (nth ast 1)))) ((= head (quote toggle-class-for)) (list (quote do) @@ -1510,11 +1629,21 @@ (hs-to-sx tgt-ast) (hs-to-sx val-ast))))) ((= head (quote toggle-between)) - (list - (quote hs-toggle-between!) - (hs-to-sx (nth ast 3)) - (nth ast 1) - (nth ast 2))) + (let + ((tgt-ast (nth ast 3))) + (list + (quote hs-toggle-between!) + (if + (and + (list? tgt-ast) + (= (first tgt-ast) (quote query))) + (list + (quote hs-named-target) + (nth tgt-ast 1) + (list (quote hs-query-first) (nth tgt-ast 1))) + (hs-to-sx tgt-ast)) + (nth ast 1) + (nth ast 2)))) ((= head (quote toggle-style)) (let ((raw-tgt (nth ast 2))) @@ -1538,10 +1667,20 @@ (quote list) (map hs-to-sx (slice ast 3 (len ast)))))) ((= head (quote toggle-attr)) - (list - (quote hs-toggle-attr!) - (hs-to-sx (nth ast 2)) - (nth ast 1))) + (let + ((tgt-ast (nth ast 2))) + (list + (quote hs-toggle-attr!) + (if + (and + (list? tgt-ast) + (= (first tgt-ast) (quote query))) + (list + (quote hs-named-target) + (nth tgt-ast 1) + (list (quote hs-query-first) (nth tgt-ast 1))) + (hs-to-sx tgt-ast)) + (nth ast 1)))) ((= head (quote toggle-attr-between)) (list (quote hs-toggle-attr-between!) @@ -1575,7 +1714,22 @@ (emit-set raw-tgt (list (quote hs-put-at!) val pos (hs-to-sx raw-tgt)))) - (true (list (quote hs-put!) val pos (hs-to-sx raw-tgt)))))) + (true + (let + ((tgt-ast raw-tgt)) + (list + (quote hs-put!) + val + pos + (if + (and + (list? tgt-ast) + (= (first tgt-ast) (quote query))) + (list + (quote hs-named-target) + (nth tgt-ast 1) + (list (quote hs-query-first) (nth tgt-ast 1))) + (hs-to-sx tgt-ast)))))))) ((= head (quote if)) (if (> (len ast) 3) @@ -1651,12 +1805,22 @@ (detail (if (= (len ast) 4) (nth ast 2) nil))) (list (quote dom-dispatch) - (hs-to-sx tgt) + (let + ((tgt-ast tgt)) + (if + (and + (list? tgt-ast) + (= (first tgt-ast) (quote query))) + (list + (quote hs-named-target) + (nth tgt-ast 1) + (list (quote hs-query-first) (nth tgt-ast 1))) + (hs-to-sx tgt-ast))) name (if has-detail (hs-to-sx detail) nil)))) ((= head (quote hide)) (let - ((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt)))) + ((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-named-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt)))) (strategy (if (> (len ast) 2) (nth ast 2) "display")) (when-cond (if (> (len ast) 3) (nth ast 3) nil))) (if @@ -1672,7 +1836,7 @@ (hs-to-sx when-cond)))))) ((= head (quote show)) (let - ((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt)))) + ((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-named-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt)))) (strategy (if (> (len ast) 2) (nth ast 2) "display")) (when-cond (if (> (len ast) 3) (nth ast 3) nil))) (if @@ -1735,13 +1899,28 @@ ((= head (quote call)) (let ((raw-fn (nth ast 1)) - (fn-expr - (if - (string? raw-fn) - (make-symbol raw-fn) - (hs-to-sx raw-fn))) (args (map hs-to-sx (rest (rest ast))))) - (cons fn-expr args))) + (if + (and (list? raw-fn) (= (first raw-fn) (quote ref))) + (let + ((name (nth raw-fn 1))) + (list + (quote let) + (list + (list + (quote __hs-fn) + (list (quote host-global) name))) + (cons + (quote do) + (list + (list + (quote if) + (list (quote nil?) (quote __hs-fn)) + (list (quote raise) (str "'" name "' is null")) + (cons (quote __hs-fn) args)))))) + (let + ((fn-expr (if (string? raw-fn) (make-symbol raw-fn) (hs-to-sx raw-fn)))) + (cons fn-expr args))))) ((= head (quote return)) (let ((val (nth ast 1))) @@ -1754,7 +1933,22 @@ ((= head (quote throw)) (list (quote raise) (hs-to-sx (nth ast 1)))) ((= head (quote settle)) - (list (quote hs-settle) (quote me))) + (let + ((raw-tgt (nth ast 1))) + (list + (quote hs-settle) + (if + (nil? raw-tgt) + (quote me) + (if + (and + (list? raw-tgt) + (= (first raw-tgt) (quote query))) + (list + (quote hs-named-target) + (nth raw-tgt 1) + (list (quote hs-query-first) (nth raw-tgt 1))) + (hs-to-sx raw-tgt)))))) ((= head (quote go)) (list (quote hs-navigate!) (hs-to-sx (nth ast 1)))) ((= head (quote ask)) @@ -1874,7 +2068,11 @@ ((= head (quote install)) (cons (quote hs-install) (map hs-to-sx (rest ast)))) ((= head (quote measure)) - (list (quote hs-measure) (hs-to-sx (nth ast 1)))) + (let + ((raw-tgt (nth ast 1))) + (let + ((compiled-tgt (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-named-target) (nth raw-tgt 1) (list (quote hs-query-first) (nth raw-tgt 1))) (hs-to-sx raw-tgt)))) + (list (quote hs-measure) compiled-tgt)))) ((= head (quote increment!)) (if (= (len ast) 3) diff --git a/lib/hyperscript/parser.sx b/lib/hyperscript/parser.sx index 6dfdaa60..77281af5 100644 --- a/lib/hyperscript/parser.sx +++ b/lib/hyperscript/parser.sx @@ -2455,7 +2455,16 @@ ((and (= typ "keyword") (= val "answer")) (do (adv!) (parse-answer-cmd))) ((and (= typ "keyword") (= val "settle")) - (do (adv!) (list (quote settle)))) + (do + (adv!) + (if + (or + (at-end?) + (and + (= (tp-type) "keyword") + (or (= (tp-val) "then") (= (tp-val) "end")))) + (list (quote settle)) + (list (quote settle) (parse-expr))))) ((and (= typ "keyword") (= val "go")) (do (adv!) (parse-go-cmd))) ((and (= typ "keyword") (= val "return")) diff --git a/lib/hyperscript/runtime.sx b/lib/hyperscript/runtime.sx index bcfce8cb..dcea9836 100644 --- a/lib/hyperscript/runtime.sx +++ b/lib/hyperscript/runtime.sx @@ -12,37 +12,14 @@ ;; Register an event listener. Returns unlisten function. ;; (hs-on target event-name handler) → unlisten-fn -(begin - (define _hs-config-log-all false) - (define _hs-log-captured (list)) - (define - hs-set-log-all! - (fn (flag) (set! _hs-config-log-all (if flag true false)))) - (define hs-get-log-captured (fn () _hs-log-captured)) - (define - hs-clear-log-captured! - (fn () (begin (set! _hs-log-captured (list)) nil))) - (define - hs-log-event! - (fn - (msg) - (when - _hs-config-log-all - (begin - (set! _hs-log-captured (append _hs-log-captured (list msg))) - (host-call (host-global "console") "log" msg) - nil))))) - -;; Register for every occurrence (no queuing — each fires independently). -;; Stock hyperscript queues by default; "every" disables queuing. (define hs-each (fn (target action) (if (list? target) (for-each action target) (action target)))) -;; Run an initializer function immediately. -;; (hs-init thunk) — called at element boot time +;; Register for every occurrence (no queuing — each fires independently). +;; Stock hyperscript queues by default; "every" disables queuing. (define hs-on (fn @@ -55,17 +32,17 @@ (dom-set-data target "hs-unlisteners" (append prev (list unlisten))) unlisten)))) +;; Run an initializer function immediately. +;; (hs-init thunk) — called at element boot time +(define + hs-on-every + (fn (target event-name handler) (dom-listen target event-name handler))) + ;; ── Async / timing ────────────────────────────────────────────── ;; Wait for a duration in milliseconds. ;; In hyperscript, wait is async-transparent — execution pauses. ;; Here we use perform/IO suspension for true pause semantics. -(define - hs-on-every - (fn (target event-name handler) (dom-listen target event-name handler))) - -;; Wait for a DOM event on a target. -;; (hs-wait-for target event-name) — suspends until event fires (define hs-on-intersection-attach! (fn @@ -81,15 +58,16 @@ (host-call observer "observe" target) observer))))) -;; Wait for CSS transitions/animations to settle on an element. +;; Wait for a DOM event on a target. +;; (hs-wait-for target event-name) — suspends until event fires (define hs-init (fn (thunk) (thunk))) +;; Wait for CSS transitions/animations to settle on an element. +(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) + ;; ── Class manipulation ────────────────────────────────────────── ;; Toggle a single class on an element. -(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) - -;; Toggle between two classes — exactly one is active at a time. (begin (define hs-wait-for @@ -102,21 +80,19 @@ (target event-name timeout-ms) (perform (list (quote io-wait-event) target event-name timeout-ms))))) +;; Toggle between two classes — exactly one is active at a time. +(define hs-settle (fn (target) (perform (list (quote io-settle) target)))) + ;; Take a class from siblings — add to target, remove from others. ;; (hs-take! target cls) — like radio button class behavior -(define hs-settle (fn (target) (perform (list (quote io-settle) target)))) +(define + hs-toggle-class! + (fn (target cls) (host-call (host-get target "classList") "toggle" cls))) ;; ── DOM insertion ─────────────────────────────────────────────── ;; Put content at a position relative to a target. ;; pos: "into" | "before" | "after" -(define - hs-toggle-class! - (fn (target cls) (host-call (host-get target "classList") "toggle" cls))) - -;; ── Navigation / traversal ────────────────────────────────────── - -;; Navigate to a URL. (define hs-toggle-between! (fn @@ -126,7 +102,9 @@ (do (dom-remove-class target cls1) (dom-add-class target cls2)) (do (dom-remove-class target cls2) (dom-add-class target cls1))))) -;; Find next sibling matching a selector (or any sibling). +;; ── Navigation / traversal ────────────────────────────────────── + +;; Navigate to a URL. (define hs-toggle-style! (fn @@ -150,7 +128,7 @@ (dom-set-style target prop "hidden") (dom-set-style target prop ""))))))) -;; Find previous sibling matching a selector. +;; Find next sibling matching a selector (or any sibling). (define hs-toggle-style-between! (fn @@ -162,7 +140,7 @@ (dom-set-style target prop val2) (dom-set-style target prop val1))))) -;; First element matching selector within a scope. +;; Find previous sibling matching a selector. (define hs-toggle-style-cycle! (fn @@ -183,7 +161,7 @@ (true (find-next (rest remaining)))))) (dom-set-style target prop (find-next vals))))) -;; Last element matching selector. +;; First element matching selector within a scope. (define hs-take! (fn @@ -206,7 +184,8 @@ (when with-cls (dom-remove-class target with-cls)))) (let ((attr-val (if (> (len extra) 0) (first extra) nil)) - (with-val (if (> (len extra) 1) (nth extra 1) nil))) + (with-val + (if (> (len extra) 1) (nth extra 1) nil))) (do (for-each (fn @@ -223,7 +202,7 @@ (dom-set-attr target name attr-val) (dom-set-attr target name "")))))))) -;; First/last within a specific scope. +;; Last element matching selector. (begin (define hs-element? @@ -335,6 +314,7 @@ (dom-insert-adjacent-html target "beforeend" value) (hs-boot-subtree! target))))))))) +;; First/last within a specific scope. (define hs-add-to! (fn @@ -347,9 +327,6 @@ (append target (list value)))) (true (do (host-call target "push" value) target))))) -;; ── Iteration ─────────────────────────────────────────────────── - -;; Repeat a thunk N times. (define hs-remove-from! (fn @@ -357,9 +334,15 @@ (if (list? target) (filter (fn (x) (not (= x value))) target) - (host-call target "splice" (host-call target "indexOf" value) 1)))) + (host-call + target + "splice" + (host-call target "indexOf" value) + 1)))) -;; Repeat forever (until break — relies on exception/continuation). +;; ── Iteration ─────────────────────────────────────────────────── + +;; Repeat a thunk N times. (define hs-splice-at! (fn @@ -372,7 +355,10 @@ ((i (if (< idx 0) (+ n idx) idx))) (cond ((or (< i 0) (>= i n)) target) - (true (concat (slice target 0 i) (slice target (+ i 1) n)))))) + (true + (concat + (slice target 0 i) + (slice target (+ i 1) n)))))) (do (when target @@ -383,10 +369,7 @@ (host-call target "splice" i 1)))) target)))) -;; ── Fetch ─────────────────────────────────────────────────────── - -;; Fetch a URL, parse response according to format. -;; (hs-fetch url format) — format is "json" | "text" | "html" +;; Repeat forever (until break — relies on exception/continuation). (define hs-index (fn @@ -398,10 +381,10 @@ ((string? obj) (nth obj key)) (true (host-get obj key))))) -;; ── Type coercion ─────────────────────────────────────────────── +;; ── Fetch ─────────────────────────────────────────────────────── -;; Coerce a value to a type by name. -;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. +;; Fetch a URL, parse response according to format. +;; (hs-fetch url format) — format is "json" | "text" | "html" (define hs-put-at! (fn @@ -423,10 +406,10 @@ ((= pos "start") (host-call target "unshift" value))) target))))))) -;; ── Object creation ───────────────────────────────────────────── +;; ── Type coercion ─────────────────────────────────────────────── -;; Make a new object of a given type. -;; (hs-make type-name) — creates empty object/collection +;; Coerce a value to a type by name. +;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. (define hs-dict-without (fn @@ -447,27 +430,27 @@ (host-call (host-global "Reflect") "deleteProperty" out key) out))))) -;; ── Behavior installation ─────────────────────────────────────── +;; ── Object creation ───────────────────────────────────────────── -;; Install a behavior on an element. -;; A behavior is a function that takes (me ...params) and sets up features. -;; (hs-install behavior-fn me ...args) +;; Make a new object of a given type. +;; (hs-make type-name) — creates empty object/collection (define hs-set-on! (fn (props target) (for-each (fn (k) (host-set! target k (get props k))) (keys props)))) +;; ── Behavior installation ─────────────────────────────────────── + +;; Install a behavior on an element. +;; A behavior is a function that takes (me ...params) and sets up features. +;; (hs-install behavior-fn me ...args) +(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url)))) + ;; ── Measurement ───────────────────────────────────────────────── ;; Measure an element's bounding rect, store as local variables. ;; Returns a dict with x, y, width, height, top, left, right, bottom. -(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url)))) - -;; Return the current text selection as a string. In the browser this is -;; `window.getSelection().toString()`. In the mock test runner, a test -;; setup stashes the desired selection text at `window.__test_selection` -;; and the fallback path returns that so tests can assert on the result. (define hs-ask (fn @@ -476,11 +459,10 @@ ((w (host-global "window"))) (if w (host-call w "prompt" msg) nil)))) - -;; ── Transition ────────────────────────────────────────────────── - -;; Transition a CSS property to a value, optionally with duration. -;; (hs-transition target prop value duration) +;; Return the current text selection as a string. In the browser this is +;; `window.getSelection().toString()`. In the mock test runner, a test +;; setup stashes the desired selection text at `window.__test_selection` +;; and the fallback path returns that so tests can assert on the result. (define hs-answer (fn @@ -489,6 +471,11 @@ ((w (host-global "window"))) (if w (if (host-call w "confirm" msg) yes-val no-val) no-val)))) + +;; ── Transition ────────────────────────────────────────────────── + +;; Transition a CSS property to a value, optionally with duration. +;; (hs-transition target prop value duration) (define hs-answer-alert (fn @@ -643,25 +630,25 @@ (hs-query-all sel) (host-call target "querySelectorAll" sel)))) - - - - (define hs-list-set (fn (lst idx val) (append (take lst idx) (cons val (drop lst (+ idx 1)))))) + + + + (define hs-to-number (fn (v) (if (number? v) v (or (parse-number (str v)) 0)))) -;; ── Sandbox/test runtime additions ────────────────────────────── -;; Property access — dot notation and .length + (define hs-query-first (fn (sel) (host-call (host-global "document") "querySelector" sel))) -;; DOM query stub — sandbox returns empty list +;; ── Sandbox/test runtime additions ────────────────────────────── +;; Property access — dot notation and .length (define hs-query-last (fn @@ -669,11 +656,9 @@ (let ((all (dom-query-all (dom-body) sel))) (if (> (len all) 0) (nth all (- (len all) 1)) nil)))) -;; Method dispatch — obj.method(args) +;; DOM query stub — sandbox returns empty list (define hs-first (fn (scope sel) (dom-query-all scope sel))) - -;; ── 0.9.90 features ───────────────────────────────────────────── -;; beep! — debug logging, returns value unchanged +;; Method dispatch — obj.method(args) (define hs-last (fn @@ -681,7 +666,9 @@ (let ((all (dom-query-all scope sel))) (if (> (len all) 0) (nth all (- (len all) 1)) nil)))) -;; Property-based is — check obj.key truthiness + +;; ── 0.9.90 features ───────────────────────────────────────────── +;; beep! — debug logging, returns value unchanged (define hs-repeat-times (fn @@ -699,7 +686,7 @@ ((= signal "hs-continue") (do-repeat (+ i 1))) (true (do-repeat (+ i 1)))))))) (do-repeat 0))) -;; Array slicing (inclusive both ends) +;; Property-based is — check obj.key truthiness (define hs-repeat-forever (fn @@ -715,7 +702,7 @@ ((= signal "hs-continue") (do-forever)) (true (do-forever)))))) (do-forever))) -;; Collection: sorted by +;; Array slicing (inclusive both ends) (define hs-repeat-while (fn @@ -728,7 +715,7 @@ ((= signal "hs-break") nil) ((= signal "hs-continue") (hs-repeat-while cond-fn thunk)) (true (hs-repeat-while cond-fn thunk))))))) -;; Collection: sorted by descending +;; Collection: sorted by (define hs-repeat-until (fn @@ -740,7 +727,7 @@ ((= signal "hs-continue") (if (cond-fn) nil (hs-repeat-until cond-fn thunk))) (true (if (cond-fn) nil (hs-repeat-until cond-fn thunk))))))) -;; Collection: split by +;; Collection: sorted by descending (define hs-for-each (fn @@ -760,7 +747,7 @@ ((= signal "hs-continue") (do-loop (rest remaining))) (true (do-loop (rest remaining)))))))) (do-loop items)))) -;; Collection: joined by +;; Collection: split by (begin (define hs-append @@ -788,7 +775,7 @@ ((hs-element? target) (dom-insert-adjacent-html target "beforeend" (str value))) (true nil))))) - +;; Collection: joined by (define hs-sender (fn @@ -1310,10 +1297,14 @@ ((ch (substring sel i (+ i 1)))) (cond ((= ch ".") - (do (flush!) (set! mode "class") (walk (+ i 1)))) + (do + (flush!) + (set! mode "class") + (walk (+ i 1)))) ((= ch "#") (do (flush!) (set! mode "id") (walk (+ i 1)))) - (true (do (set! cur (str cur ch)) (walk (+ i 1))))))))) + (true + (do (set! cur (str cur ch)) (walk (+ i 1))))))))) (walk 0) (flush!) {:tag tag :classes classes :id id})))) @@ -1398,6 +1389,7 @@ hs-strict-eq (fn (a b) (and (= (type-of a) (type-of b)) (= a b)))) + (define hs-eq-ignore-case (fn (a b) (= (downcase (str a)) (downcase (str b))))) @@ -1438,7 +1430,10 @@ ((and (dict? a) (dict? b)) (let ((pos (host-call a "compareDocumentPosition" b))) - (if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false))) + (if + (number? pos) + (not (= 0 (mod (/ pos 4) 2))) + false))) (true (< (str a) (str b)))))) (define @@ -1540,7 +1535,10 @@ ((and (dict? a) (dict? b)) (let ((pos (host-call a "compareDocumentPosition" b))) - (if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false))) + (if + (number? pos) + (not (= 0 (mod (/ pos 4) 2))) + false))) (true (< (str a) (str b)))))) (define @@ -1591,7 +1589,9 @@ (define hs-morph-char - (fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p)))) + (fn + (s p) + (if (or (< p 0) (>= p (string-length s))) nil (nth s p)))) (define hs-morph-index-from @@ -1619,7 +1619,10 @@ (q) (let ((c (hs-morph-char s q))) - (if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q)))) + (if + (and c (< (index-of stop c) 0)) + (loop (+ q 1)) + q)))) (let ((e (loop p))) (list (substring s p e) e)))) (define @@ -1661,7 +1664,9 @@ (append acc (list - (list name (substring s (+ p4 1) close))))))) + (list + name + (substring s (+ p4 1) close))))))) ((= c2 "'") (let ((close (hs-morph-index-from s "'" (+ p4 1)))) @@ -1671,7 +1676,9 @@ (append acc (list - (list name (substring s (+ p4 1) close))))))) + (list + name + (substring s (+ p4 1) close))))))) (true (let ((r2 (hs-morph-read-until s p4 " \t\n/>"))) @@ -1755,7 +1762,9 @@ (for-each (fn (c) - (when (> (string-length c) 0) (dom-add-class el c))) + (when + (> (string-length c) 0) + (dom-add-class el c))) (split v " "))) ((and keep-id (= n "id")) nil) (true (dom-set-attr el n v))))) @@ -1856,7 +1865,8 @@ ((parts (split resolved ":"))) (let ((prop (first parts)) - (val (if (> (len parts) 1) (nth parts 1) nil))) + (val + (if (> (len parts) 1) (nth parts 1) nil))) (cond ((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop)) (let @@ -1895,7 +1905,8 @@ ((parts (split resolved ":"))) (let ((prop (first parts)) - (val (if (> (len parts) 1) (nth parts 1) nil))) + (val + (if (> (len parts) 1) (nth parts 1) nil))) (cond ((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop)) (let @@ -1999,10 +2010,14 @@ (if (= depth 1) j - (find-close (+ j 1) (- depth 1))) + (find-close + (+ j 1) + (- depth 1))) (if (= (nth raw j) "{") - (find-close (+ j 1) (+ depth 1)) + (find-close + (+ j 1) + (+ depth 1)) (find-close (+ j 1) depth)))))) (let ((close (find-close start 1))) @@ -2093,7 +2108,10 @@ (if (= (len lst) 0) -1 - (if (= (first lst) item) i (idx-loop (rest lst) (+ i 1)))))) + (if + (= (first lst) item) + i + (idx-loop (rest lst) (+ i 1)))))) (idx-loop obj 0))) (true nil)))) @@ -2179,7 +2197,8 @@ (cond ((= end "hs-pick-end") n) ((= end "hs-pick-start") 0) - ((and (number? end) (< end 0)) (max 0 (+ n end))) + ((and (number? end) (< end 0)) + (max 0 (+ n end))) (true end)))) (cond ((string? col) (slice col s e)) @@ -2466,6 +2485,50 @@ ((nth entry 2) val))) _hs-dom-watchers))) +(define hs-prolog-hook nil) + +(define hs-set-prolog-hook! (fn (f) (set! hs-prolog-hook f))) + +(define + prolog + (fn + (db goal) + (if + (nil? hs-prolog-hook) + (raise "prolog hook not installed") + (hs-prolog-hook db goal)))) + +(define + hs-null-error! + (fn (selector) (raise (str "'" selector "' is null")))) + +(define + hs-named-target + (fn (selector value) (if (nil? value) (hs-null-error! selector) value))) + +(define + hs-named-target-list + (fn + (selector values) + (if (nil? values) (hs-null-error! selector) values))) + +(define + hs-query-named-all + (fn + (selector) + (let + ((results (hs-query-all selector))) + (if + (and + (or + (nil? results) + (and (list? results) (= (len results) 0))) + (string? selector) + (> (len selector) 0) + (= (substring selector 0 1) "#")) + (hs-null-error! selector) + results)))) + (define hs-dom-is-ancestor? (fn diff --git a/lib/js/conformance.sh b/lib/js/conformance.sh index c6f91502..b181e9ad 100755 --- a/lib/js/conformance.sh +++ b/lib/js/conformance.sh @@ -49,6 +49,8 @@ trap "rm -f $TMPFILE" EXIT echo '(load "lib/js/transpile.sx")' echo '(epoch 5)' echo '(load "lib/js/runtime.sx")' + echo '(epoch 6)' + echo '(load "lib/js/regex.sx")' epoch=100 for f in "${FIXTURES[@]}"; do diff --git a/lib/js/regex.sx b/lib/js/regex.sx new file mode 100644 index 00000000..c56957ca --- /dev/null +++ b/lib/js/regex.sx @@ -0,0 +1,943 @@ +;; lib/js/regex.sx — pure-SX recursive backtracking regex engine +;; +;; Installed via (js-regex-platform-override! ...) at load time. +;; Covers: character classes (\d\w\s . [abc] [^abc] [a-z]), +;; anchors (^ $ \b \B), quantifiers (* + ? {n,m} lazy variants), +;; groups (capturing + non-capturing), alternation (a|b), +;; flags: i (case-insensitive), g (global), m (multiline). +;; +;; Architecture: +;; 1. rx-parse-pattern — pattern string → compiled node list +;; 2. rx-match-nodes — recursive backtracker +;; 3. rx-exec / rx-test — public interface +;; 4. Install as {:test rx-test :exec rx-exec} + +;; ── Utilities ───────────────────────────────────────────────────── + +(define + rx-char-at + (fn (s i) (if (and (>= i 0) (< i (len s))) (char-at s i) ""))) + +(define + rx-digit? + (fn + (c) + (and (not (= c "")) (>= (char-code c) 48) (<= (char-code c) 57)))) + +(define + rx-word? + (fn + (c) + (and + (not (= c "")) + (or + (and (>= (char-code c) 65) (<= (char-code c) 90)) + (and (>= (char-code c) 97) (<= (char-code c) 122)) + (and (>= (char-code c) 48) (<= (char-code c) 57)) + (= c "_"))))) + +(define + rx-space? + (fn + (c) + (or (= c " ") (= c "\t") (= c "\n") (= c "\r") (= c "\\f") (= c "")))) + +(define rx-newline? (fn (c) (or (= c "\n") (= c "\r")))) + +(define + rx-downcase-char + (fn + (c) + (let + ((cc (char-code c))) + (if (and (>= cc 65) (<= cc 90)) (char-from-code (+ cc 32)) c)))) + +(define + rx-char-eq? + (fn + (a b ci?) + (if ci? (= (rx-downcase-char a) (rx-downcase-char b)) (= a b)))) + +(define + rx-parse-int + (fn + (pat i acc) + (let + ((c (rx-char-at pat i))) + (if + (rx-digit? c) + (rx-parse-int pat (+ i 1) (+ (* acc 10) (- (char-code c) 48))) + (list acc i))))) + +(define + rx-hex-digit-val + (fn + (c) + (cond + ((and (>= (char-code c) 48) (<= (char-code c) 57)) + (- (char-code c) 48)) + ((and (>= (char-code c) 65) (<= (char-code c) 70)) + (+ 10 (- (char-code c) 65))) + ((and (>= (char-code c) 97) (<= (char-code c) 102)) + (+ 10 (- (char-code c) 97))) + (else -1)))) + +(define + rx-parse-hex-n + (fn + (pat i n acc) + (if + (= n 0) + (list (char-from-code acc) i) + (let + ((v (rx-hex-digit-val (rx-char-at pat i)))) + (if + (< v 0) + (list (char-from-code acc) i) + (rx-parse-hex-n pat (+ i 1) (- n 1) (+ (* acc 16) v))))))) + +;; ── Pattern compiler ────────────────────────────────────────────── + +;; Node types (stored in dicts with "__t__" key): +;; literal : {:__t__ "literal" :__c__ char} +;; any : {:__t__ "any"} +;; class-d : {:__t__ "class-d" :__neg__ bool} +;; class-w : {:__t__ "class-w" :__neg__ bool} +;; class-s : {:__t__ "class-s" :__neg__ bool} +;; char-class: {:__t__ "char-class" :__neg__ bool :__items__ list} +;; anchor-start / anchor-end / anchor-word / anchor-nonword +;; quant : {:__t__ "quant" :__node__ n :__min__ m :__max__ mx :__lazy__ bool} +;; group : {:__t__ "group" :__idx__ i :__nodes__ list} +;; ncgroup : {:__t__ "ncgroup" :__nodes__ list} +;; alt : {:__t__ "alt" :__branches__ list-of-node-lists} + +;; parse one escape after `\`, returns (node new-i) +(define + rx-parse-escape + (fn + (pat i) + (let + ((c (rx-char-at pat i))) + (cond + ((= c "d") (list (dict "__t__" "class-d" "__neg__" false) (+ i 1))) + ((= c "D") (list (dict "__t__" "class-d" "__neg__" true) (+ i 1))) + ((= c "w") (list (dict "__t__" "class-w" "__neg__" false) (+ i 1))) + ((= c "W") (list (dict "__t__" "class-w" "__neg__" true) (+ i 1))) + ((= c "s") (list (dict "__t__" "class-s" "__neg__" false) (+ i 1))) + ((= c "S") (list (dict "__t__" "class-s" "__neg__" true) (+ i 1))) + ((= c "b") (list (dict "__t__" "anchor-word") (+ i 1))) + ((= c "B") (list (dict "__t__" "anchor-nonword") (+ i 1))) + ((= c "n") (list (dict "__t__" "literal" "__c__" "\n") (+ i 1))) + ((= c "r") (list (dict "__t__" "literal" "__c__" "\r") (+ i 1))) + ((= c "t") (list (dict "__t__" "literal" "__c__" "\t") (+ i 1))) + ((= c "f") (list (dict "__t__" "literal" "__c__" "\\f") (+ i 1))) + ((= c "v") (list (dict "__t__" "literal" "__c__" "") (+ i 1))) + ((= c "u") + (let + ((res (rx-parse-hex-n pat (+ i 1) 4 0))) + (list (dict "__t__" "literal" "__c__" (nth res 0)) (nth res 1)))) + ((= c "x") + (let + ((res (rx-parse-hex-n pat (+ i 1) 2 0))) + (list (dict "__t__" "literal" "__c__" (nth res 0)) (nth res 1)))) + (else (list (dict "__t__" "literal" "__c__" c) (+ i 1))))))) + +;; parse a char-class item inside [...], returns (item new-i) +(define + rx-parse-class-item + (fn + (pat i) + (let + ((c (rx-char-at pat i))) + (cond + ((= c "\\") + (let + ((esc (rx-parse-escape pat (+ i 1)))) + (let + ((node (nth esc 0)) (ni (nth esc 1))) + (let + ((t (get node "__t__"))) + (cond + ((= t "class-d") + (list + (dict "kind" "class-d" "neg" (get node "__neg__")) + ni)) + ((= t "class-w") + (list + (dict "kind" "class-w" "neg" (get node "__neg__")) + ni)) + ((= t "class-s") + (list + (dict "kind" "class-s" "neg" (get node "__neg__")) + ni)) + (else + (let + ((lc (get node "__c__"))) + (if + (and + (= (rx-char-at pat ni) "-") + (not (= (rx-char-at pat (+ ni 1)) "]"))) + (let + ((hi-c (rx-char-at pat (+ ni 1)))) + (list + (dict "kind" "range" "lo" lc "hi" hi-c) + (+ ni 2))) + (list (dict "kind" "lit" "c" lc) ni))))))))) + (else + (if + (and + (not (= c "")) + (= (rx-char-at pat (+ i 1)) "-") + (not (= (rx-char-at pat (+ i 2)) "]")) + (not (= (rx-char-at pat (+ i 2)) ""))) + (let + ((hi-c (rx-char-at pat (+ i 2)))) + (list (dict "kind" "range" "lo" c "hi" hi-c) (+ i 3))) + (list (dict "kind" "lit" "c" c) (+ i 1)))))))) + +(define + rx-parse-class-items + (fn + (pat i items) + (let + ((c (rx-char-at pat i))) + (if + (or (= c "]") (= c "")) + (list items i) + (let + ((res (rx-parse-class-item pat i))) + (begin + (append! items (nth res 0)) + (rx-parse-class-items pat (nth res 1) items))))))) + +;; parse a sequence until stop-ch or EOF; returns (nodes new-i groups-count) +(define + rx-parse-seq + (fn + (pat i stop-ch ds) + (let + ((c (rx-char-at pat i))) + (cond + ((= c "") (list (get ds "nodes") i (get ds "groups"))) + ((= c stop-ch) (list (get ds "nodes") i (get ds "groups"))) + ((= c "|") (rx-parse-alt-rest pat i ds)) + (else + (let + ((res (rx-parse-atom pat i ds))) + (let + ((node (nth res 0)) (ni (nth res 1)) (ds2 (nth res 2))) + (let + ((qres (rx-parse-quant pat ni node))) + (begin + (append! (get ds2 "nodes") (nth qres 0)) + (rx-parse-seq pat (nth qres 1) stop-ch ds2)))))))))) + +;; when we hit | inside a sequence, collect all alternatives +(define + rx-parse-alt-rest + (fn + (pat i ds) + (let + ((left-branch (get ds "nodes")) (branches (list))) + (begin + (append! branches left-branch) + (rx-parse-alt-branches pat i (get ds "groups") branches))))) + +(define + rx-parse-alt-branches + (fn + (pat i n-groups branches) + (let + ((new-nodes (list)) (ds2 (dict "groups" n-groups "nodes" new-nodes))) + (let + ((res (rx-parse-seq pat (+ i 1) "|" ds2))) + (begin + (append! branches (nth res 0)) + (let + ((ni2 (nth res 1)) (g2 (nth res 2))) + (if + (= (rx-char-at pat ni2) "|") + (rx-parse-alt-branches pat ni2 g2 branches) + (list + (list (dict "__t__" "alt" "__branches__" branches)) + ni2 + g2)))))))) + +;; parse quantifier suffix, returns (node new-i) +(define + rx-parse-quant + (fn + (pat i node) + (let + ((c (rx-char-at pat i))) + (cond + ((= c "*") + (let + ((lazy? (= (rx-char-at pat (+ i 1)) "?"))) + (list + (dict + "__t__" + "quant" + "__node__" + node + "__min__" + 0 + "__max__" + -1 + "__lazy__" + lazy?) + (if lazy? (+ i 2) (+ i 1))))) + ((= c "+") + (let + ((lazy? (= (rx-char-at pat (+ i 1)) "?"))) + (list + (dict + "__t__" + "quant" + "__node__" + node + "__min__" + 1 + "__max__" + -1 + "__lazy__" + lazy?) + (if lazy? (+ i 2) (+ i 1))))) + ((= c "?") + (let + ((lazy? (= (rx-char-at pat (+ i 1)) "?"))) + (list + (dict + "__t__" + "quant" + "__node__" + node + "__min__" + 0 + "__max__" + 1 + "__lazy__" + lazy?) + (if lazy? (+ i 2) (+ i 1))))) + ((= c "{") + (let + ((mres (rx-parse-int pat (+ i 1) 0))) + (let + ((mn (nth mres 0)) (mi (nth mres 1))) + (let + ((sep (rx-char-at pat mi))) + (cond + ((= sep "}") + (let + ((lazy? (= (rx-char-at pat (+ mi 1)) "?"))) + (list + (dict + "__t__" + "quant" + "__node__" + node + "__min__" + mn + "__max__" + mn + "__lazy__" + lazy?) + (if lazy? (+ mi 2) (+ mi 1))))) + ((= sep ",") + (let + ((c2 (rx-char-at pat (+ mi 1)))) + (if + (= c2 "}") + (let + ((lazy? (= (rx-char-at pat (+ mi 2)) "?"))) + (list + (dict + "__t__" + "quant" + "__node__" + node + "__min__" + mn + "__max__" + -1 + "__lazy__" + lazy?) + (if lazy? (+ mi 3) (+ mi 2)))) + (let + ((mxres (rx-parse-int pat (+ mi 1) 0))) + (let + ((mx (nth mxres 0)) (mxi (nth mxres 1))) + (let + ((lazy? (= (rx-char-at pat (+ mxi 1)) "?"))) + (list + (dict + "__t__" + "quant" + "__node__" + node + "__min__" + mn + "__max__" + mx + "__lazy__" + lazy?) + (if lazy? (+ mxi 2) (+ mxi 1))))))))) + (else (list node i))))))) + (else (list node i)))))) + +;; parse one atom, returns (node new-i new-ds) +(define + rx-parse-atom + (fn + (pat i ds) + (let + ((c (rx-char-at pat i))) + (cond + ((= c ".") (list (dict "__t__" "any") (+ i 1) ds)) + ((= c "^") (list (dict "__t__" "anchor-start") (+ i 1) ds)) + ((= c "$") (list (dict "__t__" "anchor-end") (+ i 1) ds)) + ((= c "\\") + (let + ((esc (rx-parse-escape pat (+ i 1)))) + (list (nth esc 0) (nth esc 1) ds))) + ((= c "[") + (let + ((neg? (= (rx-char-at pat (+ i 1)) "^"))) + (let + ((start (if neg? (+ i 2) (+ i 1))) (items (list))) + (let + ((res (rx-parse-class-items pat start items))) + (let + ((ci (nth res 1))) + (list + (dict + "__t__" + "char-class" + "__neg__" + neg? + "__items__" + items) + (+ ci 1) + ds)))))) + ((= c "(") + (let + ((c2 (rx-char-at pat (+ i 1)))) + (if + (and (= c2 "?") (= (rx-char-at pat (+ i 2)) ":")) + (let + ((inner-nodes (list)) + (inner-ds + (dict "groups" (get ds "groups") "nodes" inner-nodes))) + (let + ((res (rx-parse-seq pat (+ i 3) ")" inner-ds))) + (list + (dict "__t__" "ncgroup" "__nodes__" (nth res 0)) + (+ (nth res 1) 1) + (dict "groups" (nth res 2) "nodes" (get ds "nodes"))))) + (let + ((gidx (+ (get ds "groups") 1)) (inner-nodes (list))) + (let + ((inner-ds (dict "groups" gidx "nodes" inner-nodes))) + (let + ((res (rx-parse-seq pat (+ i 1) ")" inner-ds))) + (list + (dict + "__t__" + "group" + "__idx__" + gidx + "__nodes__" + (nth res 0)) + (+ (nth res 1) 1) + (dict "groups" (nth res 2) "nodes" (get ds "nodes"))))))))) + (else (list (dict "__t__" "literal" "__c__" c) (+ i 1) ds)))))) + +;; top-level compile +(define + rx-compile + (fn + (pattern) + (let + ((nodes (list)) (ds (dict "groups" 0 "nodes" nodes))) + (let + ((res (rx-parse-seq pattern 0 "" ds))) + (dict "nodes" (nth res 0) "ngroups" (nth res 2)))))) + +;; ── Matcher ─────────────────────────────────────────────────────── + +;; Match a char-class item against character c +(define + rx-item-matches? + (fn + (item c ci?) + (let + ((kind (get item "kind"))) + (cond + ((= kind "lit") (rx-char-eq? c (get item "c") ci?)) + ((= kind "range") + (let + ((lo (if ci? (rx-downcase-char (get item "lo")) (get item "lo"))) + (hi + (if ci? (rx-downcase-char (get item "hi")) (get item "hi"))) + (dc (if ci? (rx-downcase-char c) c))) + (and + (>= (char-code dc) (char-code lo)) + (<= (char-code dc) (char-code hi))))) + ((= kind "class-d") + (let ((m (rx-digit? c))) (if (get item "neg") (not m) m))) + ((= kind "class-w") + (let ((m (rx-word? c))) (if (get item "neg") (not m) m))) + ((= kind "class-s") + (let ((m (rx-space? c))) (if (get item "neg") (not m) m))) + (else false))))) + +(define + rx-class-items-any? + (fn + (items c ci?) + (if + (empty? items) + false + (if + (rx-item-matches? (first items) c ci?) + true + (rx-class-items-any? (rest items) c ci?))))) + +(define + rx-class-matches? + (fn + (node c ci?) + (let + ((neg? (get node "__neg__")) (items (get node "__items__"))) + (let + ((hit (rx-class-items-any? items c ci?))) + (if neg? (not hit) hit))))) + +;; Word boundary check +(define + rx-is-word-boundary? + (fn + (s i slen) + (let + ((before (if (> i 0) (rx-word? (char-at s (- i 1))) false)) + (after (if (< i slen) (rx-word? (char-at s i)) false))) + (not (= before after))))) + +;; ── Core matcher ────────────────────────────────────────────────── +;; +;; rx-match-nodes : nodes s i slen ci? mi? groups → end-pos or -1 +;; +;; Matches `nodes` starting at position `i` in string `s`. +;; Returns the position after the last character consumed, or -1 on failure. +;; Mutates `groups` dict to record captures. + +(define + rx-match-nodes + (fn + (nodes s i slen ci? mi? groups) + (if + (empty? nodes) + i + (let + ((node (first nodes)) (rest-nodes (rest nodes))) + (let + ((t (get node "__t__"))) + (cond + ((= t "literal") + (if + (and + (< i slen) + (rx-char-eq? (char-at s i) (get node "__c__") ci?)) + (rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups) + -1)) + ((= t "any") + (if + (and (< i slen) (not (rx-newline? (char-at s i)))) + (rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups) + -1)) + ((= t "class-d") + (let + ((m (and (< i slen) (rx-digit? (char-at s i))))) + (if + (if (get node "__neg__") (not m) m) + (rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups) + -1))) + ((= t "class-w") + (let + ((m (and (< i slen) (rx-word? (char-at s i))))) + (if + (if (get node "__neg__") (not m) m) + (rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups) + -1))) + ((= t "class-s") + (let + ((m (and (< i slen) (rx-space? (char-at s i))))) + (if + (if (get node "__neg__") (not m) m) + (rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups) + -1))) + ((= t "char-class") + (if + (and (< i slen) (rx-class-matches? node (char-at s i) ci?)) + (rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups) + -1)) + ((= t "anchor-start") + (if + (or + (= i 0) + (and mi? (rx-newline? (rx-char-at s (- i 1))))) + (rx-match-nodes rest-nodes s i slen ci? mi? groups) + -1)) + ((= t "anchor-end") + (if + (or (= i slen) (and mi? (rx-newline? (rx-char-at s i)))) + (rx-match-nodes rest-nodes s i slen ci? mi? groups) + -1)) + ((= t "anchor-word") + (if + (rx-is-word-boundary? s i slen) + (rx-match-nodes rest-nodes s i slen ci? mi? groups) + -1)) + ((= t "anchor-nonword") + (if + (not (rx-is-word-boundary? s i slen)) + (rx-match-nodes rest-nodes s i slen ci? mi? groups) + -1)) + ((= t "group") + (let + ((gidx (get node "__idx__")) + (inner (get node "__nodes__"))) + (let + ((g-end (rx-match-nodes inner s i slen ci? mi? groups))) + (if + (>= g-end 0) + (begin + (dict-set! + groups + (js-to-string gidx) + (substring s i g-end)) + (let + ((final-end (rx-match-nodes rest-nodes s g-end slen ci? mi? groups))) + (if + (>= final-end 0) + final-end + (begin + (dict-set! groups (js-to-string gidx) nil) + -1)))) + -1)))) + ((= t "ncgroup") + (let + ((inner (get node "__nodes__"))) + (rx-match-nodes + (append inner rest-nodes) + s + i + slen + ci? + mi? + groups))) + ((= t "alt") + (let + ((branches (get node "__branches__"))) + (rx-try-branches branches rest-nodes s i slen ci? mi? groups))) + ((= t "quant") + (let + ((inner-node (get node "__node__")) + (mn (get node "__min__")) + (mx (get node "__max__")) + (lazy? (get node "__lazy__"))) + (if + lazy? + (rx-quant-lazy + inner-node + mn + mx + rest-nodes + s + i + slen + ci? + mi? + groups + 0) + (rx-quant-greedy + inner-node + mn + mx + rest-nodes + s + i + slen + ci? + mi? + groups + 0)))) + (else -1))))))) + +(define + rx-try-branches + (fn + (branches rest-nodes s i slen ci? mi? groups) + (if + (empty? branches) + -1 + (let + ((res (rx-match-nodes (append (first branches) rest-nodes) s i slen ci? mi? groups))) + (if + (>= res 0) + res + (rx-try-branches (rest branches) rest-nodes s i slen ci? mi? groups)))))) + +;; Greedy: expand as far as possible, then try rest from the longest match +;; Strategy: recurse forward (extend first); only try rest when extension fails +(define + rx-quant-greedy + (fn + (inner-node mn mx rest-nodes s i slen ci? mi? groups count) + (let + ((can-extend (and (< i slen) (or (= mx -1) (< count mx))))) + (if + can-extend + (let + ((ni (rx-match-one inner-node s i slen ci? mi? groups))) + (if + (>= ni 0) + (let + ((res (rx-quant-greedy inner-node mn mx rest-nodes s ni slen ci? mi? groups (+ count 1)))) + (if + (>= res 0) + res + (if + (>= count mn) + (rx-match-nodes rest-nodes s i slen ci? mi? groups) + -1))) + (if + (>= count mn) + (rx-match-nodes rest-nodes s i slen ci? mi? groups) + -1))) + (if + (>= count mn) + (rx-match-nodes rest-nodes s i slen ci? mi? groups) + -1))))) + +;; Lazy: try rest first, extend only if rest fails +(define + rx-quant-lazy + (fn + (inner-node mn mx rest-nodes s i slen ci? mi? groups count) + (if + (>= count mn) + (let + ((res (rx-match-nodes rest-nodes s i slen ci? mi? groups))) + (if + (>= res 0) + res + (if + (and (< i slen) (or (= mx -1) (< count mx))) + (let + ((ni (rx-match-one inner-node s i slen ci? mi? groups))) + (if + (>= ni 0) + (rx-quant-lazy + inner-node + mn + mx + rest-nodes + s + ni + slen + ci? + mi? + groups + (+ count 1)) + -1)) + -1))) + (if + (< i slen) + (let + ((ni (rx-match-one inner-node s i slen ci? mi? groups))) + (if + (>= ni 0) + (rx-quant-lazy + inner-node + mn + mx + rest-nodes + s + ni + slen + ci? + mi? + groups + (+ count 1)) + -1)) + -1)))) + +;; Match a single node at position i, return new pos or -1 +(define + rx-match-one + (fn + (node s i slen ci? mi? groups) + (rx-match-nodes (list node) s i slen ci? mi? groups))) + +;; ── Engine entry points ─────────────────────────────────────────── + +;; Try matching at exactly position i. Returns result dict or nil. +(define + rx-try-at + (fn + (compiled s i slen ci? mi?) + (let + ((nodes (get compiled "nodes")) (ngroups (get compiled "ngroups"))) + (let + ((groups (dict))) + (let + ((end (rx-match-nodes nodes s i slen ci? mi? groups))) + (if + (>= end 0) + (dict "start" i "end" end "groups" groups "ngroups" ngroups) + nil)))))) + +;; Find first match scanning from search-start. +(define + rx-find-from + (fn + (compiled s search-start slen ci? mi?) + (if + (> search-start slen) + nil + (let + ((res (rx-try-at compiled s search-start slen ci? mi?))) + (if + res + res + (rx-find-from compiled s (+ search-start 1) slen ci? mi?)))))) + +;; Build exec result dict from raw match result +(define + rx-build-exec-result + (fn + (s match-res) + (let + ((start (get match-res "start")) + (end (get match-res "end")) + (groups (get match-res "groups")) + (ngroups (get match-res "ngroups"))) + (let + ((matched (substring s start end)) + (caps (rx-build-captures groups ngroups 1))) + (dict "match" matched "index" start "input" s "groups" caps))))) + +(define + rx-build-captures + (fn + (groups ngroups idx) + (if + (> idx ngroups) + (list) + (let + ((cap (get groups (js-to-string idx)))) + (cons + (if (= cap nil) :js-undefined cap) + (rx-build-captures groups ngroups (+ idx 1))))))) + +;; ── Public interface ────────────────────────────────────────────── + +;; Lazy compile: build NFA on first use, cache under "__compiled__" +(define + rx-ensure-compiled! + (fn + (rx) + (if + (dict-has? rx "__compiled__") + (get rx "__compiled__") + (let + ((c (rx-compile (get rx "source")))) + (begin (dict-set! rx "__compiled__" c) c))))) + +(define + rx-test + (fn + (rx s) + (let + ((compiled (rx-ensure-compiled! rx)) + (ci? (get rx "ignoreCase")) + (mi? (get rx "multiline")) + (slen (len s))) + (let + ((start (if (get rx "global") (let ((li (get rx "lastIndex"))) (if (number? li) li 0)) 0))) + (let + ((res (rx-find-from compiled s start slen ci? mi?))) + (if + (get rx "global") + (begin + (dict-set! rx "lastIndex" (if res (get res "end") 0)) + (if res true false)) + (if res true false))))))) + +(define + rx-exec + (fn + (rx s) + (let + ((compiled (rx-ensure-compiled! rx)) + (ci? (get rx "ignoreCase")) + (mi? (get rx "multiline")) + (slen (len s))) + (let + ((start (if (get rx "global") (let ((li (get rx "lastIndex"))) (if (number? li) li 0)) 0))) + (let + ((res (rx-find-from compiled s start slen ci? mi?))) + (if + res + (begin + (when + (get rx "global") + (dict-set! rx "lastIndex" (get res "end"))) + (rx-build-exec-result s res)) + (begin + (when (get rx "global") (dict-set! rx "lastIndex" 0)) + nil))))))) + +;; match-all for String.prototype.matchAll +(define + js-regex-match-all + (fn + (rx s) + (let + ((compiled (rx-ensure-compiled! rx)) + (ci? (get rx "ignoreCase")) + (mi? (get rx "multiline")) + (slen (len s)) + (results (list))) + (rx-match-all-loop compiled s 0 slen ci? mi? results)))) + +(define + rx-match-all-loop + (fn + (compiled s i slen ci? mi? results) + (if + (> i slen) + results + (let + ((res (rx-find-from compiled s i slen ci? mi?))) + (if + res + (begin + (append! results (rx-build-exec-result s res)) + (let + ((next (get res "end"))) + (rx-match-all-loop + compiled + s + (if (= next i) (+ i 1) next) + slen + ci? + mi? + results))) + results))))) + +;; ── Install platform ────────────────────────────────────────────── + +(js-regex-platform-override! "test" rx-test) +(js-regex-platform-override! "exec" rx-exec) diff --git a/lib/js/runtime.sx b/lib/js/runtime.sx index e1021cc2..1872b3e9 100644 --- a/lib/js/runtime.sx +++ b/lib/js/runtime.sx @@ -2032,7 +2032,15 @@ (&rest args) (cond ((= (len args) 0) nil) - ((js-regex? (nth args 0)) (js-regex-stub-exec (nth args 0) s)) + ((js-regex? (nth args 0)) + (let + ((rx (nth args 0))) + (let + ((impl (get __js_regex_platform__ "exec"))) + (if + (js-undefined? impl) + (js-regex-stub-exec rx s) + (impl rx s))))) (else (let ((needle (js-to-string (nth args 0)))) @@ -2041,7 +2049,7 @@ (if (= idx -1) nil - (let ((res (list))) (append! res needle) res)))))))) + (let ((res (list))) (begin (append! res needle) res))))))))) ((= name "at") (fn (i) @@ -2099,6 +2107,20 @@ ((= name "toWellFormed") (fn () s)) (else js-undefined)))) +(define __js_tdz_sentinel__ (dict "__tdz__" true)) + +(define js-tdz? (fn (v) (and (dict? v) (dict-has? v "__tdz__")))) + +(define + js-tdz-check + (fn + (name val) + (if + (js-tdz? val) + (raise + (TypeError (str "Cannot access '" name "' before initialization"))) + val))) + (define js-string-slice (fn diff --git a/lib/js/stdlib.sx b/lib/js/stdlib.sx new file mode 100644 index 00000000..60096c28 --- /dev/null +++ b/lib/js/stdlib.sx @@ -0,0 +1,239 @@ +;; lib/js/stdlib.sx — Phase 22 JS additions +;; +;; Adds to lib/js/runtime.sx (already loaded): +;; 1. Bitwise binary ops (js-bitand/bitor/bitxor/lshift/rshift/urshift/bitnot) +;; 2. Map class (arbitrary-key hash map via list of pairs) +;; 3. Set class (uniqueness collection via SX make-set) +;; 4. RegExp constructor (wraps js-regex-new already in runtime) +;; 5. Wires Map / Set / RegExp into js-global + +;; --------------------------------------------------------------------------- +;; 1. Bitwise binary ops +;; JS coerces operands to 32-bit signed int before applying the op. +;; Use truncate (not js-num-to-int) since integer / 0 crashes the evaluator. +;; --------------------------------------------------------------------------- + +(define + (js-bitand a b) + (bitwise-and (truncate (js-to-number a)) (truncate (js-to-number b)))) + +(define + (js-bitor a b) + (bitwise-or (truncate (js-to-number a)) (truncate (js-to-number b)))) + +(define + (js-bitxor a b) + (bitwise-xor (truncate (js-to-number a)) (truncate (js-to-number b)))) + +;; << : left-shift by (b mod 32) positions +(define + (js-lshift a b) + (arithmetic-shift + (truncate (js-to-number a)) + (modulo (truncate (js-to-number b)) 32))) + +;; >> : arithmetic right-shift (sign-extending) +(define + (js-rshift a b) + (arithmetic-shift + (truncate (js-to-number a)) + (- 0 (modulo (truncate (js-to-number b)) 32)))) + +;; >>> : logical right-shift (zero-extending) +;; Convert to uint32 first, then divide by 2^n. +(define + (js-urshift a b) + (let + ((u32 (modulo (truncate (js-to-number a)) 4294967296)) + (n (modulo (truncate (js-to-number b)) 32))) + (quotient u32 (arithmetic-shift 1 n)))) + +;; ~ : bitwise NOT — equivalent to -(n+1) in 32-bit signed arithmetic +(define (js-bitnot a) (bitwise-not (truncate (js-to-number a)))) + +;; --------------------------------------------------------------------------- +;; 2. Map class +;; Stored as {:__js_map__ true :size N :_pairs (list (list key val) ...)} +;; Mutation via dict-set! on the underlying dict. +;; --------------------------------------------------------------------------- + +(define + (js-map-new) + (let + ((m (dict))) + (dict-set! m "__js_map__" true) + (dict-set! m "size" 0) + (dict-set! m "_pairs" (list)) + m)) + +(define (js-map? v) (and (dict? v) (dict-has? v "__js_map__"))) + +;; Linear scan for key using ===; returns index or -1 +(define + (js-map-find-idx pairs k) + (letrec + ((go (fn (ps i) (cond ((= (len ps) 0) -1) ((js-strict-eq (first (first ps)) k) i) (else (go (rest ps) (+ i 1))))))) + (go pairs 0))) + +(define + (js-map-get m k) + (letrec + ((go (fn (ps) (if (= (len ps) 0) js-undefined (if (js-strict-eq (first (first ps)) k) (nth (first ps) 1) (go (rest ps))))))) + (go (get m "_pairs")))) + +;; Replace element at index i in list +(define + (js-list-set-nth lst i newval) + (letrec + ((go (fn (ps j) (if (= (len ps) 0) (list) (cons (if (= j i) newval (first ps)) (go (rest ps) (+ j 1))))))) + (go lst 0))) + +;; Remove element at index i from list +(define + (js-list-remove-nth lst i) + (letrec + ((go (fn (ps j) (if (= (len ps) 0) (list) (if (= j i) (go (rest ps) (+ j 1)) (cons (first ps) (go (rest ps) (+ j 1)))))))) + (go lst 0))) + +(define + (js-map-set! m k v) + (let + ((pairs (get m "_pairs")) (idx (js-map-find-idx (get m "_pairs") k))) + (if + (= idx -1) + (begin + (dict-set! m "_pairs" (append pairs (list (list k v)))) + (dict-set! m "size" (+ (get m "size") 1))) + (dict-set! m "_pairs" (js-list-set-nth pairs idx (list k v))))) + m) + +(define + (js-map-has m k) + (not (= (js-map-find-idx (get m "_pairs") k) -1))) + +(define + (js-map-delete! m k) + (let + ((idx (js-map-find-idx (get m "_pairs") k))) + (when + (not (= idx -1)) + (dict-set! m "_pairs" (js-list-remove-nth (get m "_pairs") idx)) + (dict-set! m "size" (- (get m "size") 1)))) + m) + +(define + (js-map-clear! m) + (dict-set! m "_pairs" (list)) + (dict-set! m "size" 0) + m) + +(define (js-map-keys m) (map first (get m "_pairs"))) +(define + (js-map-vals m) + (map (fn (p) (nth p 1)) (get m "_pairs"))) +(define (js-map-entries m) (get m "_pairs")) + +(define + (js-map-for-each m cb) + (for-each + (fn (p) (cb (nth p 1) (first p) m)) + (get m "_pairs")) + js-undefined) + +;; Map method dispatch (called from js-object-method-call in runtime) +(define + (js-map-method m name args) + (cond + ((= name "set") + (js-map-set! m (nth args 0) (nth args 1))) + ((= name "get") (js-map-get m (nth args 0))) + ((= name "has") (js-map-has m (nth args 0))) + ((= name "delete") (js-map-delete! m (nth args 0))) + ((= name "clear") (js-map-clear! m)) + ((= name "keys") (js-map-keys m)) + ((= name "values") (js-map-vals m)) + ((= name "entries") (js-map-entries m)) + ((= name "forEach") (js-map-for-each m (nth args 0))) + ((= name "toString") "[object Map]") + (else js-undefined))) + +(define Map {:__callable__ (fn (&rest args) (let ((m (js-map-new))) (when (and (> (len args) 0) (list? (nth args 0))) (for-each (fn (entry) (js-map-set! m (nth entry 0) (nth entry 1))) (nth args 0))) m)) :prototype {:entries (fn (&rest a) (js-map-entries (js-this))) :delete (fn (&rest a) (js-map-delete! (js-this) (nth a 0))) :get (fn (&rest a) (js-map-get (js-this) (nth a 0))) :values (fn (&rest a) (js-map-vals (js-this))) :toString (fn () "[object Map]") :has (fn (&rest a) (js-map-has (js-this) (nth a 0))) :set (fn (&rest a) (js-map-set! (js-this) (nth a 0) (nth a 1))) :forEach (fn (&rest a) (js-map-for-each (js-this) (nth a 0))) :clear (fn (&rest a) (js-map-clear! (js-this))) :keys (fn (&rest a) (js-map-keys (js-this)))}}) + +;; --------------------------------------------------------------------------- +;; 3. Set class +;; {:__js_set__ true :size N :_set } +;; Note: set-member?/set-add!/set-remove! all take (set item) order. +;; --------------------------------------------------------------------------- + +(define + (js-set-new) + (let + ((s (dict))) + (dict-set! s "__js_set__" true) + (dict-set! s "size" 0) + (dict-set! s "_set" (make-set)) + s)) + +(define (js-set? v) (and (dict? v) (dict-has? v "__js_set__"))) + +(define + (js-set-add! s v) + (let + ((sx (get s "_set"))) + (when + (not (set-member? sx v)) + (set-add! sx v) + (dict-set! s "size" (+ (get s "size") 1)))) + s) + +(define (js-set-has s v) (set-member? (get s "_set") v)) + +(define + (js-set-delete! s v) + (let + ((sx (get s "_set"))) + (when + (set-member? sx v) + (set-remove! sx v) + (dict-set! s "size" (- (get s "size") 1)))) + s) + +(define + (js-set-clear! s) + (dict-set! s "_set" (make-set)) + (dict-set! s "size" 0) + s) + +(define (js-set-vals s) (set->list (get s "_set"))) + +(define + (js-set-for-each s cb) + (for-each (fn (v) (cb v v s)) (set->list (get s "_set"))) + js-undefined) + +(define Set {:__callable__ (fn (&rest args) (let ((s (js-set-new))) (when (and (> (len args) 0) (list? (nth args 0))) (for-each (fn (v) (js-set-add! s v)) (nth args 0))) s)) :prototype {:entries (fn (&rest a) (map (fn (v) (list v v)) (js-set-vals (js-this)))) :delete (fn (&rest a) (js-set-delete! (js-this) (nth a 0))) :values (fn (&rest a) (js-set-vals (js-this))) :add (fn (&rest a) (js-set-add! (js-this) (nth a 0))) :toString (fn () "[object Set]") :has (fn (&rest a) (js-set-has (js-this) (nth a 0))) :forEach (fn (&rest a) (js-set-for-each (js-this) (nth a 0))) :clear (fn (&rest a) (js-set-clear! (js-this))) :keys (fn (&rest a) (js-set-vals (js-this)))}}) + +;; --------------------------------------------------------------------------- +;; 4. RegExp constructor — callable lambda wrapping js-regex-new +;; --------------------------------------------------------------------------- + +(define + RegExp + (fn + (&rest args) + (cond + ((= (len args) 0) (js-regex-new "" "")) + ((= (len args) 1) + (js-regex-new (js-to-string (nth args 0)) "")) + (else + (js-regex-new + (js-to-string (nth args 0)) + (js-to-string (nth args 1))))))) + +;; --------------------------------------------------------------------------- +;; 5. Wire new globals into js-global +;; --------------------------------------------------------------------------- + +(dict-set! js-global "Map" Map) +(dict-set! js-global "Set" Set) +(dict-set! js-global "RegExp" RegExp) diff --git a/lib/js/test.sh b/lib/js/test.sh index de6caea5..b943a139 100755 --- a/lib/js/test.sh +++ b/lib/js/test.sh @@ -33,6 +33,10 @@ cat > "$TMPFILE" << 'EPOCHS' (load "lib/js/transpile.sx") (epoch 5) (load "lib/js/runtime.sx") +(epoch 6) +(load "lib/js/regex.sx") +(epoch 7) +(load "lib/js/stdlib.sx") ;; ── Phase 0: stubs still behave ───────────────────────────────── (epoch 10) @@ -1323,6 +1327,166 @@ cat > "$TMPFILE" << 'EPOCHS' (epoch 3505) (eval "(js-eval \"var a = {length: 3, 0: 10, 1: 20, 2: 30}; var sum = 0; Array.prototype.forEach.call(a, function(x){sum += x;}); sum\")") +;; ── Phase 12: Regex engine ──────────────────────────────────────── +;; Platform is installed (test key is a function, not undefined) +(epoch 5000) +(eval "(js-undefined? (get __js_regex_platform__ \"test\"))") +(epoch 5001) +(eval "(js-eval \"/foo/.test('hi foo bar')\")") +(epoch 5002) +(eval "(js-eval \"/foo/.test('hi bar')\")") +;; Case-insensitive flag +(epoch 5003) +(eval "(js-eval \"/FOO/i.test('hello foo world')\")") +;; Anchors +(epoch 5004) +(eval "(js-eval \"/^hello/.test('hello world')\")") +(epoch 5005) +(eval "(js-eval \"/^hello/.test('say hello')\")") +(epoch 5006) +(eval "(js-eval \"/world$/.test('hello world')\")") +;; Character classes +(epoch 5007) +(eval "(js-eval \"/\\\\d+/.test('abc 123')\")") +(epoch 5008) +(eval "(js-eval \"/\\\\w+/.test('hello')\")") +(epoch 5009) +(eval "(js-eval \"/[abc]/.test('dog')\")") +(epoch 5010) +(eval "(js-eval \"/[abc]/.test('cat')\")") +;; Quantifiers +(epoch 5011) +(eval "(js-eval \"/a*b/.test('b')\")") +(epoch 5012) +(eval "(js-eval \"/a+b/.test('b')\")") +(epoch 5013) +(eval "(js-eval \"/a{2,3}/.test('aa')\")") +(epoch 5014) +(eval "(js-eval \"/a{2,3}/.test('a')\")") +;; Dot +(epoch 5015) +(eval "(js-eval \"/h.llo/.test('hello')\")") +(epoch 5016) +(eval "(js-eval \"/h.llo/.test('hllo')\")") +;; exec result +(epoch 5017) +(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.match\")") +(epoch 5018) +(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.index\")") +(epoch 5019) +(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.groups[0]\")") +;; Alternation +(epoch 5020) +(eval "(js-eval \"/cat|dog/.test('I have a dog')\")") +(epoch 5021) +(eval "(js-eval \"/cat|dog/.test('I have a fish')\")") +;; Non-capturing group +(epoch 5022) +(eval "(js-eval \"/(?:foo)+/.test('foofoo')\")") +;; Negated char class +(epoch 5023) +(eval "(js-eval \"/[^abc]/.test('d')\")") +(epoch 5024) +(eval "(js-eval \"/[^abc]/.test('a')\")") +;; Range inside char class +(epoch 5025) +(eval "(js-eval \"/[a-z]+/.test('hello')\")") +;; Word boundary +(epoch 5026) +(eval "(js-eval \"/\\\\bword\\\\b/.test('a word here')\")") +(epoch 5027) +(eval "(js-eval \"/\\\\bword\\\\b/.test('password')\")") +;; Lazy quantifier +(epoch 5028) +(eval "(js-eval \"var m = /a+?/.exec('aaa'); m.match\")") +;; Global flag exec +(epoch 5029) +(eval "(js-eval \"var r=/\\\\d+/g; r.exec('a1b2'); r.exec('a1b2').match\")") +;; String.prototype.match with regex +(epoch 5030) +(eval "(js-eval \"'hello world'.match(/\\\\w+/).match\")") +;; String.prototype.search +(epoch 5031) +(eval "(js-eval \"'hello world'.search(/world/)\")") +;; String.prototype.replace with regex +(epoch 5032) +(eval "(js-eval \"'hello world'.replace(/world/, 'there')\")") +;; multiline anchor +(epoch 5033) +(eval "(js-eval \"/^bar/m.test('foo\\nbar')\")") + +;; ── Phase 13: let/const TDZ infrastructure ─────────────────────── +;; The TDZ sentinel and checker are defined in runtime.sx. +;; let/const bindings work normally after initialization. +(epoch 5100) +(eval "(js-eval \"let x = 5; x\")") +(epoch 5101) +(eval "(js-eval \"const y = 42; y\")") +;; TDZ sentinel exists and is detectable +(epoch 5102) +(eval "(js-tdz? __js_tdz_sentinel__)") +;; js-tdz-check passes through non-sentinel values +(epoch 5103) +(eval "(js-tdz-check \"x\" 42)") + +;; ── Phase 22: Bitwise ops ──────────────────────────────────────── +(epoch 6000) +(eval "(js-bitand 5 3)") +(epoch 6001) +(eval "(js-bitor 5 3)") +(epoch 6002) +(eval "(js-bitxor 5 3)") +(epoch 6003) +(eval "(js-lshift 1 4)") +(epoch 6004) +(eval "(js-rshift 32 2)") +(epoch 6005) +(eval "(js-rshift -8 1)") +(epoch 6006) +(eval "(js-urshift 4294967292 2)") +(epoch 6007) +(eval "(js-bitnot 0)") + +;; ── Phase 22: Map ───────────────────────────────────────────────── +(epoch 6010) +(eval "(js-map? (js-map-new))") +(epoch 6011) +(eval "(get (js-map-set! (js-map-new) \"k\" 42) \"size\")") +(epoch 6012) +(eval "(let ((m (js-map-new))) (js-map-set! m \"a\" 1) (js-map-get m \"a\"))") +(epoch 6013) +(eval "(let ((m (js-map-new))) (js-map-set! m \"x\" 9) (js-map-has m \"x\"))") +(epoch 6014) +(eval "(let ((m (js-map-new))) (js-map-set! m \"x\" 9) (js-map-has m \"y\"))") +(epoch 6015) +(eval "(let ((m (js-map-new))) (js-map-set! m \"a\" 1) (js-map-set! m \"b\" 2) (get m \"size\"))") +(epoch 6016) +(eval "(let ((m (js-map-new))) (js-map-set! m \"a\" 1) (js-map-delete! m \"a\") (get m \"size\"))") +(epoch 6017) +(eval "(let ((m (js-map-new))) (js-map-set! m \"a\" 1) (js-map-set! m \"a\" 99) (js-map-get m \"a\"))") + +;; ── Phase 22: Set ───────────────────────────────────────────────── +(epoch 6020) +(eval "(js-set? (js-set-new))") +(epoch 6021) +(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-has s 1))") +(epoch 6022) +(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-has s 2))") +(epoch 6023) +(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-add! s 1) (get s \"size\"))") +(epoch 6024) +(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-add! s 2) (get s \"size\"))") +(epoch 6025) +(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-delete! s 1) (get s \"size\"))") + +;; ── Phase 22: RegExp constructor ────────────────────────────────── +(epoch 6030) +(eval "(js-regex? (RegExp \"ab\" \"i\"))") +(epoch 6031) +(eval "(get (RegExp \"hello\" \"gi\") \"global\")") +(epoch 6032) +(eval "(get (RegExp \"foo\" \"i\") \"ignoreCase\")") + EPOCHS @@ -2042,6 +2206,81 @@ check 3503 "indexOf.call arrLike" '1' check 3504 "filter.call arrLike" '"2,3"' check 3505 "forEach.call arrLike sum" '60' +# ── Phase 12: Regex engine ──────────────────────────────────────── +check 5000 "regex platform installed" 'false' +check 5001 "/foo/ matches" 'true' +check 5002 "/foo/ no match" 'false' +check 5003 "/FOO/i case-insensitive" 'true' +check 5004 "/^hello/ anchor match" 'true' +check 5005 "/^hello/ anchor no-match" 'false' +check 5006 "/world$/ end anchor" 'true' +check 5007 "/\\d+/ digit class" 'true' +check 5008 "/\\w+/ word class" 'true' +check 5009 "/[abc]/ class no-match" 'false' +check 5010 "/[abc]/ class match" 'true' +check 5011 "/a*b/ zero-or-more" 'true' +check 5012 "/a+b/ one-or-more no-match" 'false' +check 5013 "/a{2,3}/ quant match" 'true' +check 5014 "/a{2,3}/ quant no-match" 'false' +check 5015 "dot matches any" 'true' +check 5016 "dot requires char" 'false' +check 5017 "exec match string" '"foobar"' +check 5018 "exec match index" '0' +check 5019 "exec capture group" '"bar"' +check 5020 "alternation cat|dog match" 'true' +check 5021 "alternation cat|dog no-match" 'false' +check 5022 "non-capturing group" 'true' +check 5023 "negated class match" 'true' +check 5024 "negated class no-match" 'false' +check 5025 "range [a-z]+" 'true' +check 5026 "word boundary match" 'true' +check 5027 "word boundary no-match" 'false' +check 5028 "lazy quantifier" '"a"' +check 5029 "global exec advances" '"2"' +check 5030 "String.match regex" '"hello"' +check 5031 "String.search regex" '6' +check 5032 "String.replace regex" '"hello there"' +check 5033 "multiline anchor" 'true' + +# ── Phase 13: let/const TDZ infrastructure ─────────────────────── +check 5100 "let binding initialized" '5' +check 5101 "const binding initialized" '42' +check 5102 "TDZ sentinel is detectable" 'true' +check 5103 "tdz-check passes non-sentinel" '42' + +# ── Phase 22: Bitwise ops ───────────────────────────────────────── +check 6000 "bitand 5&3" '1' +check 6001 "bitor 5|3" '7' +check 6002 "bitxor 5^3" '6' +check 6003 "lshift 1<<4" '16' +check 6004 "rshift 32>>2" '8' +check 6005 "rshift -8>>1" '-4' +check 6006 "urshift >>>" '1073741823' +check 6007 "bitnot ~0" '-1' + +# ── Phase 22: Map ───────────────────────────────────────────────── +check 6010 "map? new map" 'true' +check 6011 "map set→size 1" '1' +check 6012 "map get existing" '1' +check 6013 "map has key yes" 'true' +check 6014 "map has key no" 'false' +check 6015 "map size 2 entries" '2' +check 6016 "map delete→size 0" '0' +check 6017 "map set overwrites" '99' + +# ── Phase 22: Set ───────────────────────────────────────────────── +check 6020 "set? new set" 'true' +check 6021 "set has after add" 'true' +check 6022 "set has absent" 'false' +check 6023 "set dedup size" '1' +check 6024 "set size 2" '2' +check 6025 "set delete→size 0" '0' + +# ── Phase 22: RegExp ────────────────────────────────────────────── +check 6030 "RegExp? result" 'true' +check 6031 "RegExp global flag" 'true' +check 6032 "RegExp ignoreCase" 'true' + TOTAL=$((PASS + FAIL)) if [ $FAIL -eq 0 ]; then echo "✓ $PASS/$TOTAL JS-on-SX tests passed" diff --git a/lib/js/test262-runner.py b/lib/js/test262-runner.py index 9a0807b7..0b803c37 100644 --- a/lib/js/test262-runner.py +++ b/lib/js/test262-runner.py @@ -798,6 +798,7 @@ class ServerSession: self._run_and_collect(3, '(load "lib/js/parser.sx")', timeout=60.0) self._run_and_collect(4, '(load "lib/js/transpile.sx")', timeout=60.0) self._run_and_collect(5, '(load "lib/js/runtime.sx")', timeout=60.0) + self._run_and_collect(50, '(load "lib/js/regex.sx")', timeout=60.0) # Preload the stub harness — use precomputed SX cache when available # (huge win: ~15s js-eval HARNESS_STUB → ~0s load precomputed .sx). cache_rel = _harness_cache_rel_path() diff --git a/lib/js/transpile.sx b/lib/js/transpile.sx index 619d796f..2667825a 100644 --- a/lib/js/transpile.sx +++ b/lib/js/transpile.sx @@ -935,12 +935,12 @@ (define js-transpile-var - (fn (kind decls) (cons (js-sym "begin") (js-vardecl-forms decls)))) + (fn (kind decls) (cons (js-sym "begin") (js-vardecl-forms kind decls)))) (define js-vardecl-forms (fn - (decls) + (kind decls) (cond ((empty? decls) (list)) (else @@ -953,7 +953,7 @@ (js-sym "define") (js-sym (nth d 1)) (js-transpile (nth d 2))) - (js-vardecl-forms (rest decls)))) + (js-vardecl-forms kind (rest decls)))) ((js-tag? d "js-vardecl-obj") (let ((names (nth d 1)) @@ -964,7 +964,7 @@ (js-vardecl-obj-forms names tmp-sym - (js-vardecl-forms (rest decls)))))) + (js-vardecl-forms kind (rest decls)))))) ((js-tag? d "js-vardecl-arr") (let ((names (nth d 1)) @@ -976,7 +976,7 @@ names tmp-sym 0 - (js-vardecl-forms (rest decls)))))) + (js-vardecl-forms kind (rest decls)))))) (else (error "js-vardecl-forms: unexpected decl")))))))) (define diff --git a/lib/lua/runtime.sx b/lib/lua/runtime.sx index 71b37373..82cf1ace 100644 --- a/lib/lua/runtime.sx +++ b/lib/lua/runtime.sx @@ -123,7 +123,7 @@ (fn (i) (if - (has? a (str i)) + (not (= (get a (str i)) nil)) (begin (set! n i) (count-loop (+ i 1))) n))) (count-loop 1)))) @@ -152,7 +152,9 @@ (cond ((= (first f) "pos") (begin - (set! t (assoc t (str array-idx) (nth f 1))) + (set! + t + (assoc t (str array-idx) (nth f 1))) (set! array-idx (+ array-idx 1)))) ((= (first f) "kv") (let @@ -169,3 +171,108 @@ (if (= t nil) nil (let ((v (get t (str k)))) (if (= v nil) nil v))))) (define lua-set! (fn (t k v) (assoc t (str k) v))) + +;; --------------------------------------------------------------------------- +;; Helpers for stdlib +;; --------------------------------------------------------------------------- + +;; Apply a char function to every character in a string +(define (lua-str-map s fn) (list->string (map fn (string->list s)))) + +;; Repeat string s n times +(define + (lua-str-rep s n) + (letrec + ((go (fn (acc i) (if (= i 0) acc (go (str acc s) (- i 1)))))) + (go "" n))) + +;; Force a promise created by delay +(define + (lua-force p) + (if + (and (dict? p) (get p :_promise)) + (if (get p :forced) (get p :value) ((get p :thunk))) + p)) + +;; --------------------------------------------------------------------------- +;; math — Lua math library +;; --------------------------------------------------------------------------- + +(define math {:asin asin :floor floor :exp exp :huge 1e+308 :tan tan :sqrt sqrt :log log :abs abs :ceil ceil :sin sin :max (fn (a b) (if (> a b) a b)) :acos acos :min (fn (a b) (if (< a b) a b)) :cos cos :pi 3.14159 :atan atan}) + +;; --------------------------------------------------------------------------- +;; string — Lua string library +;; --------------------------------------------------------------------------- + +(define + (lua-string-find s pat) + (let + ((m (regexp-match (make-regexp pat) s))) + (if (= m nil) nil (list (+ (get m :start) 1) (get m :end))))) + +(define + (lua-string-match s pat) + (let + ((m (regexp-match (make-regexp pat) s))) + (if + (= m nil) + nil + (let + ((groups (get m :groups))) + (if (= (len groups) 0) (get m :match) (first groups)))))) + +(define + (lua-string-gmatch s pat) + (map (fn (m) (get m :match)) (regexp-match-all (make-regexp pat) s))) + +(define + (lua-string-gsub s pat repl) + (regexp-replace-all (make-regexp pat) s repl)) + +(define string {:rep lua-str-rep :sub (fn (s i &rest j-args) (let ((slen (len s)) (j (if (= (len j-args) 0) -1 (first j-args)))) (let ((from (if (< i 0) (let ((r (+ slen i))) (if (< r 0) 0 r)) (- i 1))) (to (if (< j 0) (let ((r (+ slen j 1))) (if (< r 0) 0 r)) (if (> j slen) slen j)))) (if (> from to) "" (substring s from to))))) :len (fn (s) (len s)) :upper (fn (s) (lua-str-map s char-upcase)) :char (fn (&rest codes) (list->string (map (fn (c) (integer->char (truncate c))) codes))) :gmatch lua-string-gmatch :gsub lua-string-gsub :lower (fn (s) (lua-str-map s char-downcase)) :byte (fn (s &rest args) (char->integer (nth (string->list s) (- (if (= (len args) 0) 1 (first args)) 1)))) :match lua-string-match :find lua-string-find :reverse (fn (s) (list->string (reverse (string->list s))))}) + +;; --------------------------------------------------------------------------- +;; table — Lua table library +;; --------------------------------------------------------------------------- + +(define + (lua-table-insert t v) + (assoc t (str (+ (lua-len t) 1)) v)) + +(define + (lua-table-remove t &rest args) + (let + ((n (lua-len t)) + (pos (if (= (len args) 0) (lua-len t) (first args)))) + (letrec + ((slide (fn (t i) (if (< i n) (assoc (slide t (+ i 1)) (str i) (lua-get t (+ i 1))) (assoc t (str n) nil))))) + (slide t pos)))) + +(define + (lua-table-concat t &rest args) + (let + ((sep (if (= (len args) 0) "" (first args))) + (n (lua-len t))) + (letrec + ((go (fn (acc i) (if (> i n) acc (go (str acc (if (= i 1) "" sep) (lua-to-string (lua-get t i))) (+ i 1)))))) + (go "" 1)))) + +(define + (lua-table-sort t) + (let + ((n (lua-len t))) + (letrec + ((collect (fn (i acc) (if (< i 1) acc (collect (- i 1) (cons (lua-get t i) acc))))) + (rebuild + (fn + (t i items) + (if + (= (len items) 0) + t + (rebuild + (assoc t (str i) (first items)) + (+ i 1) + (rest items)))))) + (rebuild t 1 (sort (collect n (list))))))) + +(define table {:sort lua-table-sort :concat lua-table-concat :insert lua-table-insert :remove lua-table-remove}) diff --git a/lib/lua/test.sh b/lib/lua/test.sh index 96a2e495..719f3750 100755 --- a/lib/lua/test.sh +++ b/lib/lua/test.sh @@ -633,6 +633,116 @@ check 482 "while i<5 count" '5' check 483 "repeat until i>=3" '3' check 484 "for 1..100 sum" '5050' +# ── Phase 3: stdlib — math, string, table ────────────────────────────────── + +cat >> "$TMPFILE" << 'EPOCHS2' + +;; ── math library ─────────────────────────────────────────────── +(epoch 500) +(eval "(lua-eval-ast \"return math.abs(-7)\")") +(epoch 501) +(eval "(lua-eval-ast \"return math.floor(3.9)\")") +(epoch 502) +(eval "(lua-eval-ast \"return math.ceil(3.1)\")") +(epoch 503) +(eval "(lua-eval-ast \"return math.sqrt(9)\")") +(epoch 504) +(eval "(lua-eval-ast \"return math.sin(0)\")") +(epoch 505) +(eval "(lua-eval-ast \"return math.cos(0)\")") +(epoch 506) +(eval "(lua-eval-ast \"return math.max(3, 7)\")") +(epoch 507) +(eval "(lua-eval-ast \"return math.min(3, 7)\")") +(epoch 508) +(eval "(lua-eval-ast \"return math.pi > 3\")") +(epoch 509) +(eval "(lua-eval-ast \"return math.huge > 0\")") + +;; ── string library ───────────────────────────────────────────── +(epoch 520) +(eval "(lua-eval-ast \"return string.len(\\\"hello\\\")\")") +(epoch 521) +(eval "(lua-eval-ast \"return string.upper(\\\"hello\\\")\")") +(epoch 522) +(eval "(lua-eval-ast \"return string.lower(\\\"WORLD\\\")\")") +(epoch 523) +(eval "(lua-eval-ast \"return string.sub(\\\"hello\\\", 2, 4)\")") +(epoch 524) +(eval "(lua-eval-ast \"return string.rep(\\\"ab\\\", 3)\")") +(epoch 525) +(eval "(lua-eval-ast \"return string.reverse(\\\"hello\\\")\")") +(epoch 526) +(eval "(lua-eval-ast \"return string.byte(\\\"A\\\")\")") +(epoch 527) +(eval "(lua-eval-ast \"return string.char(72, 105)\")") +(epoch 528) +(eval "(lua-eval-ast \"return string.find(\\\"hello\\\", \\\"ll\\\")\")") +(epoch 529) +(eval "(lua-eval-ast \"return string.match(\\\"hello\\\", \\\"ell\\\")\")") +(epoch 530) +(eval "(lua-eval-ast \"return string.gsub(\\\"hello\\\", \\\"l\\\", \\\"r\\\")\")") + +;; ── table library ────────────────────────────────────────────── +(epoch 540) +(eval "(lua-eval-ast \"local t = {10, 20, 30} t = table.insert(t, 40) return t[4]\")") +(epoch 541) +(eval "(lua-eval-ast \"local t = {10, 20, 30} t = table.remove(t) return t[3]\")") +(epoch 542) +(eval "(lua-eval-ast \"local t = {\\\"a\\\", \\\"b\\\", \\\"c\\\"} return table.concat(t, \\\",\\\")\")") +(epoch 543) +(eval "(lua-eval-ast \"local t = {3, 1, 2} t = table.sort(t) return t[1]\")") +(epoch 544) +(eval "(lua-eval-ast \"local t = {3, 1, 2} t = table.sort(t) return t[3]\")") + +;; ── delay / force ────────────────────────────────────────────── +(epoch 550) +(eval "(lua-force (delay (+ 10 5)))") +(epoch 551) +(eval "(lua-force 42)") + +EPOCHS2 + +OUTPUT2=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) +OUTPUT="$OUTPUT +$OUTPUT2" + +# math +check 500 "math.abs(-7)" '7' +check 501 "math.floor(3.9)" '3' +check 502 "math.ceil(3.1)" '4' +check 503 "math.sqrt(9)" '3' +check 504 "math.sin(0)" '0' +check 505 "math.cos(0)" '1' +check 506 "math.max(3,7)" '7' +check 507 "math.min(3,7)" '3' +check 508 "math.pi > 3" 'true' +check 509 "math.huge > 0" 'true' + +# string +check 520 "string.len" '5' +check 521 "string.upper" '"HELLO"' +check 522 "string.lower" '"world"' +check 523 "string.sub(2,4)" '"ell"' +check 524 "string.rep(ab,3)" '"ababab"' +check 525 "string.reverse" '"olleh"' +check 526 "string.byte(A)" '65' +check 527 "string.char(72,105)" '"Hi"' +check 528 "string.find ll" '3' +check 529 "string.match ell" '"ell"' +check 530 "string.gsub l->r" '"herro"' + +# table +check 540 "table.insert" '40' +check 541 "table.remove" 'nil' +check 542 "table.concat ," '"a,b,c"' +check 543 "table.sort [1]" '1' +check 544 "table.sort [3]" '3' + +# delay/force +check 550 "lua-force delay" '15' +check 551 "lua-force non-promise" '42' + TOTAL=$((PASS + FAIL)) if [ $FAIL -eq 0 ]; then echo "ok $PASS/$TOTAL Lua-on-SX tests passed" diff --git a/lib/prolog/compiler.sx b/lib/prolog/compiler.sx new file mode 100644 index 00000000..725f8cdf --- /dev/null +++ b/lib/prolog/compiler.sx @@ -0,0 +1,176 @@ +;; lib/prolog/compiler.sx — clause compiler: parse-AST clauses → SX closures +;; +;; Each compiled clause is a lambda (fn (goal trail db cut-box k) bool) +;; that creates fresh vars, builds the instantiated head/body, and calls +;; pl-unify! + pl-solve! directly — no AST walk at solve time. +;; +;; Usage: +;; (pl-db-load! db (pl-parse src)) +;; (pl-compile-db! db) +;; ; pl-solve-user! in runtime.sx automatically prefers compiled clauses +;; (pl-solve-once! db goal trail) + +;; Collect unique variable names from a parse-AST clause into a dict. +(define + pl-cmp-vars-into! + (fn + (ast seen) + (cond + ((not (list? ast)) nil) + ((empty? ast) nil) + ((= (first ast) "var") + (let + ((name (nth ast 1))) + (when + (and (not (= name "_")) (not (dict-has? seen name))) + (dict-set! seen name true)))) + ((= (first ast) "compound") + (for-each (fn (a) (pl-cmp-vars-into! a seen)) (nth ast 2))) + ((= (first ast) "clause") + (begin + (pl-cmp-vars-into! (nth ast 1) seen) + (pl-cmp-vars-into! (nth ast 2) seen)))))) + +;; Return list of unique var names in a clause (head + body, excluding _). +(define + pl-cmp-collect-vars + (fn + (clause) + (let ((seen {})) (pl-cmp-vars-into! clause seen) (keys seen)))) + +;; Create a fresh runtime var for each name in the list; return name->var dict. +(define + pl-cmp-make-var-map + (fn + (var-names) + (let + ((m {})) + (for-each + (fn (name) (dict-set! m name (pl-mk-rt-var name))) + var-names) + m))) + +;; Instantiate a parse-AST term using a pre-built var-map. +;; ("var" "_") always gets a fresh anonymous var. +(define + pl-cmp-build-term + (fn + (ast var-map) + (cond + ((pl-var? ast) ast) + ((not (list? ast)) ast) + ((empty? ast) ast) + ((= (first ast) "var") + (let + ((name (nth ast 1))) + (if (= name "_") (pl-mk-rt-var "_") (dict-get var-map name)))) + ((or (= (first ast) "atom") (= (first ast) "num") (= (first ast) "str")) + ast) + ((= (first ast) "compound") + (list + "compound" + (nth ast 1) + (map (fn (a) (pl-cmp-build-term a var-map)) (nth ast 2)))) + ((= (first ast) "clause") + (list + "clause" + (pl-cmp-build-term (nth ast 1) var-map) + (pl-cmp-build-term (nth ast 2) var-map))) + (true ast)))) + +;; Compile one parse-AST clause to a lambda. +;; Pre-computes var names at compile time; creates fresh vars per call. +(define + pl-compile-clause + (fn + (clause) + (let + ((var-names (pl-cmp-collect-vars clause)) + (head-ast (nth clause 1)) + (body-ast (nth clause 2))) + (fn + (goal trail db cut-box k) + (let + ((var-map (pl-cmp-make-var-map var-names))) + (let + ((fresh-head (pl-cmp-build-term head-ast var-map)) + (fresh-body (pl-cmp-build-term body-ast var-map))) + (let + ((mark (pl-trail-mark trail))) + (if + (pl-unify! goal fresh-head trail) + (let + ((r (pl-solve! db fresh-body trail cut-box k))) + (if r true (begin (pl-trail-undo-to! trail mark) false))) + (begin (pl-trail-undo-to! trail mark) false))))))))) + +;; Try a list of compiled clause lambdas — same cut semantics as pl-try-clauses!. +(define + pl-try-compiled-clauses! + (fn + (db + goal + trail + compiled-clauses + outer-cut-box + outer-was-cut + inner-cut-box + k) + (cond + ((empty? compiled-clauses) false) + (true + (let + ((r ((first compiled-clauses) goal trail db inner-cut-box k))) + (cond + (r true) + ((dict-get inner-cut-box :cut) false) + ((and (not outer-was-cut) (dict-get outer-cut-box :cut)) false) + (true + (pl-try-compiled-clauses! + db + goal + trail + (rest compiled-clauses) + outer-cut-box + outer-was-cut + inner-cut-box + k)))))))) + +;; Compile all clauses in DB and store in :compiled table. +;; After this call, pl-solve-user! will dispatch via compiled lambdas. +;; Note: clauses assert!-ed after this call are not compiled. +(define + pl-compile-db! + (fn + (db) + (let + ((src-table (dict-get db :clauses)) (compiled-table {})) + (for-each + (fn + (key) + (dict-set! + compiled-table + key + (map pl-compile-clause (dict-get src-table key)))) + (keys src-table)) + (dict-set! db :compiled compiled-table) + db))) + +;; Cross-validate: load src into both a plain and a compiled DB, +;; run goal-str through each, return true iff solution counts match. +;; Use this to keep the interpreter as the reference implementation. +(define + pl-compiled-matches-interp? + (fn + (src goal-str) + (let + ((db-interp (pl-mk-db)) (db-comp (pl-mk-db))) + (pl-db-load! db-interp (pl-parse src)) + (pl-db-load! db-comp (pl-parse src)) + (pl-compile-db! db-comp) + (let + ((gi (pl-instantiate (pl-parse-goal goal-str) {})) + (gc (pl-instantiate (pl-parse-goal goal-str) {}))) + (= + (pl-solve-count! db-interp gi (pl-mk-trail)) + (pl-solve-count! db-comp gc (pl-mk-trail))))))) diff --git a/lib/prolog/conformance.sh b/lib/prolog/conformance.sh new file mode 100755 index 00000000..6715320e --- /dev/null +++ b/lib/prolog/conformance.sh @@ -0,0 +1,129 @@ +#!/usr/bin/env bash +# Run every Prolog test suite via sx_server and refresh scoreboard.{json,md}. +# Exit 0 if all green, 1 if any failures. +set -euo pipefail + +HERE="$(cd "$(dirname "$0")" && pwd)" +ROOT="$(cd "$HERE/../.." && pwd)" +SX="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}" + +if [[ ! -x "$SX" ]]; then + echo "sx_server not found at $SX (set SX_SERVER env to override)" >&2 + exit 2 +fi + +cd "$ROOT" + +# name : test-file : runner-fn +SUITES=( + "parse:lib/prolog/tests/parse.sx:pl-parse-tests-run!" + "unify:lib/prolog/tests/unify.sx:pl-unify-tests-run!" + "clausedb:lib/prolog/tests/clausedb.sx:pl-clausedb-tests-run!" + "solve:lib/prolog/tests/solve.sx:pl-solve-tests-run!" + "operators:lib/prolog/tests/operators.sx:pl-operators-tests-run!" + "dynamic:lib/prolog/tests/dynamic.sx:pl-dynamic-tests-run!" + "findall:lib/prolog/tests/findall.sx:pl-findall-tests-run!" + "term_inspect:lib/prolog/tests/term_inspect.sx:pl-term-inspect-tests-run!" + "append:lib/prolog/tests/programs/append.sx:pl-append-tests-run!" + "reverse:lib/prolog/tests/programs/reverse.sx:pl-reverse-tests-run!" + "member:lib/prolog/tests/programs/member.sx:pl-member-tests-run!" + "nqueens:lib/prolog/tests/programs/nqueens.sx:pl-nqueens-tests-run!" + "family:lib/prolog/tests/programs/family.sx:pl-family-tests-run!" + "atoms:lib/prolog/tests/atoms.sx:pl-atom-tests-run!" + "query_api:lib/prolog/tests/query_api.sx:pl-query-api-tests-run!" + "iso_predicates:lib/prolog/tests/iso_predicates.sx:pl-iso-predicates-tests-run!" + "meta_predicates:lib/prolog/tests/meta_predicates.sx:pl-meta-predicates-tests-run!" + "list_predicates:lib/prolog/tests/list_predicates.sx:pl-list-predicates-tests-run!" + "meta_call:lib/prolog/tests/meta_call.sx:pl-meta-call-tests-run!" + "set_predicates:lib/prolog/tests/set_predicates.sx:pl-set-predicates-tests-run!" + "char_predicates:lib/prolog/tests/char_predicates.sx:pl-char-predicates-tests-run!" + "io_predicates:lib/prolog/tests/io_predicates.sx:pl-io-predicates-tests-run!" + "assert_rules:lib/prolog/tests/assert_rules.sx:pl-assert-rules-tests-run!" + "string_agg:lib/prolog/tests/string_agg.sx:pl-string-agg-tests-run!" + "advanced:lib/prolog/tests/advanced.sx:pl-advanced-tests-run!" + "compiler:lib/prolog/tests/compiler.sx:pl-compiler-tests-run!" + "cross_validate:lib/prolog/tests/cross_validate.sx:pl-cross-validate-tests-run!" + "integration:lib/prolog/tests/integration.sx:pl-integration-tests-run!" + "hs_bridge:lib/prolog/tests/hs_bridge.sx:pl-hs-bridge-tests-run!" +) + +SCRIPT='(epoch 1) +(load "lib/prolog/tokenizer.sx") +(load "lib/prolog/parser.sx") +(load "lib/prolog/runtime.sx") +(load "lib/prolog/query.sx") +(load "lib/prolog/compiler.sx") +(load "lib/prolog/hs-bridge.sx")' +for entry in "${SUITES[@]}"; do + IFS=: read -r _ file _ <<< "$entry" + SCRIPT+=$'\n(load "'"$file"$'")' +done +for entry in "${SUITES[@]}"; do + IFS=: read -r _ _ fn <<< "$entry" + SCRIPT+=$'\n(eval "('"$fn"$')")' +done + +OUTPUT="$(printf '%s\n' "$SCRIPT" | "$SX" 2>&1)" + +mapfile -t LINES < <(printf '%s\n' "$OUTPUT" | grep -E '^\{:failed') + +if [[ ${#LINES[@]} -ne ${#SUITES[@]} ]]; then + echo "Expected ${#SUITES[@]} suite results, got ${#LINES[@]}" >&2 + echo "---- raw output ----" >&2 + printf '%s\n' "$OUTPUT" >&2 + exit 3 +fi + +TOTAL_PASS=0 +TOTAL_FAIL=0 +TOTAL=0 +JSON_SUITES="" +MD_ROWS="" + +for i in "${!SUITES[@]}"; do + IFS=: read -r name _ _ <<< "${SUITES[$i]}" + line="${LINES[$i]}" + passed=$(grep -oE ':passed [0-9]+' <<< "$line" | grep -oE '[0-9]+') + total=$(grep -oE ':total [0-9]+' <<< "$line" | grep -oE '[0-9]+') + failed=$(grep -oE ':failed [0-9]+' <<< "$line" | grep -oE '[0-9]+') + TOTAL_PASS=$((TOTAL_PASS + passed)) + TOTAL_FAIL=$((TOTAL_FAIL + failed)) + TOTAL=$((TOTAL + total)) + status="ok" + [[ "$failed" -gt 0 ]] && status="FAIL" + [[ -n "$JSON_SUITES" ]] && JSON_SUITES+="," + JSON_SUITES+="\"$name\":{\"passed\":$passed,\"total\":$total,\"failed\":$failed}" + MD_ROWS+="| $name | $passed | $total | $status |"$'\n' +done + +WHEN="$(date -Iseconds 2>/dev/null || date)" + +cat > "$HERE/scoreboard.json" < "$HERE/scoreboard.md" <&2 + exit 1 +fi + +echo "All $TOTAL tests pass." diff --git a/lib/prolog/hs-bridge.sx b/lib/prolog/hs-bridge.sx new file mode 100644 index 00000000..66982aba --- /dev/null +++ b/lib/prolog/hs-bridge.sx @@ -0,0 +1,84 @@ +;; lib/prolog/hs-bridge.sx — Prolog ↔ Hyperscript bridge +;; +;; Two complementary integration styles: +;; +;; 1. Hook style — for `prolog(db, "goal(args)")` call syntax in Hyperscript: +;; (pl-install-hs-hook!) ;; call once at startup +;; Requires lib/hyperscript/runtime.sx (provides hs-set-prolog-hook!) +;; +;; 2. Factory style — for named conditions like `when allowed(user, action)`: +;; (define allowed (pl-hs-predicate/2 pl-db "allowed")) +;; No parser/compiler changes needed: Hyperscript compiles +;; `allowed(user, action)` to `(allowed user action)` — a plain SX call. +;; +;; Requires tokenizer.sx, parser.sx, runtime.sx, query.sx loaded first. + +;; --- Hook style --- + +(define + pl-install-hs-hook! + (fn + () + (hs-set-prolog-hook! + (fn (db goal) (not (= nil (pl-query-one db goal))))))) + +;; --- Factory style --- + +;; Test whether a ground Prolog goal succeeds against db. +;; Returns true/false (not a solution dict). +(define + pl-hs-query + (fn (db goal-str) (not (nil? (pl-query-one db goal-str))))) + +;; Build a Prolog goal string from a predicate name and arg list. +;; SX values: strings/keywords pass through; numbers are stringified via str. +(define + pl-hs-build-goal + (fn + (pred-name args) + (str pred-name "(" (join ", " (map (fn (a) (str a)) args)) ")"))) + +;; Return a 1-arg SX function that succeeds iff pred(a) holds in db. +(define + pl-hs-predicate/1 + (fn + (db pred-name) + (fn (a) (pl-hs-query db (pl-hs-build-goal pred-name (list a)))))) + +;; Return a 2-arg SX function that succeeds iff pred(a, b) holds in db. +(define + pl-hs-predicate/2 + (fn + (db pred-name) + (fn (a b) (pl-hs-query db (pl-hs-build-goal pred-name (list a b)))))) + +;; Return a 3-arg SX function that succeeds iff pred(a, b, c) holds in db. +(define + pl-hs-predicate/3 + (fn + (db pred-name) + (fn (a b c) (pl-hs-query db (pl-hs-build-goal pred-name (list a b c)))))) + +;; Install every predicate in install-list as a named SX function backed by db. +;; install-list: list of (name arity) pairs. +;; Returns a dict {name → fn} for the caller to destructure. +(define + pl-hs-install + (fn + (db install-list) + (reduce + (fn + (acc entry) + (let + ((pred-name (first entry)) (arity (nth entry 1))) + (dict-set! + acc + pred-name + (cond + ((= arity 1) (pl-hs-predicate/1 db pred-name)) + ((= arity 2) (pl-hs-predicate/2 db pred-name)) + ((= arity 3) (pl-hs-predicate/3 db pred-name)) + (true (fn (a b) false)))) + acc)) + {} + install-list))) diff --git a/lib/prolog/parser.sx b/lib/prolog/parser.sx index d301a184..d6ee00b7 100644 --- a/lib/prolog/parser.sx +++ b/lib/prolog/parser.sx @@ -1,28 +1,20 @@ ;; lib/prolog/parser.sx — tokens → Prolog AST ;; -;; Phase 1 grammar (NO operator table yet): +;; Phase 4 grammar (with operator table): ;; Program := Clause* EOF -;; Clause := Term "." | Term ":-" Term "." -;; Term := Atom | Var | Number | String | Compound | List -;; Compound := atom "(" ArgList ")" -;; ArgList := Term ("," Term)* -;; List := "[" "]" | "[" Term ("," Term)* ("|" Term)? "]" +;; Clause := Term[999] "." | Term[999] ":-" Term[1200] "." +;; Term[Pmax] uses precedence climbing on the operator table: +;; primary = Atom | Var | Number | String | Compound | List | "(" Term[1200] ")" +;; while next token is infix op `op` with prec(op) ≤ Pmax: +;; consume op; parse rhs at right-prec(op); fold into compound(op-name,[lhs,rhs]) ;; -;; Term AST shapes (all tagged lists for uniform dispatch): -;; ("atom" name) — atom -;; ("var" name) — variable template (parser-time only) -;; ("num" value) — integer or float -;; ("str" value) — string literal -;; ("compound" functor args) — compound term, args is list of term-ASTs -;; ("cut") — the cut atom ! +;; Op type → right-prec for op at precedence P: +;; xfx → P-1 strict-both +;; xfy → P right-associative +;; yfx → P-1 left-associative ;; -;; A clause is (list "clause" head body). A fact is head with body = ("atom" "true"). -;; -;; The empty list is (atom "[]"). Cons is compound "." with two args: -;; [1, 2, 3] → .(1, .(2, .(3, []))) -;; [H|T] → .(H, T) +;; AST shapes are unchanged — operators just become compound terms. -;; ── Parser state helpers ──────────────────────────────────────────── (define pp-peek (fn @@ -66,7 +58,6 @@ (if (= (get t :value) nil) "" (get t :value)) "'")))))) -;; ── AST constructors ──────────────────────────────────────────────── (define pl-mk-atom (fn (name) (list "atom" name))) (define pl-mk-var (fn (name) (list "var" name))) (define pl-mk-num (fn (n) (list "num" n))) @@ -74,18 +65,14 @@ (define pl-mk-compound (fn (f args) (list "compound" f args))) (define pl-mk-cut (fn () (list "cut"))) -;; Term tag extractors (define pl-term-tag (fn (t) (if (list? t) (first t) nil))) (define pl-term-val (fn (t) (nth t 1))) (define pl-compound-functor (fn (t) (nth t 1))) (define pl-compound-args (fn (t) (nth t 2))) -;; Empty-list atom and cons helpers (define pl-nil-term (fn () (pl-mk-atom "[]"))) - (define pl-mk-cons (fn (h t) (pl-mk-compound "." (list h t)))) -;; Build cons list from a list of terms + optional tail (define pl-mk-list-term (fn @@ -95,9 +82,61 @@ tail (pl-mk-cons (first items) (pl-mk-list-term (rest items) tail))))) -;; ── Term parser ───────────────────────────────────────────────────── +;; ── Operator table (Phase 4) ────────────────────────────────────── +;; Each entry: (name precedence type). Type ∈ "xfx" "xfy" "yfx". (define - pp-parse-term + pl-op-table + (list + (list "," 1000 "xfy") + (list ";" 1100 "xfy") + (list "->" 1050 "xfy") + (list "=" 700 "xfx") + (list "\\=" 700 "xfx") + (list "is" 700 "xfx") + (list "<" 700 "xfx") + (list ">" 700 "xfx") + (list "=<" 700 "xfx") + (list ">=" 700 "xfx") + (list "+" 500 "yfx") + (list "-" 500 "yfx") + (list "*" 400 "yfx") + (list "/" 400 "yfx") + (list ":-" 1200 "xfx") + (list "mod" 400 "yfx"))) + +(define + pl-op-find + (fn + (name table) + (cond + ((empty? table) nil) + ((= (first (first table)) name) (rest (first table))) + (true (pl-op-find name (rest table)))))) + +(define pl-op-lookup (fn (name) (pl-op-find name pl-op-table))) + +;; Token → (name prec type) for known infix ops, else nil. +(define + pl-token-op + (fn + (t) + (let + ((ty (get t :type)) (vv (get t :value))) + (cond + ((and (= ty "punct") (= vv ",")) + (let + ((info (pl-op-lookup ","))) + (if (nil? info) nil (cons "," info)))) + ((or (= ty "atom") (= ty "op")) + (let + ((info (pl-op-lookup vv))) + (if (nil? info) nil (cons vv info)))) + (true nil))))) + +;; ── Term parser ───────────────────────────────────────────────────── +;; Primary term: atom, var, num, str, compound (atom + paren), list, cut, parens. +(define + pp-parse-primary (fn (st) (let @@ -111,6 +150,12 @@ ((and (= ty "op") (= vv "!")) (do (pp-advance! st) (pl-mk-cut))) ((and (= ty "punct") (= vv "[")) (pp-parse-list st)) + ((and (= ty "punct") (= vv "(")) + (do + (pp-advance! st) + (let + ((inner (pp-parse-term-prec st 1200))) + (do (pp-expect! st "punct" ")") inner)))) ((= ty "atom") (do (pp-advance! st) @@ -133,13 +178,51 @@ (if (= vv nil) "" vv) "'")))))))) -;; Parse one or more comma-separated terms (arguments). +;; Operator-aware term parser: precedence climbing. +(define + pp-parse-term-prec + (fn + (st max-prec) + (let ((left (pp-parse-primary st))) (pp-parse-op-rhs st left max-prec)))) + +(define + pp-parse-op-rhs + (fn + (st left max-prec) + (let + ((op-info (pl-token-op (pp-peek st)))) + (cond + ((nil? op-info) left) + (true + (let + ((name (first op-info)) + (prec (nth op-info 1)) + (ty (nth op-info 2))) + (cond + ((> prec max-prec) left) + (true + (let + ((right-prec (if (= ty "xfy") prec (- prec 1)))) + (do + (pp-advance! st) + (let + ((right (pp-parse-term-prec st right-prec))) + (pp-parse-op-rhs + st + (pl-mk-compound name (list left right)) + max-prec)))))))))))) + +;; Backwards-compat alias. +(define pp-parse-term (fn (st) (pp-parse-term-prec st 999))) + +;; Args inside parens: parse at prec 999 so comma-as-operator (1000) +;; is not consumed; the explicit comma loop handles separation. (define pp-parse-arg-list (fn (st) (let - ((first-arg (pp-parse-term st)) (args (list))) + ((first-arg (pp-parse-term-prec st 999)) (args (list))) (do (append! args first-arg) (define @@ -150,12 +233,12 @@ (pp-at? st "punct" ",") (do (pp-advance! st) - (append! args (pp-parse-term st)) + (append! args (pp-parse-term-prec st 999)) (loop))))) (loop) args)))) -;; Parse a [ ... ] list literal. Consumes the "[". +;; List literal. (define pp-parse-list (fn @@ -168,7 +251,7 @@ (let ((items (list))) (do - (append! items (pp-parse-term st)) + (append! items (pp-parse-term-prec st 999)) (define comma-loop (fn @@ -177,52 +260,17 @@ (pp-at? st "punct" ",") (do (pp-advance! st) - (append! items (pp-parse-term st)) + (append! items (pp-parse-term-prec st 999)) (comma-loop))))) (comma-loop) (let - ((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term st)) (pl-nil-term)))) + ((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term-prec st 999)) (pl-nil-term)))) (do (pp-expect! st "punct" "]") (pl-mk-list-term items tail))))))))) ;; ── Body parsing ──────────────────────────────────────────────────── -;; A clause body is a comma-separated list of goals. We flatten into a -;; right-associative `,` compound: (A, B, C) → ','(A, ','(B, C)) -;; If only one goal, it's that goal directly. -(define - pp-parse-body - (fn - (st) - (let - ((first-goal (pp-parse-term st)) (rest-goals (list))) - (do - (define - gloop - (fn - () - (when - (pp-at? st "punct" ",") - (do - (pp-advance! st) - (append! rest-goals (pp-parse-term st)) - (gloop))))) - (gloop) - (if - (= (len rest-goals) 0) - first-goal - (pp-build-conj first-goal rest-goals)))))) - -(define - pp-build-conj - (fn - (first-goal rest-goals) - (if - (= (len rest-goals) 0) - first-goal - (pl-mk-compound - "," - (list - first-goal - (pp-build-conj (first rest-goals) (rest rest-goals))))))) +;; A body is a single term parsed at prec 1200 — operator parser folds +;; `,`, `;`, `->` automatically into right-associative compounds. +(define pp-parse-body (fn (st) (pp-parse-term-prec st 1200))) ;; ── Clause parsing ────────────────────────────────────────────────── (define @@ -230,12 +278,11 @@ (fn (st) (let - ((head (pp-parse-term st))) + ((head (pp-parse-term-prec st 999))) (let ((body (if (pp-at? st "op" ":-") (do (pp-advance! st) (pp-parse-body st)) (pl-mk-atom "true")))) (do (pp-expect! st "punct" ".") (list "clause" head body)))))) -;; Parse an entire program — returns list of clauses. (define pl-parse-program (fn @@ -253,13 +300,9 @@ (ploop) clauses)))) -;; Parse a single query term (no trailing "."). Returns the term. (define pl-parse-query (fn (tokens) (let ((st {:idx 0 :tokens tokens})) (pp-parse-body st)))) -;; Convenience: source → clauses (define pl-parse (fn (src) (pl-parse-program (pl-tokenize src)))) - -;; Convenience: source → query term (define pl-parse-goal (fn (src) (pl-parse-query (pl-tokenize src)))) diff --git a/lib/prolog/query.sx b/lib/prolog/query.sx new file mode 100644 index 00000000..268202b2 --- /dev/null +++ b/lib/prolog/query.sx @@ -0,0 +1,114 @@ +;; lib/prolog/query.sx — high-level Prolog query API for SX/Hyperscript callers. +;; +;; Requires tokenizer.sx, parser.sx, runtime.sx to be loaded first. +;; +;; Public API: +;; (pl-load source-str) → db +;; (pl-query-all db query-str) → list of solution dicts {var-name → term-string} +;; (pl-query-one db query-str) → first solution dict or nil +;; (pl-query source-str query-str) → list of solution dicts (convenience) + +;; Collect variable name strings from a parse-time AST (pre-instantiation). +;; Returns list of unique strings, excluding anonymous "_". +(define + pl-query-extract-vars + (fn + (ast) + (let + ((seen {})) + (let + ((collect! + (fn + (t) + (cond + ((not (list? t)) nil) + ((empty? t) nil) + ((= (first t) "var") + (if + (not (= (nth t 1) "_")) + (dict-set! seen (nth t 1) true) + nil)) + ((= (first t) "compound") + (for-each collect! (nth t 2))) + (true nil))))) + (collect! ast) + (keys seen))))) + +;; Build a solution dict from a var-env after a successful solve. +;; Maps each variable name string to its formatted term value. +(define + pl-query-solution-dict + (fn + (var-names var-env) + (let + ((d {})) + (for-each + (fn (name) (dict-set! d name (pl-format-term (dict-get var-env name)))) + var-names) + d))) + +;; Parse source-str and load clauses into a fresh DB. +;; Returns the DB for reuse across multiple queries. +(define + pl-load + (fn + (source-str) + (let + ((db (pl-mk-db))) + (if + (and (string? source-str) (not (= source-str ""))) + (pl-db-load! db (pl-parse source-str)) + nil) + db))) + +;; Run query-str against db, returning a list of solution dicts. +;; Each dict maps variable name strings to their formatted term values. +;; Returns an empty list if no solutions. +(define + pl-query-all + (fn + (db query-str) + (let + ((parsed (pl-parse (str "q_ :- " query-str ".")))) + (let + ((body-ast (nth (first parsed) 2))) + (let + ((var-names (pl-query-extract-vars body-ast)) + (var-env {})) + (let + ((goal (pl-instantiate body-ast var-env)) + (trail (pl-mk-trail)) + (solutions (list))) + (let + ((mark (pl-trail-mark trail))) + (pl-solve! + db + goal + trail + {:cut false} + (fn + () + (begin + (append! + solutions + (pl-query-solution-dict var-names var-env)) + false))) + (pl-trail-undo-to! trail mark) + solutions))))))) + +;; Return the first solution dict, or nil if no solutions. +(define + pl-query-one + (fn + (db query-str) + (let + ((all (pl-query-all db query-str))) + (if (empty? all) nil (first all))))) + +;; Convenience: parse source-str, then run query-str against it. +;; Returns a list of solution dicts. Creates a fresh DB each call. +(define + pl-query + (fn + (source-str query-str) + (pl-query-all (pl-load source-str) query-str))) diff --git a/lib/prolog/runtime.sx b/lib/prolog/runtime.sx index d20a71cb..257894a0 100644 --- a/lib/prolog/runtime.sx +++ b/lib/prolog/runtime.sx @@ -98,6 +98,11 @@ "compound" fun (map (fn (a) (pl-instantiate a var-env)) args)))) + ((= (first ast) "clause") + (let + ((h (pl-instantiate (nth ast 1) var-env)) + (b (pl-instantiate (nth ast 2) var-env))) + (list "clause" h b))) (true ast)))) (define pl-instantiate-fresh (fn (ast) (pl-instantiate ast {}))) @@ -230,3 +235,2560 @@ (pl-unify! t1 t2 trail) true (do (pl-trail-undo-to! trail mark) false))))) + +(define pl-mk-db (fn () {:clauses {}})) + +(define + pl-head-key + (fn + (head) + (cond + ((pl-compound? head) (str (pl-fun head) "/" (len (pl-args head)))) + ((pl-atom? head) (str (pl-atom-name head) "/0")) + (true (error "pl-head-key: invalid head"))))) + +(define pl-clause-key (fn (clause) (pl-head-key (nth clause 1)))) + +(define pl-goal-key (fn (goal) (pl-head-key goal))) + +(define + pl-db-add! + (fn + (db clause) + (let + ((key (pl-clause-key clause)) (table (dict-get db :clauses))) + (cond + ((nil? (dict-get table key)) (dict-set! table key (list clause))) + (true (begin (append! (dict-get table key) clause) nil)))))) + +(define + pl-db-load! + (fn + (db program) + (cond + ((empty? program) nil) + (true + (begin + (pl-db-add! db (first program)) + (pl-db-load! db (rest program))))))) + +(define + pl-db-lookup + (fn + (db key) + (let + ((v (dict-get (dict-get db :clauses) key))) + (cond ((nil? v) (list)) (true v))))) + +(define + pl-db-lookup-goal + (fn (db goal) (pl-db-lookup db (pl-goal-key goal)))) + +(define + pl-rt-walk-to-ast + (fn + (w) + (cond + ((pl-var? w) (list "var" (str "_G" (pl-var-id w)))) + ((and (list? w) (not (empty? w)) (= (first w) "compound")) + (list "compound" (nth w 1) (map pl-rt-walk-to-ast (nth w 2)))) + (true w)))) + +(define pl-rt-to-ast (fn (t) (pl-rt-walk-to-ast (pl-walk-deep t)))) + +(define + pl-build-clause + (fn + (ast) + (cond + ((and (list? ast) (= (first ast) "compound") (= (nth ast 1) ":-") (= (len (nth ast 2)) 2)) + (list "clause" (first (nth ast 2)) (nth (nth ast 2) 1))) + (true (list "clause" ast (list "atom" "true")))))) + +(define + pl-db-prepend! + (fn + (db clause) + (let + ((key (pl-clause-key clause)) (table (dict-get db :clauses))) + (cond + ((nil? (dict-get table key)) (dict-set! table key (list clause))) + (true (dict-set! table key (cons clause (dict-get table key)))))))) + +(define + pl-list-without + (fn + (lst i) + (cond + ((empty? lst) (list)) + ((= i 0) (rest lst)) + (true (cons (first lst) (pl-list-without (rest lst) (- i 1))))))) + +(define + pl-solve-assertz! + (fn + (db term k) + (begin (pl-db-add! db (pl-build-clause (pl-rt-to-ast term))) (k)))) + +(define + pl-solve-asserta! + (fn + (db term k) + (begin (pl-db-prepend! db (pl-build-clause (pl-rt-to-ast term))) (k)))) + +(define + pl-solve-retract! + (fn + (db term trail k) + (let + ((head-runtime (cond ((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2)) (first (pl-args term))) (true term))) + (body-runtime + (cond + ((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2)) + (nth (pl-args term) 1)) + (true (list "atom" "true"))))) + (let + ((wh (pl-walk head-runtime))) + (cond + ((pl-var? wh) false) + (true + (let + ((key (pl-head-key wh))) + (pl-retract-try-each + db + key + (pl-db-lookup db key) + head-runtime + body-runtime + 0 + trail + k)))))))) + +(define + pl-deep-copy + (fn + (t var-map) + (let + ((w (pl-walk t))) + (cond + ((pl-var? w) + (let + ((id-key (str (pl-var-id w)))) + (cond + ((dict-has? var-map id-key) (dict-get var-map id-key)) + (true + (let + ((nv (pl-mk-rt-var (dict-get w :name)))) + (begin (dict-set! var-map id-key nv) nv)))))) + ((pl-compound? w) + (list + "compound" + (pl-fun w) + (map (fn (a) (pl-deep-copy a var-map)) (pl-args w)))) + (true w))))) + +(define + pl-each-into-dict! + (fn + (terms d) + (cond + ((empty? terms) nil) + (true + (begin + (dict-set! d (pl-format-term (first terms)) (first terms)) + (pl-each-into-dict! (rest terms) d)))))) + +(define + pl-sort-uniq-terms + (fn + (terms) + (let + ((kv {})) + (begin + (pl-each-into-dict! terms kv) + (let + ((sorted-keys (sort (keys kv)))) + (map (fn (k) (dict-get kv k)) sorted-keys)))))) + +(define + pl-collect-vars + (fn + (term seen-ids) + (let + ((walked (pl-walk term))) + (cond + ((pl-var? walked) + (let + ((id (pl-var-id walked))) + (if + (some (fn (s) (= s id)) seen-ids) + (list seen-ids (list)) + (list (cons id seen-ids) (list walked))))) + ((pl-compound? walked) + (reduce + (fn + (acc arg) + (let + ((result (pl-collect-vars arg (first acc)))) + (list (first result) (append (nth acc 1) (nth result 1))))) + (list seen-ids (list)) + (pl-args walked))) + (true (list seen-ids (list))))))) + +(define + pl-predsort-insert! + (fn + (db pred elem sorted trail) + (if + (empty? sorted) + (list elem) + (let + ((head (first sorted)) (order-var (pl-mk-rt-var "_PO"))) + (let + ((call-goal (pl-apply-goal pred (list order-var elem head))) + (mark (pl-trail-mark trail))) + (let + ((ok (pl-solve-once! db call-goal trail))) + (if + ok + (let + ((order (pl-atom-name (pl-walk-deep order-var)))) + (do + (pl-trail-undo-to! trail mark) + (cond + ((= order "<") (cons elem sorted)) + ((= order "=") sorted) + ((= order ">") + (let + ((rest-sorted (pl-predsort-insert! db pred elem (rest sorted) trail))) + (if rest-sorted (cons head rest-sorted) false))) + (true false)))) + (begin (pl-trail-undo-to! trail mark) false)))))))) + +(define + pl-predsort-build! + (fn + (db pred items trail) + (reduce + (fn + (sorted elem) + (if sorted (pl-predsort-insert! db pred elem sorted trail) false)) + (list) + items))) + +(define + pl-collect-solutions + (fn + (db template-rt goal-rt trail) + (let + ((box {:results (list)}) (mark (pl-trail-mark trail))) + (begin + (pl-solve! + db + goal-rt + trail + {:cut false} + (fn + () + (begin + (append! + (dict-get box :results) + (pl-deep-copy template-rt {})) + false))) + (pl-trail-undo-to! trail mark) + (dict-get box :results))))) + +(define + pl-solve-findall! + (fn + (db template-rt goal-rt third-rt trail k) + (let + ((items (pl-collect-solutions db template-rt goal-rt trail))) + (let + ((rl (pl-mk-list-term items (pl-nil-term)))) + (pl-solve-eq! third-rt rl trail k))))) + +(define + pl-solve-bagof! + (fn + (db template-rt goal-rt third-rt trail k) + (let + ((items (pl-collect-solutions db template-rt goal-rt trail))) + (cond + ((empty? items) false) + (true + (let + ((rl (pl-mk-list-term items (pl-nil-term)))) + (pl-solve-eq! third-rt rl trail k))))))) + +(define + pl-solve-setof! + (fn + (db template-rt goal-rt third-rt trail k) + (let + ((items (pl-collect-solutions db template-rt goal-rt trail))) + (cond + ((empty? items) false) + (true + (let + ((sorted (pl-sort-uniq-terms items))) + (let + ((rl (pl-mk-list-term sorted (pl-nil-term)))) + (pl-solve-eq! third-rt rl trail k)))))))) + +(define + pl-solve-eq2! + (fn + (a1 b1 a2 b2 trail k) + (let + ((mark (pl-trail-mark trail))) + (cond + ((and (pl-unify! a1 b1 trail) (pl-unify! a2 b2 trail)) + (let + ((r (k))) + (cond + (r true) + (true (begin (pl-trail-undo-to! trail mark) false))))) + (true (begin (pl-trail-undo-to! trail mark) false)))))) + +(define + pl-make-fresh-args + (fn + (n) + (cond + ((<= n 0) (list)) + (true (cons (pl-mk-rt-var "_") (pl-make-fresh-args (- n 1))))))) + +(define + pl-solve-functor-construct! + (fn + (term-rt name-rt arity-rt trail k) + (let + ((wn (pl-walk name-rt)) (wa (pl-walk arity-rt))) + (cond + ((and (pl-num? wa) (= (pl-num-val wa) 0)) + (cond + ((or (pl-atom? wn) (pl-num? wn)) + (pl-solve-eq! term-rt wn trail k)) + (true false))) + ((and (pl-num? wa) (> (pl-num-val wa) 0) (pl-atom? wn)) + (let + ((new-args (pl-make-fresh-args (pl-num-val wa)))) + (pl-solve-eq! + term-rt + (list "compound" (pl-atom-name wn) new-args) + trail + k))) + (true false))))) + +(define + pl-solve-functor! + (fn + (term-rt name-rt arity-rt trail k) + (let + ((wt (pl-walk term-rt))) + (cond + ((pl-var? wt) + (pl-solve-functor-construct! term-rt name-rt arity-rt trail k)) + ((pl-atom? wt) + (pl-solve-eq2! name-rt wt arity-rt (list "num" 0) trail k)) + ((pl-num? wt) + (pl-solve-eq2! name-rt wt arity-rt (list "num" 0) trail k)) + ((pl-compound? wt) + (pl-solve-eq2! + name-rt + (list "atom" (pl-fun wt)) + arity-rt + (list "num" (len (pl-args wt))) + trail + k)) + (true false))))) + +(define + pl-solve-arg! + (fn + (n-rt term-rt arg-rt trail k) + (let + ((wn (pl-walk n-rt)) (wt (pl-walk term-rt))) + (cond + ((and (pl-num? wn) (pl-compound? wt)) + (let + ((idx (pl-num-val wn)) (args (pl-args wt))) + (cond + ((and (>= idx 1) (<= idx (len args))) + (pl-solve-eq! arg-rt (nth args (- idx 1)) trail k)) + (true false)))) + (true false))))) + +(define + pl-retract-try-each + (fn + (db key remaining head-rt body-rt idx trail k) + (cond + ((empty? remaining) false) + (true + (let + ((mark (pl-trail-mark trail)) + (cl (pl-instantiate-fresh (first remaining)))) + (cond + ((and (pl-unify! head-rt (nth cl 1) trail) (pl-unify! body-rt (nth cl 2) trail)) + (begin + (let + ((all (pl-db-lookup db key))) + (dict-set! + (dict-get db :clauses) + key + (pl-list-without all idx))) + (let + ((r (k))) + (cond + (r true) + (true (begin (pl-trail-undo-to! trail mark) false)))))) + (true + (begin + (pl-trail-undo-to! trail mark) + (pl-retract-try-each + db + key + (rest remaining) + head-rt + body-rt + (+ idx 1) + trail + k))))))))) + +(define + pl-cut? + (fn (t) (and (list? t) (not (empty? t)) (= (first t) "cut")))) + +(define + pl-list-length + (fn + (t) + (let + ((w (pl-walk t))) + (cond + ((and (pl-atom? w) (= (pl-atom-name w) "[]")) 0) + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (+ 1 (pl-list-length (nth (pl-args w) 1)))) + (true -1))))) + +(define + pl-make-list-of-vars + (fn + (n) + (cond + ((= n 0) (list "atom" "[]")) + (true + (list + "compound" + "." + (list (pl-mk-rt-var "_") (pl-make-list-of-vars (- n 1)))))))) + +(define + pl-between-loop! + (fn + (i hi x-rt trail k) + (cond + ((> i hi) false) + (true + (let + ((mark (pl-trail-mark trail))) + (cond + ((pl-unify! x-rt (list "num" i) trail) + (let + ((r (k))) + (cond + (r true) + (true + (begin + (pl-trail-undo-to! trail mark) + (pl-between-loop! (+ i 1) hi x-rt trail k)))))) + (true + (begin + (pl-trail-undo-to! trail mark) + (pl-between-loop! (+ i 1) hi x-rt trail k))))))))) + +(define + pl-solve-between! + (fn + (low-rt high-rt x-rt trail k) + (let + ((wl (pl-walk low-rt)) (wh (pl-walk high-rt))) + (if + (and (pl-num? wl) (pl-num? wh)) + (pl-between-loop! (pl-num-val wl) (pl-num-val wh) x-rt trail k) + false)))) + +(define + pl-solve-last! + (fn + (list-rt elem-rt trail k) + (let + ((w (pl-walk list-rt))) + (cond + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (let + ((tail (pl-walk (nth (pl-args w) 1)))) + (cond + ((and (pl-atom? tail) (= (pl-atom-name tail) "[]")) + (pl-solve-eq! elem-rt (first (pl-args w)) trail k)) + (true (pl-solve-last! (nth (pl-args w) 1) elem-rt trail k))))) + (true false))))) + +(define + pl-solve-nth0! + (fn + (n list-rt elem-rt trail k) + (let + ((w (pl-walk list-rt))) + (cond + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (cond + ((= n 0) (pl-solve-eq! elem-rt (first (pl-args w)) trail k)) + (true + (pl-solve-nth0! (- n 1) (nth (pl-args w) 1) elem-rt trail k)))) + (true false))))) + +(define + pl-ground? + (fn + (t) + (let + ((w (pl-walk t))) + (cond + ((pl-var? w) false) + ((pl-atom? w) true) + ((pl-num? w) true) + ((pl-str? w) true) + ((pl-compound? w) + (reduce (fn (acc a) (and acc (pl-ground? a))) true (pl-args w))) + (true false))))) + +(define + pl-sort-pairs-dedup + (fn + (pairs) + (cond + ((empty? pairs) (list)) + ((= (len pairs) 1) pairs) + ((= (first (first pairs)) (first (nth pairs 1))) + (pl-sort-pairs-dedup (cons (first pairs) (rest (rest pairs))))) + (true (cons (first pairs) (pl-sort-pairs-dedup (rest pairs))))))) + +(define + pl-list-to-prolog + (fn + (xs) + (if + (empty? xs) + (list "atom" "[]") + (list "compound" "." (list (first xs) (pl-list-to-prolog (rest xs))))))) + +(define + pl-proper-list? + (fn + (t) + (let + ((w (pl-walk t))) + (cond + ((and (pl-atom? w) (= (pl-atom-name w) "[]")) true) + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (pl-proper-list? (nth (pl-args w) 1))) + (true false))))) + +(define + pl-prolog-list-to-sx + (fn + (t) + (let + ((w (pl-walk t))) + (cond + ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list)) + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (cons + (pl-walk (first (pl-args w))) + (pl-prolog-list-to-sx (nth (pl-args w) 1)))) + (true (list)))))) + +(define + pl-solve-atom-concat! + (fn + (a1-rt a2-rt a3-rt trail k) + (let + ((a1 (pl-walk a1-rt)) (a2 (pl-walk a2-rt)) (a3 (pl-walk a3-rt))) + (cond + ((and (pl-atom? a1) (pl-atom? a2)) + (pl-solve-eq! + a3-rt + (list "atom" (str (pl-atom-name a1) (pl-atom-name a2))) + trail + k)) + ((and (pl-atom? a3) (pl-atom? a1)) + (let + ((s3 (pl-atom-name a3)) (s1 (pl-atom-name a1))) + (if + (starts-with? s3 s1) + (pl-solve-eq! + a2-rt + (list "atom" (substring s3 (len s1) (len s3))) + trail + k) + false))) + ((and (pl-atom? a3) (pl-atom? a2)) + (let + ((s3 (pl-atom-name a3)) (s2 (pl-atom-name a2))) + (if + (ends-with? s3 s2) + (pl-solve-eq! + a1-rt + (list "atom" (substring s3 0 (- (len s3) (len s2)))) + trail + k) + false))) + (true false))))) + +;; ── Structural equality helper (for ==/2, \==/2, delete/3) ──────── +(define + pl-solve-atom-chars! + (fn + (atom-rt chars-rt trail k) + (let + ((a (pl-walk atom-rt))) + (cond + ((pl-atom? a) + (pl-solve-eq! + chars-rt + (pl-list-to-prolog + (map (fn (c) (list "atom" c)) (split (pl-atom-name a) ""))) + trail + k)) + ((pl-num? a) + (pl-solve-eq! + chars-rt + (pl-list-to-prolog + (map + (fn (c) (list "atom" c)) + (split (str (pl-num-val a)) ""))) + trail + k)) + ((pl-var? a) + (if + (pl-proper-list? chars-rt) + (let + ((char-terms (pl-prolog-list-to-sx chars-rt))) + (pl-solve-eq! + atom-rt + (list + "atom" + (join "" (map (fn (t) (pl-atom-name t)) char-terms))) + trail + k)) + false)) + (true false))))) + +;; ── Flatten helper: collect all non-list leaves into SX list ─────── +(define + pl-solve-atom-codes! + (fn + (atom-rt codes-rt trail k) + (let + ((a (pl-walk atom-rt))) + (cond + ((pl-atom? a) + (pl-solve-eq! + codes-rt + (pl-list-to-prolog + (map + (fn (c) (list "num" (char-code c))) + (split (pl-atom-name a) ""))) + trail + k)) + ((pl-num? a) + (pl-solve-eq! + codes-rt + (pl-list-to-prolog + (map + (fn (c) (list "num" (char-code c))) + (split (str (pl-num-val a)) ""))) + trail + k)) + ((pl-var? a) + (if + (pl-proper-list? codes-rt) + (let + ((code-terms (pl-prolog-list-to-sx codes-rt))) + (pl-solve-eq! + atom-rt + (list + "atom" + (join + "" + (map + (fn (t) (char-from-code (pl-num-val t))) + code-terms))) + trail + k)) + false)) + (true false))))) + +;; ── numlist helper: build SX list of ("num" i) for i in [lo..hi] ── +(define + pl-solve-char-code! + (fn + (char-rt code-rt trail k) + (let + ((c (pl-walk char-rt)) (n (pl-walk code-rt))) + (cond + ((pl-atom? c) + (let + ((s (pl-atom-name c))) + (if + (= (len s) 1) + (pl-solve-eq! code-rt (list "num" (char-code s)) trail k) + false))) + ((pl-num? n) + (pl-solve-eq! + char-rt + (list "atom" (char-from-code (pl-num-val n))) + trail + k)) + (true false))))) + +;; ── atomic_list_concat helper: collect atom names / num vals ─────── +(define + pl-struct-eq? + (fn + (a b) + (cond + ((and (pl-var? a) (pl-var? b)) + (= (dict-get a :id) (dict-get b :id))) + ((and (pl-atom? a) (pl-atom? b)) + (= (pl-atom-name a) (pl-atom-name b))) + ((and (pl-num? a) (pl-num? b)) (= (pl-num-val a) (pl-num-val b))) + ((and (pl-compound? a) (pl-compound? b)) + (if + (and + (= (pl-fun a) (pl-fun b)) + (= (len (pl-args a)) (len (pl-args b)))) + (let + ((all-eq true) (i 0)) + (begin + (for-each + (fn + (ai) + (begin + (if + (not (pl-struct-eq? ai (nth (pl-args b) i))) + (set! all-eq false) + nil) + (set! i (+ i 1)))) + (pl-args a)) + all-eq)) + false)) + (true false)))) + +;; ── sum_list helper ──────────────────────────────────────────────── +(define + pl-flatten-prolog + (fn + (t) + (let + ((w (pl-walk-deep t))) + (cond + ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list)) + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (let + ((h (pl-walk-deep (first (pl-args w)))) + (tl (nth (pl-args w) 1))) + (if + (or + (and (pl-atom? h) (= (pl-atom-name h) "[]")) + (and (pl-compound? h) (= (pl-fun h) "."))) + (append (pl-flatten-prolog h) (pl-flatten-prolog tl)) + (cons h (pl-flatten-prolog tl))))) + (true (list w)))))) + +;; ── max_list / min_list helpers ──────────────────────────────────── +(define + pl-numlist-build + (fn + (lo hi) + (if + (> lo hi) + (list) + (cons (list "num" lo) (pl-numlist-build (+ lo 1) hi))))) + +(define + pl-atomic-list-collect + (fn + (prolog-list) + (let + ((items (pl-prolog-list-to-sx prolog-list))) + (map + (fn + (item) + (let + ((w (pl-walk-deep item))) + (cond + ((pl-atom? w) (pl-atom-name w)) + ((pl-num? w) (str (pl-num-val w))) + (true "")))) + items)))) + +;; ── delete/3 helper: remove elements struct-equal to elem ────────── +(define + pl-sum-list-sx + (fn + (prolog-list) + (let + ((items (pl-prolog-list-to-sx prolog-list))) + (reduce + (fn (acc item) (+ acc (pl-num-val (pl-walk-deep item)))) + 0 + items)))) + +;; ── join string list with separator ──────────────────────────────── +(define + pl-max-list-sx + (fn + (prolog-list) + (let + ((items (pl-prolog-list-to-sx prolog-list))) + (reduce + (fn + (acc item) + (let + ((v (pl-num-val (pl-walk-deep item)))) + (if (> v acc) v acc))) + (pl-num-val (pl-walk-deep (first items))) + (rest items))))) + +(define + pl-min-list-sx + (fn + (prolog-list) + (let + ((items (pl-prolog-list-to-sx prolog-list))) + (reduce + (fn + (acc item) + (let + ((v (pl-num-val (pl-walk-deep item)))) + (if (< v acc) v acc))) + (pl-num-val (pl-walk-deep (first items))) + (rest items))))) + +(define + pl-delete-sx + (fn + (prolog-list elem) + (let + ((items (pl-prolog-list-to-sx prolog-list)) (ew (pl-walk-deep elem))) + (filter + (fn (item) (not (pl-struct-eq? (pl-walk-deep item) ew))) + items)))) + +(define + pl-join-strings + (fn + (strs sep) + (if + (empty? strs) + "" + (reduce (fn (acc s) (str acc sep s)) (first strs) (rest strs))))) + +(define + pl-apply-goal + (fn + (goal args) + (let + ((w (pl-walk-deep goal))) + (cond + ((pl-atom? w) (list "compound" (pl-atom-name w) args)) + ((pl-compound? w) + (list "compound" (pl-fun w) (append (pl-args w) args))) + (else w))))) + +(define + pl-solve-forall! + (fn + (db cond-g action-g trail cut-box k) + (let + ((mark (pl-trail-mark trail))) + (let + ((found-counterexample (pl-solve! db cond-g trail {:cut false} (fn () (let ((mark2 (pl-trail-mark trail))) (let ((action-ok (pl-solve-once! db action-g trail))) (pl-trail-undo-to! trail mark2) (if action-ok false true))))))) + (pl-trail-undo-to! trail mark) + (if found-counterexample false (k)))))) + +(define + pl-solve-maplist2! + (fn + (db goal lst trail k) + (let + ((l (pl-walk-deep lst))) + (cond + ((and (pl-atom? l) (= (pl-atom-name l) "[]")) (k)) + ((and (pl-compound? l) (= (pl-fun l) ".")) + (let + ((head (first (pl-args l))) (tail (nth (pl-args l) 1))) + (let + ((call-goal (pl-apply-goal goal (list head)))) + (if + (pl-solve-once! db call-goal trail) + (pl-solve-maplist2! db goal tail trail k) + false)))) + (else false))))) + +(define + pl-solve-maplist3! + (fn + (db goal list1 list2 trail k) + (let + ((l1 (pl-walk-deep list1)) (l2 (pl-walk-deep list2))) + (cond + ((and (pl-atom? l1) (= (pl-atom-name l1) "[]")) + (let + ((nil-atom (list "atom" "[]"))) + (if (pl-unify! l2 nil-atom trail) (k) false))) + ((and (pl-compound? l1) (= (pl-fun l1) ".")) + (let + ((h1 (first (pl-args l1))) (t1 (nth (pl-args l1) 1))) + (let + ((h2-var (pl-mk-rt-var "_M"))) + (let + ((call-goal (pl-apply-goal goal (list h1 h2-var)))) + (if + (pl-solve-once! db call-goal trail) + (let + ((t2-var (pl-mk-rt-var "_MT"))) + (let + ((cons2 (list "compound" "." (list h2-var t2-var)))) + (if + (pl-unify! l2 cons2 trail) + (pl-solve-maplist3! db goal t1 t2-var trail k) + false))) + false))))) + (else false))))) + +(define + pl-solve-include! + (fn + (db goal lst result trail k) + (let + ((l (pl-walk-deep lst))) + (cond + ((and (pl-atom? l) (= (pl-atom-name l) "[]")) + (let + ((nil-atom (list "atom" "[]"))) + (if (pl-unify! result nil-atom trail) (k) false))) + ((and (pl-compound? l) (= (pl-fun l) ".")) + (let + ((head (first (pl-args l))) (tail (nth (pl-args l) 1))) + (let + ((call-goal (pl-apply-goal goal (list head)))) + (let + ((included (pl-solve-once! db call-goal trail))) + (if + included + (let + ((rest-var (pl-mk-rt-var "_IR"))) + (let + ((cons-res (list "compound" "." (list head rest-var)))) + (if + (pl-unify! result cons-res trail) + (pl-solve-include! db goal tail rest-var trail k) + false))) + (pl-solve-include! db goal tail result trail k)))))) + (else false))))) + +(define + pl-solve-exclude! + (fn + (db goal lst result trail k) + (let + ((l (pl-walk-deep lst))) + (cond + ((and (pl-atom? l) (= (pl-atom-name l) "[]")) + (let + ((nil-atom (list "atom" "[]"))) + (if (pl-unify! result nil-atom trail) (k) false))) + ((and (pl-compound? l) (= (pl-fun l) ".")) + (let + ((head (first (pl-args l))) (tail (nth (pl-args l) 1))) + (let + ((call-goal (pl-apply-goal goal (list head)))) + (let + ((excluded (pl-solve-once! db call-goal trail))) + (if + excluded + (pl-solve-exclude! db goal tail result trail k) + (let + ((rest-var (pl-mk-rt-var "_ER"))) + (let + ((cons-res (list "compound" "." (list head rest-var)))) + (if + (pl-unify! result cons-res trail) + (pl-solve-exclude! db goal tail rest-var trail k) + false)))))))) + (else false))))) + +(define + pl-solve-foldl! + (fn + (db goal lst vin vout trail k) + (let + ((l (pl-walk-deep lst)) (v0 (pl-walk vin))) + (cond + ((and (pl-atom? l) (= (pl-atom-name l) "[]")) + (if (pl-unify! vout v0 trail) (k) false)) + ((and (pl-compound? l) (= (pl-fun l) ".")) + (let + ((head (first (pl-args l))) (tail (nth (pl-args l) 1))) + (let + ((v1-var (pl-mk-rt-var "_FV"))) + (let + ((call-goal (pl-apply-goal goal (list head v0 v1-var)))) + (if + (pl-solve-once! db call-goal trail) + (pl-solve-foldl! db goal tail v1-var vout trail k) + false))))) + (else false))))) + +(define + pl-list-to-set-sx + (fn + (lst seen) + (if + (empty? lst) + (list) + (let + ((head (first lst)) (tail (rest lst))) + (if + (some (fn (s) (pl-struct-eq? head s)) seen) + (pl-list-to-set-sx tail seen) + (cons head (pl-list-to-set-sx tail (cons head seen)))))))) + +(define + pl-pl-list-contains? + (fn + (pl-lst elem) + (let + ((sx-lst (pl-prolog-list-to-sx (pl-walk-deep pl-lst)))) + (some (fn (x) (pl-struct-eq? elem x)) sx-lst)))) + +(define pl-char-code (fn (atom-term) (char-code (pl-atom-name atom-term)))) + +(define + pl-char-alpha? + (fn + (code) + (or (and (>= code 65) (<= code 90)) (and (>= code 97) (<= code 122))))) + +(define pl-char-digit? (fn (code) (and (>= code 48) (<= code 57)))) + +(define + pl-char-space? + (fn (code) (or (= code 32) (= code 9) (= code 10) (= code 13)))) + +(define pl-char-upper? (fn (code) (and (>= code 65) (<= code 90)))) + +(define pl-char-lower? (fn (code) (and (>= code 97) (<= code 122)))) + +(define + pl-upcase-char + (fn + (c) + (let + ((code (char-code c))) + (if (pl-char-lower? code) (char-from-code (- code 32)) c)))) + +(define + pl-downcase-char + (fn + (c) + (let + ((code (char-code c))) + (if (pl-char-upper? code) (char-from-code (+ code 32)) c)))) + +(define + pl-upcase-string + (fn (s) (join "" (map pl-upcase-char (split s ""))))) + +(define + pl-downcase-string + (fn (s) (join "" (map pl-downcase-char (split s ""))))) + +(define + pl-solve-char-type! + (fn + (db char type-term trail k) + (let + ((ch (pl-walk-deep char)) (tp (pl-walk-deep type-term))) + (if + (not (pl-atom? ch)) + false + (let + ((code (pl-char-code ch))) + (cond + ((and (pl-atom? tp) (= (pl-atom-name tp) "alpha")) + (if (pl-char-alpha? code) (k) false)) + ((and (pl-atom? tp) (= (pl-atom-name tp) "alnum")) + (if + (or (pl-char-alpha? code) (pl-char-digit? code)) + (k) + false)) + ((and (pl-atom? tp) (= (pl-atom-name tp) "digit")) + (if (pl-char-digit? code) (k) false)) + ((and (pl-compound? tp) (= (pl-fun tp) "digit") (= (len (pl-args tp)) 1)) + (if + (pl-char-digit? code) + (let + ((weight (list "num" (- code 48)))) + (if + (pl-unify! (nth (pl-args tp) 0) weight trail) + (k) + false)) + false)) + ((and (pl-atom? tp) (or (= (pl-atom-name tp) "space") (= (pl-atom-name tp) "white"))) + (if (pl-char-space? code) (k) false)) + ((and (pl-compound? tp) (= (pl-fun tp) "upper") (= (len (pl-args tp)) 1)) + (if + (pl-char-upper? code) + (let + ((lower-atom (list "atom" (char-from-code (+ code 32))))) + (if + (pl-unify! (nth (pl-args tp) 0) lower-atom trail) + (k) + false)) + false)) + ((and (pl-compound? tp) (= (pl-fun tp) "lower") (= (len (pl-args tp)) 1)) + (if + (pl-char-lower? code) + (let + ((upper-atom (list "atom" (char-from-code (- code 32))))) + (if + (pl-unify! (nth (pl-args tp) 0) upper-atom trail) + (k) + false)) + false)) + ((and (pl-compound? tp) (= (pl-fun tp) "ascii") (= (len (pl-args tp)) 1)) + (if + (< code 128) + (let + ((code-term (list "num" code))) + (if + (pl-unify! (nth (pl-args tp) 0) code-term trail) + (k) + false)) + false)) + ((and (pl-atom? tp) (= (pl-atom-name tp) "punct")) + (if + (and + (not (pl-char-alpha? code)) + (not (pl-char-digit? code)) + (not (pl-char-space? code)) + (< code 128)) + (k) + false)) + (else false))))))) + +(define + pl-solve-upcase-atom! + (fn + (atom-rt result-rt trail k) + (let + ((a (pl-walk atom-rt))) + (if + (pl-atom? a) + (pl-solve-eq! + result-rt + (list "atom" (pl-upcase-string (pl-atom-name a))) + trail + k) + false)))) + +(define + pl-solve-downcase-atom! + (fn + (atom-rt result-rt trail k) + (let + ((a (pl-walk atom-rt))) + (if + (pl-atom? a) + (pl-solve-eq! + result-rt + (list "atom" (pl-downcase-string (pl-atom-name a))) + trail + k) + false)))) + +(define + pl-format-process + (fn + (fmt-str args-list) + (let + ((chars (split fmt-str "")) (result "") (remaining args-list)) + (define + do-char + (fn + (cs r rem) + (cond + ((empty? cs) r) + ((= (first cs) "~") + (if + (empty? (rest cs)) + (str r "~") + (let + ((directive (first (rest cs))) (tail (rest (rest cs)))) + (cond + ((= directive "n") (do-char tail (str r "\n") rem)) + ((= directive "N") (do-char tail (str r "\n") rem)) + ((= directive "t") (do-char tail (str r "\t") rem)) + ((= directive "~") (do-char tail (str r "~") rem)) + ((= directive "w") + (if + (empty? rem) + (do-char tail (str r "?") rem) + (do-char + tail + (str r (pl-format-term (first rem))) + (rest rem)))) + ((= directive "a") + (if + (empty? rem) + (do-char tail (str r "?") rem) + (do-char + tail + (str r (pl-format-term (first rem))) + (rest rem)))) + ((= directive "d") + (if + (empty? rem) + (do-char tail (str r "?") rem) + (do-char + tail + (str r (pl-format-term (first rem))) + (rest rem)))) + (true (do-char tail (str r "~" directive) rem)))))) + (true (do-char (rest cs) (str r (first cs)) rem))))) + (do-char chars "" args-list)))) + +(define + pl-solve-term-to-atom! + (fn + (term-arg atom-arg trail k) + (let + ((t-walked (pl-walk term-arg)) (a-walked (pl-walk atom-arg))) + (cond + ((not (pl-var? t-walked)) + (let + ((formatted (pl-format-term t-walked))) + (let + ((result-atom (list "atom" formatted))) + (if (pl-unify! atom-arg result-atom trail) (k) false)))) + ((and (pl-var? t-walked) (pl-atom? a-walked)) + (let + ((atom-str (pl-atom-name a-walked))) + (let + ((parsed (pl-parse (str atom-str ".")))) + (if + (and (list? parsed) (> (len parsed) 0)) + (let + ((clause (first parsed))) + (let + ((actual-term (if (and (list? clause) (= (len clause) 3) (= (nth clause 0) "clause")) (nth clause 1) clause))) + (let + ((fresh (pl-instantiate actual-term {}))) + (if (pl-unify! term-arg fresh trail) (k) false)))) + false)))) + (true false))))) + +(define + pl-solve-with-output-to! + (fn + (db sink goal trail cut-box k) + (let + ((sink-walked (pl-walk-deep sink))) + (if + (and + (pl-compound? sink-walked) + (or + (= (pl-fun sink-walked) "atom") + (= (pl-fun sink-walked) "string")) + (= (len (pl-args sink-walked)) 1)) + (let + ((var (first (pl-args sink-walked))) + (saved-buffer pl-output-buffer)) + (do + (set! pl-output-buffer "") + (let + ((result (pl-solve-once! db goal trail))) + (let + ((captured pl-output-buffer)) + (do + (set! pl-output-buffer saved-buffer) + (if + result + (if + (pl-unify! var (list "atom" captured) trail) + (k) + false) + false)))))) + false)))) + + +(define + pl-solve-writeln! + (fn + (term-arg k) + (do + (pl-output-write! (pl-format-term term-arg)) + (pl-output-write! "\n") + (k)))) + +(define + pl-solve-format-1! + (fn + (fmt-arg k) + (let + ((fmt-walked (pl-walk-deep fmt-arg))) + (if + (pl-atom? fmt-walked) + (do + (pl-output-write! + (pl-format-process (pl-atom-name fmt-walked) (list))) + (k)) + false)))) + +(define + pl-solve-format-2! + (fn + (db fmt-arg args-arg trail k) + (let + ((fmt-walked (pl-walk-deep fmt-arg)) + (args-walked (pl-walk-deep args-arg))) + (if + (pl-atom? fmt-walked) + (let + ((args-sx (pl-prolog-list-to-sx args-walked))) + (do + (pl-output-write! + (pl-format-process (pl-atom-name fmt-walked) args-sx)) + (k))) + false)))) + +(define + pl-substring + (fn (s start sublen) (substring s start (+ start sublen)))) + +(define + pl-sub-atom-try-one! + (fn + (s start sublen total-len before-arg len-arg after-arg sub-arg trail k) + (let + ((mark (pl-trail-mark trail)) + (after-val (- total-len (+ start sublen))) + (sub (pl-substring s start sublen))) + (if + (and + (pl-unify! before-arg (list "num" start) trail) + (pl-unify! len-arg (list "num" sublen) trail) + (pl-unify! after-arg (list "num" after-val) trail) + (pl-unify! sub-arg (list "atom" sub) trail)) + (let + ((kresult (k))) + (if kresult kresult (begin (pl-trail-undo-to! trail mark) false))) + (begin (pl-trail-undo-to! trail mark) false))))) + +(define + pl-sub-atom-loop! + (fn + (s total-len start sublen before-arg len-arg after-arg sub-arg trail k) + (cond + ((> start total-len) false) + ((> sublen (- total-len start)) + (pl-sub-atom-loop! + s + total-len + (+ start 1) + 0 + before-arg + len-arg + after-arg + sub-arg + trail + k)) + (true + (let + ((one-result (pl-sub-atom-try-one! s start sublen total-len before-arg len-arg after-arg sub-arg trail k))) + (if + one-result + one-result + (pl-sub-atom-loop! + s + total-len + start + (+ sublen 1) + before-arg + len-arg + after-arg + sub-arg + trail + k))))))) + +(define + pl-solve-aggregate-all! + (fn + (db tmpl goal result trail k) + (let + ((tmpl-walked (pl-walk-deep tmpl))) + (cond + ((and (pl-atom? tmpl-walked) (= (pl-atom-name tmpl-walked) "count")) + (let + ((solutions (pl-collect-solutions db (list "atom" "true") goal trail))) + (if + (pl-unify! result (list "num" (len solutions)) trail) + (k) + false))) + ((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "bag") (= (len (pl-args tmpl-walked)) 1)) + (let + ((template (nth (pl-args tmpl-walked) 0))) + (let + ((solutions (pl-collect-solutions db template goal trail))) + (let + ((prolog-list (pl-mk-list-term solutions (pl-nil-term)))) + (if (pl-unify! result prolog-list trail) (k) false))))) + ((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "sum") (= (len (pl-args tmpl-walked)) 1)) + (let + ((template (nth (pl-args tmpl-walked) 0))) + (let + ((solutions (pl-collect-solutions db template goal trail))) + (let + ((total (reduce (fn (acc sol) (+ acc (pl-eval-arith sol))) 0 solutions))) + (if (pl-unify! result (list "num" total) trail) (k) false))))) + ((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "max") (= (len (pl-args tmpl-walked)) 1)) + (let + ((template (nth (pl-args tmpl-walked) 0))) + (let + ((solutions (pl-collect-solutions db template goal trail))) + (if + (empty? solutions) + false + (let + ((vals (map pl-eval-arith solutions))) + (let + ((mx (reduce (fn (a b) (if (> a b) a b)) (first vals) (rest vals)))) + (if (pl-unify! result (list "num" mx) trail) (k) false))))))) + ((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "min") (= (len (pl-args tmpl-walked)) 1)) + (let + ((template (nth (pl-args tmpl-walked) 0))) + (let + ((solutions (pl-collect-solutions db template goal trail))) + (if + (empty? solutions) + false + (let + ((vals (map pl-eval-arith solutions))) + (let + ((mn (reduce (fn (a b) (if (< a b) a b)) (first vals) (rest vals)))) + (if (pl-unify! result (list "num" mn) trail) (k) false))))))) + ((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "set") (= (len (pl-args tmpl-walked)) 1)) + (let + ((template (nth (pl-args tmpl-walked) 0))) + (let + ((solutions (pl-collect-solutions db template goal trail))) + (let + ((deduped (pl-list-to-set-sx solutions (list)))) + (let + ((keyed (map (fn (t) (list (pl-format-term t) t)) deduped))) + (let + ((sorted (sort keyed))) + (let + ((sorted-terms (map (fn (pair) (nth pair 1)) sorted))) + (let + ((prolog-list (pl-mk-list-term sorted-terms (pl-nil-term)))) + (if (pl-unify! result prolog-list trail) (k) false))))))))) + (true false))))) + +(define + pl-solve! + (fn + (db goal trail cut-box k) + (let + ((g (pl-walk goal))) + (cond + ((pl-var? g) false) + ((pl-cut? g) (begin (dict-set! cut-box :cut true) (k))) + ((and (pl-atom? g) (= (pl-atom-name g) "true")) (k)) + ((and (pl-atom? g) (= (pl-atom-name g) "fail")) false) + ((and (pl-atom? g) (= (pl-atom-name g) "nl")) + (begin (pl-output-write! "\n") (k))) + ((and (pl-compound? g) (= (pl-fun g) "=") (= (len (pl-args g)) 2)) + (pl-solve-eq! (first (pl-args g)) (nth (pl-args g) 1) trail k)) + ((and (pl-compound? g) (= (pl-fun g) "\\=") (= (len (pl-args g)) 2)) + (pl-solve-not-eq! + (first (pl-args g)) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "is") (= (len (pl-args g)) 2)) + (pl-solve-eq! + (first (pl-args g)) + (list "num" (pl-eval-arith (nth (pl-args g) 1))) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "<") (= (len (pl-args g)) 2)) + (cond + ((< (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1))) + (k)) + (true false))) + ((and (pl-compound? g) (= (pl-fun g) ">") (= (len (pl-args g)) 2)) + (cond + ((> (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1))) + (k)) + (true false))) + ((and (pl-compound? g) (= (pl-fun g) "=<") (= (len (pl-args g)) 2)) + (cond + ((<= (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1))) + (k)) + (true false))) + ((and (pl-compound? g) (= (pl-fun g) ">=") (= (len (pl-args g)) 2)) + (cond + ((>= (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1))) + (k)) + (true false))) + ((and (pl-compound? g) (= (pl-fun g) ",") (= (len (pl-args g)) 2)) + (pl-solve! + db + (first (pl-args g)) + trail + cut-box + (fn () (pl-solve! db (nth (pl-args g) 1) trail cut-box k)))) + ((and (pl-compound? g) (= (pl-fun g) ";") (= (len (pl-args g)) 2)) + (pl-solve-or! + db + (first (pl-args g)) + (nth (pl-args g) 1) + trail + cut-box + k)) + ((and (pl-compound? g) (= (pl-fun g) "->") (= (len (pl-args g)) 2)) + (pl-solve-if-then-else! + db + (first (pl-args g)) + (nth (pl-args g) 1) + (list "atom" "fail") + trail + cut-box + k)) + ((and (pl-compound? g) (= (pl-fun g) "call") (= (len (pl-args g)) 1)) + (let + ((call-cb {:cut false})) + (pl-solve! db (first (pl-args g)) trail call-cb k))) + ((and (pl-compound? g) (= (pl-fun g) "write") (= (len (pl-args g)) 1)) + (begin + (pl-output-write! (pl-format-term (first (pl-args g)))) + (k))) + ((and (pl-compound? g) (= (pl-fun g) "assertz") (= (len (pl-args g)) 1)) + (pl-solve-assertz! db (first (pl-args g)) k)) + ((and (pl-compound? g) (= (pl-fun g) "assert") (= (len (pl-args g)) 1)) + (pl-solve-assertz! db (first (pl-args g)) k)) + ((and (pl-compound? g) (= (pl-fun g) "asserta") (= (len (pl-args g)) 1)) + (pl-solve-asserta! db (first (pl-args g)) k)) + ((and (pl-compound? g) (= (pl-fun g) "retract") (= (len (pl-args g)) 1)) + (pl-solve-retract! db (first (pl-args g)) trail k)) + ((and (pl-compound? g) (= (pl-fun g) "findall") (= (len (pl-args g)) 3)) + (pl-solve-findall! + db + (first (pl-args g)) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "bagof") (= (len (pl-args g)) 3)) + (pl-solve-bagof! + db + (first (pl-args g)) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "setof") (= (len (pl-args g)) 3)) + (pl-solve-setof! + db + (first (pl-args g)) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "copy_term") (= (len (pl-args g)) 2)) + (pl-solve-eq! + (nth (pl-args g) 1) + (pl-deep-copy (first (pl-args g)) {}) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "functor") (= (len (pl-args g)) 3)) + (pl-solve-functor! + (first (pl-args g)) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "arg") (= (len (pl-args g)) 3)) + (pl-solve-arg! + (first (pl-args g)) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "var") (= (len (pl-args g)) 1)) + (let + ((a (pl-walk (first (pl-args g))))) + (if (pl-var? a) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "nonvar") (= (len (pl-args g)) 1)) + (let + ((a (pl-walk (first (pl-args g))))) + (if (not (pl-var? a)) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "atom") (= (len (pl-args g)) 1)) + (let + ((a (pl-walk (first (pl-args g))))) + (if (pl-atom? a) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "number") (= (len (pl-args g)) 1)) + (let + ((a (pl-walk (first (pl-args g))))) + (if (pl-num? a) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "integer") (= (len (pl-args g)) 1)) + (let + ((a (pl-walk (first (pl-args g))))) + (if (pl-num? a) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "float") (= (len (pl-args g)) 1)) + false) + ((and (pl-compound? g) (= (pl-fun g) "compound") (= (len (pl-args g)) 1)) + (let + ((a (pl-walk (first (pl-args g))))) + (if (pl-compound? a) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "callable") (= (len (pl-args g)) 1)) + (let + ((a (pl-walk (first (pl-args g))))) + (if (or (pl-atom? a) (pl-compound? a)) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "atomic") (= (len (pl-args g)) 1)) + (let + ((a (pl-walk (first (pl-args g))))) + (if (or (pl-atom? a) (or (pl-num? a) (pl-str? a))) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "is_list") (= (len (pl-args g)) 1)) + (if (pl-proper-list? (first (pl-args g))) (k) false)) + ((and (pl-compound? g) (= (pl-fun g) "atom_length") (= (len (pl-args g)) 2)) + (let + ((a (pl-walk (first (pl-args g))))) + (if + (pl-atom? a) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "num" (len (pl-atom-name a))) + trail + k) + false))) + ((and (pl-compound? g) (= (pl-fun g) "atom_concat") (= (len (pl-args g)) 3)) + (pl-solve-atom-concat! + (first (pl-args g)) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "atom_chars") (= (len (pl-args g)) 2)) + (pl-solve-atom-chars! + (first (pl-args g)) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "atom_codes") (= (len (pl-args g)) 2)) + (pl-solve-atom-codes! + (first (pl-args g)) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "char_code") (= (len (pl-args g)) 2)) + (pl-solve-char-code! + (first (pl-args g)) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "number_codes") (= (len (pl-args g)) 2)) + (let + ((a (pl-walk (first (pl-args g))))) + (if + (pl-num? a) + (pl-solve-eq! + (nth (pl-args g) 1) + (pl-list-to-prolog + (map + (fn (c) (list "num" (char-code c))) + (split (str (pl-num-val a)) ""))) + trail + k) + false))) + ((and (pl-compound? g) (= (pl-fun g) "number_chars") (= (len (pl-args g)) 2)) + (let + ((a (pl-walk (first (pl-args g))))) + (if + (pl-num? a) + (pl-solve-eq! + (nth (pl-args g) 1) + (pl-list-to-prolog + (map + (fn (c) (list "atom" c)) + (split (str (pl-num-val a)) ""))) + trail + k) + false))) + ((and (pl-compound? g) (= (pl-fun g) "succ") (= (len (pl-args g)) 2)) + (let + ((wa (pl-walk (first (pl-args g)))) + (wb (pl-walk (nth (pl-args g) 1)))) + (cond + ((pl-num? wa) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "num" (+ (pl-num-val wa) 1)) + trail + k)) + ((pl-num? wb) + (if + (> (pl-num-val wb) 0) + (pl-solve-eq! + (first (pl-args g)) + (list "num" (- (pl-num-val wb) 1)) + trail + k) + false)) + (true false)))) + ((and (pl-compound? g) (= (pl-fun g) "plus") (= (len (pl-args g)) 3)) + (let + ((wa (pl-walk (first (pl-args g)))) + (wb (pl-walk (nth (pl-args g) 1))) + (wc (pl-walk (nth (pl-args g) 2)))) + (cond + ((and (pl-num? wa) (pl-num? wb)) + (pl-solve-eq! + (nth (pl-args g) 2) + (list "num" (+ (pl-num-val wa) (pl-num-val wb))) + trail + k)) + ((and (pl-num? wa) (pl-num? wc)) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "num" (- (pl-num-val wc) (pl-num-val wa))) + trail + k)) + ((and (pl-num? wb) (pl-num? wc)) + (pl-solve-eq! + (first (pl-args g)) + (list "num" (- (pl-num-val wc) (pl-num-val wb))) + trail + k)) + (true false)))) + ((and (pl-compound? g) (= (pl-fun g) "between") (= (len (pl-args g)) 3)) + (pl-solve-between! + (first (pl-args g)) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "length") (= (len (pl-args g)) 2)) + (let + ((wl (pl-walk (first (pl-args g)))) + (wn (pl-walk (nth (pl-args g) 1)))) + (cond + ((pl-proper-list? (first (pl-args g))) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "num" (pl-list-length (first (pl-args g)))) + trail + k)) + ((and (pl-var? wl) (pl-num? wn)) + (if + (>= (pl-num-val wn) 0) + (pl-solve-eq! + (first (pl-args g)) + (pl-make-list-of-vars (pl-num-val wn)) + trail + k) + false)) + (true false)))) + ((and (pl-compound? g) (= (pl-fun g) "last") (= (len (pl-args g)) 2)) + (pl-solve-last! (first (pl-args g)) (nth (pl-args g) 1) trail k)) + ((and (pl-compound? g) (= (pl-fun g) "nth0") (= (len (pl-args g)) 3)) + (let + ((wn (pl-walk (first (pl-args g))))) + (if + (pl-num? wn) + (pl-solve-nth0! + (pl-num-val wn) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k) + false))) + ((and (pl-compound? g) (= (pl-fun g) "nth1") (= (len (pl-args g)) 3)) + (let + ((wn (pl-walk (first (pl-args g))))) + (if + (and (pl-num? wn) (> (pl-num-val wn) 0)) + (pl-solve-nth0! + (- (pl-num-val wn) 1) + (nth (pl-args g) 1) + (nth (pl-args g) 2) + trail + k) + false))) + ((and (pl-compound? g) (= (pl-fun g) "\\+") (= (len (pl-args g)) 1)) + (let + ((mark (pl-trail-mark trail))) + (let + ((r (pl-solve! db (first (pl-args g)) trail {:cut false} (fn () true)))) + (pl-trail-undo-to! trail mark) + (if r false (k))))) + ((and (pl-compound? g) (= (pl-fun g) "not") (= (len (pl-args g)) 1)) + (let + ((mark (pl-trail-mark trail))) + (let + ((r (pl-solve! db (first (pl-args g)) trail {:cut false} (fn () true)))) + (pl-trail-undo-to! trail mark) + (if r false (k))))) + ((and (pl-compound? g) (= (pl-fun g) "once") (= (len (pl-args g)) 1)) + (pl-solve-if-then-else! + db + (first (pl-args g)) + (list "atom" "true") + (list "atom" "fail") + trail + cut-box + k)) + ((and (pl-compound? g) (= (pl-fun g) "ignore") (= (len (pl-args g)) 1)) + (pl-solve-if-then-else! + db + (first (pl-args g)) + (list "atom" "true") + (list "atom" "true") + trail + cut-box + k)) + ((and (pl-compound? g) (= (pl-fun g) "ground") (= (len (pl-args g)) 1)) + (if (pl-ground? (first (pl-args g))) (k) false)) + ((and (pl-compound? g) (= (pl-fun g) "sort") (= (len (pl-args g)) 2)) + (let + ((elems (pl-prolog-list-to-sx (first (pl-args g))))) + (let + ((keyed (map (fn (e) (list (pl-format-term e) e)) elems))) + (let + ((sorted (sort keyed))) + (let + ((deduped (pl-sort-pairs-dedup sorted))) + (pl-solve-eq! + (nth (pl-args g) 1) + (pl-list-to-prolog (map (fn (p) (nth p 1)) deduped)) + trail + k)))))) + ((and (pl-compound? g) (= (pl-fun g) "msort") (= (len (pl-args g)) 2)) + (let + ((elems (pl-prolog-list-to-sx (first (pl-args g))))) + (let + ((keyed (map (fn (e) (list (pl-format-term e) e)) elems))) + (let + ((sorted (sort keyed))) + (pl-solve-eq! + (nth (pl-args g) 1) + (pl-list-to-prolog (map (fn (p) (nth p 1)) sorted)) + trail + k))))) + ((and (pl-compound? g) (= (pl-fun g) "atom_number") (= (len (pl-args g)) 2)) + (let + ((wa (pl-walk (first (pl-args g)))) + (wb (pl-walk (nth (pl-args g) 1)))) + (cond + ((pl-atom? wa) + (let + ((n (parse-number (pl-atom-name wa)))) + (if + (nil? n) + false + (pl-solve-eq! + (nth (pl-args g) 1) + (list "num" n) + trail + k)))) + ((pl-num? wb) + (pl-solve-eq! + (first (pl-args g)) + (list "atom" (str (pl-num-val wb))) + trail + k)) + (true false)))) + ((and (pl-compound? g) (= (pl-fun g) "number_string") (= (len (pl-args g)) 2)) + (let + ((wa (pl-walk (first (pl-args g)))) + (wb (pl-walk (nth (pl-args g) 1)))) + (cond + ((pl-num? wa) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "atom" (str (pl-num-val wa))) + trail + k)) + ((pl-var? wa) + (if + (pl-atom? wb) + (let + ((n (parse-number (pl-atom-name wb)))) + (if + (nil? n) + false + (pl-solve-eq! + (first (pl-args g)) + (list "num" n) + trail + k))) + false)) + (true false)))) + ((and (pl-compound? g) (= (pl-fun g) "==") (= (len (pl-args g)) 2)) + (let + ((a (pl-walk-deep (first (pl-args g)))) + (b (pl-walk-deep (nth (pl-args g) 1)))) + (if (pl-struct-eq? a b) (k) false))) + ((and (pl-compound? g) (= (pl-fun g) "\\==") (= (len (pl-args g)) 2)) + (let + ((a (pl-walk-deep (first (pl-args g)))) + (b (pl-walk-deep (nth (pl-args g) 1)))) + (if (pl-struct-eq? a b) false (k)))) + ((and (pl-compound? g) (= (pl-fun g) "flatten") (= (len (pl-args g)) 2)) + (let + ((lst-rt (pl-walk (first (pl-args g))))) + (if + (pl-proper-list? lst-rt) + (let + ((flat-sx (pl-flatten-prolog lst-rt))) + (pl-solve-eq! + (nth (pl-args g) 1) + (pl-list-to-prolog flat-sx) + trail + k)) + false))) + ((and (pl-compound? g) (= (pl-fun g) "numlist") (= (len (pl-args g)) 3)) + (let + ((wlo (pl-walk-deep (first (pl-args g)))) + (whi (pl-walk-deep (nth (pl-args g) 1)))) + (if + (and (pl-num? wlo) (pl-num? whi)) + (let + ((lo (pl-num-val wlo)) (hi (pl-num-val whi))) + (if + (> lo hi) + false + (pl-solve-eq! + (nth (pl-args g) 2) + (pl-list-to-prolog (pl-numlist-build lo hi)) + trail + k))) + false))) + ((and (pl-compound? g) (= (pl-fun g) "atomic_list_concat") (= (len (pl-args g)) 2)) + (let + ((lst-rt (pl-walk (first (pl-args g))))) + (if + (pl-proper-list? lst-rt) + (let + ((strs (pl-atomic-list-collect lst-rt))) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "atom" (reduce (fn (a b) (str a b)) "" strs)) + trail + k)) + false))) + ((and (pl-compound? g) (= (pl-fun g) "atomic_list_concat") (= (len (pl-args g)) 3)) + (let + ((lst-rt (pl-walk (first (pl-args g)))) + (sep-rt (pl-walk-deep (nth (pl-args g) 1)))) + (if + (and (pl-proper-list? lst-rt) (pl-atom? sep-rt)) + (let + ((strs (pl-atomic-list-collect lst-rt)) + (sep (pl-atom-name sep-rt))) + (pl-solve-eq! + (nth (pl-args g) 2) + (list "atom" (pl-join-strings strs sep)) + trail + k)) + false))) + ((and (pl-compound? g) (= (pl-fun g) "sum_list") (= (len (pl-args g)) 2)) + (let + ((lst-rt (pl-walk (first (pl-args g))))) + (if + (pl-proper-list? lst-rt) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "num" (pl-sum-list-sx lst-rt)) + trail + k) + false))) + ((and (pl-compound? g) (= (pl-fun g) "max_list") (= (len (pl-args g)) 2)) + (let + ((lst-rt (pl-walk (first (pl-args g))))) + (if + (and + (pl-proper-list? lst-rt) + (not + (and (pl-atom? lst-rt) (= (pl-atom-name lst-rt) "[]")))) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "num" (pl-max-list-sx lst-rt)) + trail + k) + false))) + ((and (pl-compound? g) (= (pl-fun g) "min_list") (= (len (pl-args g)) 2)) + (let + ((lst-rt (pl-walk (first (pl-args g))))) + (if + (and + (pl-proper-list? lst-rt) + (not + (and (pl-atom? lst-rt) (= (pl-atom-name lst-rt) "[]")))) + (pl-solve-eq! + (nth (pl-args g) 1) + (list "num" (pl-min-list-sx lst-rt)) + trail + k) + false))) + ((and (pl-compound? g) (= (pl-fun g) "delete") (= (len (pl-args g)) 3)) + (let + ((lst-rt (pl-walk (first (pl-args g)))) + (elem-rt (nth (pl-args g) 1))) + (if + (pl-proper-list? lst-rt) + (let + ((filtered (pl-delete-sx lst-rt elem-rt))) + (pl-solve-eq! + (nth (pl-args g) 2) + (pl-list-to-prolog filtered) + trail + k)) + false))) + ((and (pl-compound? g) (= (pl-fun g) "exclude") (= (len (pl-args g)) 3)) + (let + ((exc-goal (pl-walk (first (pl-args g)))) + (exc-lst (pl-walk (nth (pl-args g) 1))) + (exc-res (pl-walk (nth (pl-args g) 2)))) + (pl-solve-exclude! db exc-goal exc-lst exc-res trail k))) + ((and (pl-compound? g) (= (pl-fun g) "include") (= (len (pl-args g)) 3)) + (let + ((inc-goal (pl-walk (first (pl-args g)))) + (inc-lst (pl-walk (nth (pl-args g) 1))) + (inc-res (pl-walk (nth (pl-args g) 2)))) + (pl-solve-include! db inc-goal inc-lst inc-res trail k))) + ((and (pl-compound? g) (= (pl-fun g) "maplist") (= (len (pl-args g)) 3)) + (let + ((ml-goal (pl-walk (first (pl-args g)))) + (ml-l1 (pl-walk (nth (pl-args g) 1))) + (ml-l2 (pl-walk (nth (pl-args g) 2)))) + (pl-solve-maplist3! db ml-goal ml-l1 ml-l2 trail k))) + ((and (pl-compound? g) (= (pl-fun g) "maplist") (= (len (pl-args g)) 2)) + (let + ((ml-goal (pl-walk (first (pl-args g)))) + (ml-lst (pl-walk (nth (pl-args g) 1)))) + (pl-solve-maplist2! db ml-goal ml-lst trail k))) + ((and (pl-compound? g) (= (pl-fun g) "forall") (= (len (pl-args g)) 2)) + (let + ((cond-g (pl-walk (first (pl-args g)))) + (action-g (pl-walk (nth (pl-args g) 1)))) + (pl-solve-forall! db cond-g action-g trail cut-box k))) + ((and (pl-compound? g) (= (pl-fun g) "foldl") (= (len (pl-args g)) 4)) + (pl-solve-foldl! + db + (pl-walk (first (pl-args g))) + (pl-walk (nth (pl-args g) 1)) + (pl-walk (nth (pl-args g) 2)) + (pl-walk (nth (pl-args g) 3)) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "list_to_set") (= (len (pl-args g)) 2)) + (let + ((lst-rt (pl-walk (first (pl-args g)))) + (res-rt (pl-walk (nth (pl-args g) 1)))) + (if + (pl-proper-list? lst-rt) + (let + ((sx-lst (map (fn (x) (pl-walk-deep x)) (pl-prolog-list-to-sx lst-rt)))) + (let + ((unique-lst (pl-list-to-set-sx sx-lst (list)))) + (pl-solve-eq! res-rt (pl-list-to-prolog unique-lst) trail k))) + false))) + ((and (pl-compound? g) (= (pl-fun g) "intersection") (= (len (pl-args g)) 3)) + (let + ((s1-rt (pl-walk (first (pl-args g)))) + (s2-rt (pl-walk (nth (pl-args g) 1))) + (res-rt (pl-walk (nth (pl-args g) 2)))) + (if + (and (pl-proper-list? s1-rt) (pl-proper-list? s2-rt)) + (let + ((s1-sx (map (fn (x) (pl-walk-deep x)) (pl-prolog-list-to-sx s1-rt))) + (s2-sx + (map + (fn (x) (pl-walk-deep x)) + (pl-prolog-list-to-sx s2-rt)))) + (let + ((inter (filter (fn (x) (some (fn (y) (pl-struct-eq? x y)) s2-sx)) s1-sx))) + (pl-solve-eq! res-rt (pl-list-to-prolog inter) trail k))) + false))) + ((and (pl-compound? g) (= (pl-fun g) "subtract") (= (len (pl-args g)) 3)) + (let + ((s1-rt (pl-walk (first (pl-args g)))) + (s2-rt (pl-walk (nth (pl-args g) 1))) + (res-rt (pl-walk (nth (pl-args g) 2)))) + (if + (and (pl-proper-list? s1-rt) (pl-proper-list? s2-rt)) + (let + ((s1-sx (map (fn (x) (pl-walk-deep x)) (pl-prolog-list-to-sx s1-rt))) + (s2-sx + (map + (fn (x) (pl-walk-deep x)) + (pl-prolog-list-to-sx s2-rt)))) + (let + ((diff (filter (fn (x) (not (some (fn (y) (pl-struct-eq? x y)) s2-sx))) s1-sx))) + (pl-solve-eq! res-rt (pl-list-to-prolog diff) trail k))) + false))) + ((and (pl-compound? g) (= (pl-fun g) "union") (= (len (pl-args g)) 3)) + (let + ((s1-rt (pl-walk (first (pl-args g)))) + (s2-rt (pl-walk (nth (pl-args g) 1))) + (res-rt (pl-walk (nth (pl-args g) 2)))) + (if + (and (pl-proper-list? s1-rt) (pl-proper-list? s2-rt)) + (let + ((s1-sx (map (fn (x) (pl-walk-deep x)) (pl-prolog-list-to-sx s1-rt))) + (s2-sx + (map + (fn (x) (pl-walk-deep x)) + (pl-prolog-list-to-sx s2-rt)))) + (let + ((s2-only (filter (fn (x) (not (some (fn (y) (pl-struct-eq? x y)) s1-sx))) s2-sx))) + (let + ((union-lst (append s1-sx s2-only))) + (pl-solve-eq! + res-rt + (pl-list-to-prolog union-lst) + trail + k)))) + false))) + ((and (pl-compound? g) (= (pl-fun g) "char_type") (= (len (pl-args g)) 2)) + (pl-solve-char-type! + db + (pl-walk (nth (pl-args g) 0)) + (pl-walk (nth (pl-args g) 1)) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "upcase_atom") (= (len (pl-args g)) 2)) + (pl-solve-upcase-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "downcase_atom") (= (len (pl-args g)) 2)) + (pl-solve-downcase-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "string_upper") (= (len (pl-args g)) 2)) + (pl-solve-upcase-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "string_lower") (= (len (pl-args g)) 2)) + (pl-solve-downcase-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "term_to_atom") (= (len (pl-args g)) 2)) + (pl-solve-term-to-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "term_string") (= (len (pl-args g)) 2)) + (pl-solve-term-to-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "with_output_to") (= (len (pl-args g)) 2)) + (pl-solve-with-output-to! + db + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + cut-box + k)) + ((and (pl-compound? g) (= (pl-fun g) "writeln") (= (len (pl-args g)) 1)) + (pl-solve-writeln! (nth (pl-args g) 0) k)) + ((and (pl-compound? g) (= (pl-fun g) "format") (= (len (pl-args g)) 1)) + (pl-solve-format-1! (nth (pl-args g) 0) k)) + ((and (pl-compound? g) (= (pl-fun g) "format") (= (len (pl-args g)) 2)) + (pl-solve-format-2! + db + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "sub_atom") (= (len (pl-args g)) 5)) + (let + ((atom-term (pl-walk-deep (nth (pl-args g) 0)))) + (if + (pl-atom? atom-term) + (let + ((s (pl-atom-name atom-term)) + (total-len (len (pl-atom-name atom-term)))) + (pl-sub-atom-loop! + s + total-len + 0 + 0 + (pl-walk (nth (pl-args g) 1)) + (pl-walk (nth (pl-args g) 2)) + (pl-walk (nth (pl-args g) 3)) + (pl-walk (nth (pl-args g) 4)) + trail + k)) + false))) + ((and (pl-compound? g) (= (pl-fun g) "aggregate_all") (= (len (pl-args g)) 3)) + (pl-solve-aggregate-all! + db + (pl-walk (nth (pl-args g) 0)) + (pl-walk (nth (pl-args g) 1)) + (pl-walk (nth (pl-args g) 2)) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "term_variables") (= (len (pl-args g)) 2)) + (let + ((term (pl-walk (nth (pl-args g) 0))) + (vars-arg (pl-walk (nth (pl-args g) 1)))) + (let + ((result (pl-collect-vars term (list)))) + (let + ((var-list (nth result 1))) + (let + ((prolog-vars (pl-list-to-prolog var-list))) + (if (pl-unify! vars-arg prolog-vars trail) (k) false)))))) + ((and (pl-compound? g) (= (pl-fun g) "predsort") (= (len (pl-args g)) 3)) + (let + ((pred (pl-walk (nth (pl-args g) 0))) + (list-arg (pl-walk (nth (pl-args g) 1))) + (result-arg (pl-walk (nth (pl-args g) 2)))) + (let + ((items (pl-prolog-list-to-sx (pl-walk-deep list-arg)))) + (let + ((sorted (pl-predsort-build! db pred items trail))) + (if + sorted + (let + ((prolog-sorted (pl-list-to-prolog sorted))) + (if (pl-unify! result-arg prolog-sorted trail) (k) false)) + false))))) + (true (pl-solve-user! db g trail cut-box k)))))) + +(define + pl-solve-or! + (fn + (db a b trail cut-box k) + (cond + ((and (pl-compound? a) (= (pl-fun a) "->") (= (len (pl-args a)) 2)) + (pl-solve-if-then-else! + db + (first (pl-args a)) + (nth (pl-args a) 1) + b + trail + cut-box + k)) + (true + (let + ((mark (pl-trail-mark trail))) + (let + ((r (pl-solve! db a trail cut-box k))) + (cond + (r true) + ((dict-get cut-box :cut) false) + (true + (begin + (pl-trail-undo-to! trail mark) + (pl-solve! db b trail cut-box k)))))))))) + +(define + pl-solve-if-then-else! + (fn + (db cond-goal then-goal else-goal trail cut-box k) + (let + ((mark (pl-trail-mark trail))) + (let + ((local-cb {:cut false})) + (let + ((found {:val false})) + (pl-solve! + db + cond-goal + trail + local-cb + (fn () (begin (dict-set! found :val true) true))) + (cond + ((dict-get found :val) (pl-solve! db then-goal trail cut-box k)) + (true + (begin + (pl-trail-undo-to! trail mark) + (pl-solve! db else-goal trail cut-box k))))))))) + +(define pl-output-buffer "") + +(define pl-output-clear! (fn () (set! pl-output-buffer ""))) + +(define + pl-output-write! + (fn (s) (begin (set! pl-output-buffer (str pl-output-buffer s)) nil))) + +(define + pl-format-args + (fn + (args) + (cond + ((empty? args) "") + ((= (len args) 1) (pl-format-term (first args))) + (true + (str + (pl-format-term (first args)) + ", " + (pl-format-args (rest args))))))) + +(define + pl-format-term + (fn + (t) + (let + ((w (pl-walk-deep t))) + (cond + ((pl-var? w) (str "_" (pl-var-id w))) + ((pl-atom? w) (pl-atom-name w)) + ((pl-num? w) (str (pl-num-val w))) + ((pl-str? w) (pl-str-val w)) + ((pl-compound? w) + (str (pl-fun w) "(" (pl-format-args (pl-args w)) ")")) + (true (str w)))))) + +(define + pl-eval-arith + (fn + (t) + (let + ((w (pl-walk-deep t))) + (cond + ((pl-num? w) (pl-num-val w)) + ((pl-compound? w) + (let + ((f (pl-fun w)) (args (pl-args w))) + (cond + ((and (= f "+") (= (len args) 2)) + (+ + (pl-eval-arith (first args)) + (pl-eval-arith (nth args 1)))) + ((and (= f "-") (= (len args) 2)) + (- + (pl-eval-arith (first args)) + (pl-eval-arith (nth args 1)))) + ((and (= f "-") (= (len args) 1)) + (- 0 (pl-eval-arith (first args)))) + ((and (= f "*") (= (len args) 2)) + (* + (pl-eval-arith (first args)) + (pl-eval-arith (nth args 1)))) + ((and (= f "/") (= (len args) 2)) + (/ + (pl-eval-arith (first args)) + (pl-eval-arith (nth args 1)))) + ((and (= f "mod") (= (len args) 2)) + (mod + (pl-eval-arith (first args)) + (pl-eval-arith (nth args 1)))) + ((and (= f "abs") (= (len args) 1)) + (let + ((v (pl-eval-arith (first args)))) + (cond ((< v 0) (- 0 v)) (true v)))) + ((and (= f "max") (= (len args) 2)) + (let + ((va (pl-eval-arith (first args))) + (vb (pl-eval-arith (nth args 1)))) + (cond ((> va vb) va) (true vb)))) + ((and (= f "min") (= (len args) 2)) + (let + ((va (pl-eval-arith (first args))) + (vb (pl-eval-arith (nth args 1)))) + (cond ((< va vb) va) (true vb)))) + ((and (= f "floor") (= (len args) 1)) + (floor (pl-eval-arith (first args)))) + ((and (= f "ceiling") (= (len args) 1)) + (ceil (pl-eval-arith (first args)))) + ((and (= f "truncate") (= (len args) 1)) + (truncate (pl-eval-arith (first args)))) + ((and (= f "round") (= (len args) 1)) + (round (pl-eval-arith (first args)))) + ((and (= f "sqrt") (= (len args) 1)) + (sqrt (pl-eval-arith (first args)))) + ((and (= f "sign") (= (len args) 1)) + (let + ((v (pl-eval-arith (first args)))) + (cond ((< v 0) -1) ((> v 0) 1) (true 0)))) + ((and (= f "integer") (= (len args) 1)) + (truncate (pl-eval-arith (first args)))) + ((and (= f "float") (= (len args) 1)) + (pl-eval-arith (first args))) + ((and (= f "float_integer_part") (= (len args) 1)) + (truncate (pl-eval-arith (first args)))) + ((and (= f "float_fractional_part") (= (len args) 1)) + (let + ((v (pl-eval-arith (first args)))) + (- v (truncate v)))) + ((and (= f "**") (= (len args) 2)) + (pow + (pl-eval-arith (first args)) + (pl-eval-arith (nth args 1)))) + ((and (= f "^") (= (len args) 2)) + (pow + (pl-eval-arith (first args)) + (pl-eval-arith (nth args 1)))) + ((and (= f "pow") (= (len args) 2)) + (pow + (pl-eval-arith (first args)) + (pl-eval-arith (nth args 1)))) + (true 0)))) + (true 0))))) + +(define + pl-solve-not-eq! + (fn + (a b trail k) + (let + ((mark (pl-trail-mark trail))) + (let + ((unified (pl-unify! a b trail))) + (begin + (pl-trail-undo-to! trail mark) + (cond (unified false) (true (k)))))))) + +(define + pl-solve-eq! + (fn + (a b trail k) + (let + ((mark (pl-trail-mark trail))) + (cond + ((pl-unify! a b trail) + (let + ((r (k))) + (cond + (r true) + (true (begin (pl-trail-undo-to! trail mark) false))))) + (true (begin (pl-trail-undo-to! trail mark) false)))))) + +(define + pl-solve-user! + (fn + (db goal trail outer-cut-box k) + (let + ((inner-cut-box {:cut false})) + (let + ((outer-was-cut (dict-get outer-cut-box :cut))) + (let + ((compiled (when (dict-has? db :compiled) (dict-get db :compiled)))) + (if + (and compiled (dict-has? compiled (pl-goal-key goal))) + (pl-try-compiled-clauses! + db + goal + trail + (dict-get compiled (pl-goal-key goal)) + outer-cut-box + outer-was-cut + inner-cut-box + k) + (pl-try-clauses! + db + goal + trail + (pl-db-lookup-goal db goal) + outer-cut-box + outer-was-cut + inner-cut-box + k))))))) + +(define + pl-try-clauses! + (fn + (db goal trail clauses outer-cut-box outer-was-cut inner-cut-box k) + (cond + ((empty? clauses) false) + (true + (let + ((mark (pl-trail-mark trail))) + (let + ((clause (pl-instantiate-fresh (first clauses)))) + (let + ((head (nth clause 1)) (body (nth clause 2))) + (cond + ((pl-unify! goal head trail) + (let + ((r (pl-solve! db body trail inner-cut-box k))) + (cond + (r true) + ((dict-get inner-cut-box :cut) + (begin (pl-trail-undo-to! trail mark) false)) + ((and (not outer-was-cut) (dict-get outer-cut-box :cut)) + (begin (pl-trail-undo-to! trail mark) false)) + (true + (begin + (pl-trail-undo-to! trail mark) + (pl-try-clauses! + db + goal + trail + (rest clauses) + outer-cut-box + outer-was-cut + inner-cut-box + k)))))) + (true + (begin + (pl-trail-undo-to! trail mark) + (pl-try-clauses! + db + goal + trail + (rest clauses) + outer-cut-box + outer-was-cut + inner-cut-box + k))))))))))) + +(define + pl-solve-once! + (fn (db goal trail) (pl-solve! db goal trail {:cut false} (fn () true)))) + +(define + pl-solve-count! + (fn + (db goal trail) + (let + ((box {:n 0})) + (pl-solve! + db + goal + trail + {:cut false} + (fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false))) + (dict-get box :n)))) diff --git a/lib/prolog/scoreboard.json b/lib/prolog/scoreboard.json new file mode 100644 index 00000000..dfd36f21 --- /dev/null +++ b/lib/prolog/scoreboard.json @@ -0,0 +1,7 @@ +{ + "total_passed": 590, + "total_failed": 0, + "total": 590, + "suites": {"parse":{"passed":25,"total":25,"failed":0},"unify":{"passed":47,"total":47,"failed":0},"clausedb":{"passed":14,"total":14,"failed":0},"solve":{"passed":62,"total":62,"failed":0},"operators":{"passed":19,"total":19,"failed":0},"dynamic":{"passed":11,"total":11,"failed":0},"findall":{"passed":11,"total":11,"failed":0},"term_inspect":{"passed":14,"total":14,"failed":0},"append":{"passed":6,"total":6,"failed":0},"reverse":{"passed":6,"total":6,"failed":0},"member":{"passed":7,"total":7,"failed":0},"nqueens":{"passed":6,"total":6,"failed":0},"family":{"passed":10,"total":10,"failed":0},"atoms":{"passed":34,"total":34,"failed":0},"query_api":{"passed":16,"total":16,"failed":0},"iso_predicates":{"passed":29,"total":29,"failed":0},"meta_predicates":{"passed":25,"total":25,"failed":0},"list_predicates":{"passed":33,"total":33,"failed":0},"meta_call":{"passed":15,"total":15,"failed":0},"set_predicates":{"passed":15,"total":15,"failed":0},"char_predicates":{"passed":27,"total":27,"failed":0},"io_predicates":{"passed":24,"total":24,"failed":0},"assert_rules":{"passed":15,"total":15,"failed":0},"string_agg":{"passed":25,"total":25,"failed":0},"advanced":{"passed":21,"total":21,"failed":0},"compiler":{"passed":17,"total":17,"failed":0},"cross_validate":{"passed":17,"total":17,"failed":0},"integration":{"passed":20,"total":20,"failed":0},"hs_bridge":{"passed":19,"total":19,"failed":0}}, + "generated": "2026-05-06T08:29:09+00:00" +} diff --git a/lib/prolog/scoreboard.md b/lib/prolog/scoreboard.md new file mode 100644 index 00000000..edd774a3 --- /dev/null +++ b/lib/prolog/scoreboard.md @@ -0,0 +1,39 @@ +# Prolog scoreboard + +**590 / 590 passing** (0 failure(s)). +Generated 2026-05-06T08:29:09+00:00. + +| Suite | Passed | Total | Status | +|-------|--------|-------|--------| +| parse | 25 | 25 | ok | +| unify | 47 | 47 | ok | +| clausedb | 14 | 14 | ok | +| solve | 62 | 62 | ok | +| operators | 19 | 19 | ok | +| dynamic | 11 | 11 | ok | +| findall | 11 | 11 | ok | +| term_inspect | 14 | 14 | ok | +| append | 6 | 6 | ok | +| reverse | 6 | 6 | ok | +| member | 7 | 7 | ok | +| nqueens | 6 | 6 | ok | +| family | 10 | 10 | ok | +| atoms | 34 | 34 | ok | +| query_api | 16 | 16 | ok | +| iso_predicates | 29 | 29 | ok | +| meta_predicates | 25 | 25 | ok | +| list_predicates | 33 | 33 | ok | +| meta_call | 15 | 15 | ok | +| set_predicates | 15 | 15 | ok | +| char_predicates | 27 | 27 | ok | +| io_predicates | 24 | 24 | ok | +| assert_rules | 15 | 15 | ok | +| string_agg | 25 | 25 | ok | +| advanced | 21 | 21 | ok | +| compiler | 17 | 17 | ok | +| cross_validate | 17 | 17 | ok | +| integration | 20 | 20 | ok | +| hs_bridge | 19 | 19 | ok | + +Run `bash lib/prolog/conformance.sh` to refresh. Override the binary +with `SX_SERVER=path/to/sx_server.exe bash …`. diff --git a/lib/prolog/tests/advanced.sx b/lib/prolog/tests/advanced.sx new file mode 100644 index 00000000..3b5afb4d --- /dev/null +++ b/lib/prolog/tests/advanced.sx @@ -0,0 +1,254 @@ +;; lib/prolog/tests/advanced.sx — predsort/3, term_variables/2, arith extensions + +(define pl-adv-test-count 0) +(define pl-adv-test-pass 0) +(define pl-adv-test-fail 0) +(define pl-adv-test-failures (list)) + +(define + pl-adv-test! + (fn + (name got expected) + (begin + (set! pl-adv-test-count (+ pl-adv-test-count 1)) + (if + (= got expected) + (set! pl-adv-test-pass (+ pl-adv-test-pass 1)) + (begin + (set! pl-adv-test-fail (+ pl-adv-test-fail 1)) + (append! + pl-adv-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-adv-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-adv-db (pl-mk-db)) +;; Load a numeric comparator for predsort tests +(pl-db-load! + pl-adv-db + (pl-parse + "cmp_num(Order, X, Y) :- (X < Y -> Order = '<' ; (X > Y -> Order = '>' ; Order = '=')).")) + +;; ── Arithmetic extensions ────────────────────────────────────────── + +(define pl-adv-arith-env-1 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is floor(3.7)" pl-adv-arith-env-1) + (pl-mk-trail)) +(pl-adv-test! + "floor(3.7) = 3" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-1 "X"))) + 3) + +(define pl-adv-arith-env-2 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is ceiling(3.2)" pl-adv-arith-env-2) + (pl-mk-trail)) +(pl-adv-test! + "ceiling(3.2) = 4" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-2 "X"))) + 4) + +(define pl-adv-arith-env-3 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is truncate(3.9)" pl-adv-arith-env-3) + (pl-mk-trail)) +(pl-adv-test! + "truncate(3.9) = 3" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-3 "X"))) + 3) + +(define pl-adv-arith-env-4 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is truncate(0 - 3.9)" pl-adv-arith-env-4) + (pl-mk-trail)) +(pl-adv-test! + "truncate(0-3.9) = -3" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-4 "X"))) + -3) + +(define pl-adv-arith-env-5 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is round(3.5)" pl-adv-arith-env-5) + (pl-mk-trail)) +(pl-adv-test! + "round(3.5) = 4" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-5 "X"))) + 4) + +(define pl-adv-arith-env-6 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is sqrt(4.0)" pl-adv-arith-env-6) + (pl-mk-trail)) +(pl-adv-test! + "sqrt(4.0) = 2" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-6 "X"))) + 2) + +(define pl-adv-arith-env-7 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is sign(0 - 5)" pl-adv-arith-env-7) + (pl-mk-trail)) +(pl-adv-test! + "sign(0-5) = -1" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-7 "X"))) + -1) + +(define pl-adv-arith-env-8 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is sign(0)" pl-adv-arith-env-8) + (pl-mk-trail)) +(pl-adv-test! + "sign(0) = 0" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-8 "X"))) + 0) + +(define pl-adv-arith-env-9 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is sign(3)" pl-adv-arith-env-9) + (pl-mk-trail)) +(pl-adv-test! + "sign(3) = 1" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-9 "X"))) + 1) + +(define pl-adv-arith-env-10 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is pow(2, 3)" pl-adv-arith-env-10) + (pl-mk-trail)) +(pl-adv-test! + "pow(2,3) = 8" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-10 "X"))) + 8) + +(define pl-adv-arith-env-11 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is floor(0 - 3.7)" pl-adv-arith-env-11) + (pl-mk-trail)) +(pl-adv-test! + "floor(0-3.7) = -4" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-11 "X"))) + -4) + +(define pl-adv-arith-env-12 {:X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "X is ceiling(0 - 3.2)" pl-adv-arith-env-12) + (pl-mk-trail)) +(pl-adv-test! + "ceiling(0-3.2) = -3" + (pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-12 "X"))) + -3) + +;; ── term_variables/2 ────────────────────────────────────────────── + +(define pl-adv-tv-env-1 {:Vs (pl-mk-rt-var "Vs")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "term_variables(hello, Vs)" pl-adv-tv-env-1) + (pl-mk-trail)) +(pl-adv-test! + "term_variables(hello,Vs) -> []" + (pl-format-term (pl-walk-deep (dict-get pl-adv-tv-env-1 "Vs"))) + "[]") + +(define pl-adv-tv-env-2 {:Vs (pl-mk-rt-var "Vs")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "term_variables(f(a, g(b)), Vs)" pl-adv-tv-env-2) + (pl-mk-trail)) +(pl-adv-test! + "term_variables(f(a,g(b)),Vs) -> []" + (pl-format-term (pl-walk-deep (dict-get pl-adv-tv-env-2 "Vs"))) + "[]") + +(define pl-adv-tv-env-3 {:Y (pl-mk-rt-var "Y") :Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "term_variables(f(X, Y), Vs)" pl-adv-tv-env-3) + (pl-mk-trail)) +(pl-adv-test! + "term_variables(f(X,Y),Vs) has 2 vars" + (pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-3 "Vs"))) + 2) + +(define pl-adv-tv-env-4 {:Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "term_variables(X, Vs)" pl-adv-tv-env-4) + (pl-mk-trail)) +(pl-adv-test! + "term_variables(X,Vs) has 1 var" + (pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-4 "Vs"))) + 1) + +(define pl-adv-tv-env-5 {:Y (pl-mk-rt-var "Y") :Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "term_variables(foo(X, Y, X), Vs)" pl-adv-tv-env-5) + (pl-mk-trail)) +(pl-adv-test! + "term_variables(foo(X,Y,X),Vs) deduplicates X -> 2 vars" + (pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-5 "Vs"))) + 2) + +;; ── predsort/3 ──────────────────────────────────────────────────── + +(define pl-adv-ps-env-1 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "predsort(cmp_num, [], R)" pl-adv-ps-env-1) + (pl-mk-trail)) +(pl-adv-test! + "predsort([]) -> []" + (pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-1 "R"))) + "[]") + +(define pl-adv-ps-env-2 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "predsort(cmp_num, [1], R)" pl-adv-ps-env-2) + (pl-mk-trail)) +(pl-adv-test! + "predsort([1]) -> [1]" + (pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-2 "R"))) + ".(1, [])") + +(define pl-adv-ps-env-3 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "predsort(cmp_num, [3,1,2], R)" pl-adv-ps-env-3) + (pl-mk-trail)) +(pl-adv-test! + "predsort([3,1,2]) -> [1,2,3]" + (pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-3 "R"))) + ".(1, .(2, .(3, [])))") + +(define pl-adv-ps-env-4 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-adv-db + (pl-adv-goal "predsort(cmp_num, [3,1,2,1,3], R)" pl-adv-ps-env-4) + (pl-mk-trail)) +(pl-adv-test! + "predsort([3,1,2,1,3]) dedup -> [1,2,3]" + (pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-4 "R"))) + ".(1, .(2, .(3, [])))") + +;; ── Runner ───────────────────────────────────────────────────────── + +(define pl-advanced-tests-run! (fn () {:failed pl-adv-test-fail :passed pl-adv-test-pass :total pl-adv-test-count :failures pl-adv-test-failures})) diff --git a/lib/prolog/tests/assert_rules.sx b/lib/prolog/tests/assert_rules.sx new file mode 100644 index 00000000..f7284268 --- /dev/null +++ b/lib/prolog/tests/assert_rules.sx @@ -0,0 +1,215 @@ +;; lib/prolog/tests/assert_rules.sx — assert/assertz/asserta with rule terms (head :- body) +;; Tests that :- is in the op table (prec 1200 xfx) and pl-build-clause handles rule form. + +(define pl-ar-test-count 0) +(define pl-ar-test-pass 0) +(define pl-ar-test-fail 0) +(define pl-ar-test-failures (list)) + +(define + pl-ar-test! + (fn + (name got expected) + (begin + (set! pl-ar-test-count (+ pl-ar-test-count 1)) + (if + (= got expected) + (set! pl-ar-test-pass (+ pl-ar-test-pass 1)) + (begin + (set! pl-ar-test-fail (+ pl-ar-test-fail 1)) + (append! + pl-ar-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-ar-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +;; ── DB1: assertz a simple rule then query ────────────────────────── +(define pl-ar-db1 (pl-mk-db)) + +(pl-solve-once! + pl-ar-db1 + (pl-ar-goal "assertz((double(X, Y) :- Y is X * 2))" {}) + (pl-mk-trail)) + +(pl-ar-test! + "assertz rule: double(3, Y) succeeds" + (pl-solve-once! + pl-ar-db1 + (pl-ar-goal "double(3, Y)" {}) + (pl-mk-trail)) + true) + +(define pl-ar-env1 {}) +(pl-solve-once! + pl-ar-db1 + (pl-ar-goal "double(3, Y)" pl-ar-env1) + (pl-mk-trail)) + +(pl-ar-test! + "assertz rule: double(3, Y) binds Y to 6" + (pl-num-val (pl-walk-deep (dict-get pl-ar-env1 "Y"))) + 6) + +(define pl-ar-env1b {}) +(pl-solve-once! + pl-ar-db1 + (pl-ar-goal "double(10, Y)" pl-ar-env1b) + (pl-mk-trail)) + +(pl-ar-test! + "assertz rule: double(10, Y) yields 20" + (pl-num-val (pl-walk-deep (dict-get pl-ar-env1b "Y"))) + 20) + +;; ── DB2: assert a rule with multiple facts, count solutions ───────── +(define pl-ar-db2 (pl-mk-db)) + +(pl-solve-once! + pl-ar-db2 + (pl-ar-goal "assert(fact(a))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-ar-db2 + (pl-ar-goal "assert(fact(b))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-ar-db2 + (pl-ar-goal "assertz((copy(X) :- fact(X)))" {}) + (pl-mk-trail)) + +(pl-ar-test! + "rule copy/1 using fact/1: 2 solutions" + (pl-solve-count! pl-ar-db2 (pl-ar-goal "copy(X)" {}) (pl-mk-trail)) + 2) + +(define pl-ar-env2a {}) +(pl-solve-once! pl-ar-db2 (pl-ar-goal "copy(X)" pl-ar-env2a) (pl-mk-trail)) + +(pl-ar-test! + "rule copy/1: first solution is a" + (pl-atom-name (pl-walk-deep (dict-get pl-ar-env2a "X"))) + "a") + +;; ── DB3: asserta rule is tried before existing clauses ───────────── +(define pl-ar-db3 (pl-mk-db)) + +(pl-solve-once! + pl-ar-db3 + (pl-ar-goal "assert(ord(a))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-ar-db3 + (pl-ar-goal "asserta((ord(b) :- true))" {}) + (pl-mk-trail)) + +(define pl-ar-env3 {}) +(pl-solve-once! pl-ar-db3 (pl-ar-goal "ord(X)" pl-ar-env3) (pl-mk-trail)) + +(pl-ar-test! + "asserta rule ord(b) is tried before ord(a)" + (pl-atom-name (pl-walk-deep (dict-get pl-ar-env3 "X"))) + "b") + +(pl-ar-test! + "asserta: total solutions for ord/1 is 2" + (pl-solve-count! pl-ar-db3 (pl-ar-goal "ord(X)" {}) (pl-mk-trail)) + 2) + +;; ── DB4: rule with conjunction in body ───────────────────────────── +(define pl-ar-db4 (pl-mk-db)) + +(pl-solve-once! + pl-ar-db4 + (pl-ar-goal "assert(num(1))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-ar-db4 + (pl-ar-goal "assert(num(2))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-ar-db4 + (pl-ar-goal "assertz((big(X) :- num(X), X > 1))" {}) + (pl-mk-trail)) + +(pl-ar-test! + "conjunction in rule body: big(1) fails" + (pl-solve-once! pl-ar-db4 (pl-ar-goal "big(1)" {}) (pl-mk-trail)) + false) + +(pl-ar-test! + "conjunction in rule body: big(2) succeeds" + (pl-solve-once! pl-ar-db4 (pl-ar-goal "big(2)" {}) (pl-mk-trail)) + true) + +;; ── DB5: recursive rule ───────────────────────────────────────────── +(define pl-ar-db5 (pl-mk-db)) + +(pl-solve-once! + pl-ar-db5 + (pl-ar-goal "assert((nat(0) :- true))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-ar-db5 + (pl-ar-goal "assertz((nat(s(X)) :- nat(X)))" {}) + (pl-mk-trail)) + +(pl-ar-test! + "recursive rule: nat(0) succeeds" + (pl-solve-once! pl-ar-db5 (pl-ar-goal "nat(0)" {}) (pl-mk-trail)) + true) + +(pl-ar-test! + "recursive rule: nat(s(0)) succeeds" + (pl-solve-once! + pl-ar-db5 + (pl-ar-goal "nat(s(0))" {}) + (pl-mk-trail)) + true) + +(pl-ar-test! + "recursive rule: nat(s(s(0))) succeeds" + (pl-solve-once! + pl-ar-db5 + (pl-ar-goal "nat(s(s(0)))" {}) + (pl-mk-trail)) + true) + +(pl-ar-test! + "recursive rule: nat(bad) fails" + (pl-solve-once! pl-ar-db5 (pl-ar-goal "nat(bad)" {}) (pl-mk-trail)) + false) + +;; ── DB6: rule with true body (explicit) ──────────────────────────── +(define pl-ar-db6 (pl-mk-db)) + +(pl-solve-once! + pl-ar-db6 + (pl-ar-goal "assertz((always(X) :- true))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-ar-db6 + (pl-ar-goal "assert(always(extra))" {}) + (pl-mk-trail)) + +(pl-ar-test! + "rule body=true: always(foo) succeeds" + (pl-solve-once! + pl-ar-db6 + (pl-ar-goal "always(foo)" {}) + (pl-mk-trail)) + true) + +(pl-ar-test! + "rule body=true: always/1 has 2 clauses (1 rule + 1 fact)" + (pl-solve-count! + pl-ar-db6 + (pl-ar-goal "always(X)" {}) + (pl-mk-trail)) + 2) + +;; ── Runner ────────────────────────────────────────────────────────── +(define pl-assert-rules-tests-run! (fn () {:failed pl-ar-test-fail :passed pl-ar-test-pass :total pl-ar-test-count :failures pl-ar-test-failures})) diff --git a/lib/prolog/tests/atoms.sx b/lib/prolog/tests/atoms.sx new file mode 100644 index 00000000..e1b09bae --- /dev/null +++ b/lib/prolog/tests/atoms.sx @@ -0,0 +1,305 @@ +;; lib/prolog/tests/atoms.sx — type predicates + string/atom built-ins + +(define pl-at-test-count 0) +(define pl-at-test-pass 0) +(define pl-at-test-fail 0) +(define pl-at-test-failures (list)) + +(define + pl-at-test! + (fn + (name got expected) + (begin + (set! pl-at-test-count (+ pl-at-test-count 1)) + (if + (= got expected) + (set! pl-at-test-pass (+ pl-at-test-pass 1)) + (begin + (set! pl-at-test-fail (+ pl-at-test-fail 1)) + (append! + pl-at-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-at-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-at-db (pl-mk-db)) + +;; ── var/1 + nonvar/1 ── + +(pl-at-test! + "var(X) for unbound var" + (pl-solve-once! pl-at-db (pl-at-goal "var(X)" {}) (pl-mk-trail)) + true) +(pl-at-test! + "var(foo) fails" + (pl-solve-once! pl-at-db (pl-at-goal "var(foo)" {}) (pl-mk-trail)) + false) +(pl-at-test! + "nonvar(foo) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "nonvar(foo)" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "nonvar(X) for unbound var fails" + (pl-solve-once! pl-at-db (pl-at-goal "nonvar(X)" {}) (pl-mk-trail)) + false) + +;; ── atom/1 ── + +(pl-at-test! + "atom(foo) succeeds" + (pl-solve-once! pl-at-db (pl-at-goal "atom(foo)" {}) (pl-mk-trail)) + true) +(pl-at-test! + "atom([]) succeeds" + (pl-solve-once! pl-at-db (pl-at-goal "atom([])" {}) (pl-mk-trail)) + true) +(pl-at-test! + "atom(42) fails" + (pl-solve-once! pl-at-db (pl-at-goal "atom(42)" {}) (pl-mk-trail)) + false) +(pl-at-test! + "atom(f(x)) fails" + (pl-solve-once! + pl-at-db + (pl-at-goal "atom(f(x))" {}) + (pl-mk-trail)) + false) + +;; ── number/1 + integer/1 ── + +(pl-at-test! + "number(42) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "number(42)" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "number(foo) fails" + (pl-solve-once! + pl-at-db + (pl-at-goal "number(foo)" {}) + (pl-mk-trail)) + false) +(pl-at-test! + "integer(7) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "integer(7)" {}) + (pl-mk-trail)) + true) + +;; ── compound/1 + callable/1 + atomic/1 ── + +(pl-at-test! + "compound(f(x)) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "compound(f(x))" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "compound(foo) fails" + (pl-solve-once! + pl-at-db + (pl-at-goal "compound(foo)" {}) + (pl-mk-trail)) + false) +(pl-at-test! + "callable(foo) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "callable(foo)" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "callable(f(x)) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "callable(f(x))" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "callable(42) fails" + (pl-solve-once! + pl-at-db + (pl-at-goal "callable(42)" {}) + (pl-mk-trail)) + false) +(pl-at-test! + "atomic(foo) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "atomic(foo)" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "atomic(42) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "atomic(42)" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "atomic(f(x)) fails" + (pl-solve-once! + pl-at-db + (pl-at-goal "atomic(f(x))" {}) + (pl-mk-trail)) + false) + +;; ── is_list/1 ── + +(pl-at-test! + "is_list([]) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "is_list([])" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "is_list([1,2,3]) succeeds" + (pl-solve-once! + pl-at-db + (pl-at-goal "is_list([1,2,3])" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "is_list(foo) fails" + (pl-solve-once! + pl-at-db + (pl-at-goal "is_list(foo)" {}) + (pl-mk-trail)) + false) + +;; ── atom_length/2 ── + +(define pl-at-env-al {}) +(pl-solve-once! + pl-at-db + (pl-at-goal "atom_length(hello, N)" pl-at-env-al) + (pl-mk-trail)) +(pl-at-test! + "atom_length(hello, N) -> N=5" + (pl-num-val (pl-walk-deep (dict-get pl-at-env-al "N"))) + 5) +(pl-at-test! + "atom_length empty atom" + (pl-solve-once! + pl-at-db + (pl-at-goal "atom_length('', 0)" {}) + (pl-mk-trail)) + true) + +;; ── atom_concat/3 ── + +(define pl-at-env-ac {}) +(pl-solve-once! + pl-at-db + (pl-at-goal "atom_concat(foo, bar, X)" pl-at-env-ac) + (pl-mk-trail)) +(pl-at-test! + "atom_concat(foo, bar, X) -> X=foobar" + (pl-atom-name (pl-walk-deep (dict-get pl-at-env-ac "X"))) + "foobar") + +(pl-at-test! + "atom_concat(foo, bar, foobar) check" + (pl-solve-once! + pl-at-db + (pl-at-goal "atom_concat(foo, bar, foobar)" {}) + (pl-mk-trail)) + true) +(pl-at-test! + "atom_concat(foo, bar, foobaz) fails" + (pl-solve-once! + pl-at-db + (pl-at-goal "atom_concat(foo, bar, foobaz)" {}) + (pl-mk-trail)) + false) + +(define pl-at-env-ac2 {}) +(pl-solve-once! + pl-at-db + (pl-at-goal "atom_concat(foo, Y, foobar)" pl-at-env-ac2) + (pl-mk-trail)) +(pl-at-test! + "atom_concat(foo, Y, foobar) -> Y=bar" + (pl-atom-name (pl-walk-deep (dict-get pl-at-env-ac2 "Y"))) + "bar") + +;; ── atom_chars/2 ── + +(define pl-at-env-ach {}) +(pl-solve-once! + pl-at-db + (pl-at-goal "atom_chars(cat, Cs)" pl-at-env-ach) + (pl-mk-trail)) +(pl-at-test! + "atom_chars(cat, Cs) -> Cs=[c,a,t]" + (pl-solve-once! + pl-at-db + (pl-at-goal "atom_chars(cat, [c,a,t])" {}) + (pl-mk-trail)) + true) + +(define pl-at-env-ach2 {}) +(pl-solve-once! + pl-at-db + (pl-at-goal "atom_chars(A, [h,i])" pl-at-env-ach2) + (pl-mk-trail)) +(pl-at-test! + "atom_chars(A, [h,i]) -> A=hi" + (pl-atom-name (pl-walk-deep (dict-get pl-at-env-ach2 "A"))) + "hi") + +;; ── char_code/2 ── + +(define pl-at-env-cc {}) +(pl-solve-once! + pl-at-db + (pl-at-goal "char_code(a, N)" pl-at-env-cc) + (pl-mk-trail)) +(pl-at-test! + "char_code(a, N) -> N=97" + (pl-num-val (pl-walk-deep (dict-get pl-at-env-cc "N"))) + 97) + +(define pl-at-env-cc2 {}) +(pl-solve-once! + pl-at-db + (pl-at-goal "char_code(C, 65)" pl-at-env-cc2) + (pl-mk-trail)) +(pl-at-test! + "char_code(C, 65) -> C='A'" + (pl-atom-name (pl-walk-deep (dict-get pl-at-env-cc2 "C"))) + "A") + +;; ── number_codes/2 ── + +(pl-at-test! + "number_codes(42, [52,50])" + (pl-solve-once! + pl-at-db + (pl-at-goal "number_codes(42, [52,50])" {}) + (pl-mk-trail)) + true) + +;; ── number_chars/2 ── + +(pl-at-test! + "number_chars(42, ['4','2'])" + (pl-solve-once! + pl-at-db + (pl-at-goal "number_chars(42, ['4','2'])" {}) + (pl-mk-trail)) + true) + +(define pl-atom-tests-run! (fn () {:failed pl-at-test-fail :passed pl-at-test-pass :total pl-at-test-count :failures pl-at-test-failures})) diff --git a/lib/prolog/tests/char_predicates.sx b/lib/prolog/tests/char_predicates.sx new file mode 100644 index 00000000..e60bad58 --- /dev/null +++ b/lib/prolog/tests/char_predicates.sx @@ -0,0 +1,290 @@ +;; lib/prolog/tests/char_predicates.sx — char_type/2, upcase_atom/2, downcase_atom/2, +;; string_upper/2, string_lower/2 + +(define pl-cp-test-count 0) +(define pl-cp-test-pass 0) +(define pl-cp-test-fail 0) +(define pl-cp-test-failures (list)) + +(define + pl-cp-test! + (fn + (name got expected) + (begin + (set! pl-cp-test-count (+ pl-cp-test-count 1)) + (if + (= got expected) + (set! pl-cp-test-pass (+ pl-cp-test-pass 1)) + (begin + (set! pl-cp-test-fail (+ pl-cp-test-fail 1)) + (append! + pl-cp-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-cp-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-cp-db (pl-mk-db)) + +;; ─── char_type/2 — alpha ────────────────────────────────────────── + +(pl-cp-test! + "char_type(a, alpha) succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(a, alpha)" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "char_type('1', alpha) fails" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type('1', alpha)" {}) + (pl-mk-trail)) + false) + +(pl-cp-test! + "char_type('A', alpha) succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type('A', alpha)" {}) + (pl-mk-trail)) + true) + +;; ─── char_type/2 — alnum ───────────────────────────────────────── + +(pl-cp-test! + "char_type('5', alnum) succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type('5', alnum)" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "char_type(a, alnum) succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(a, alnum)" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "char_type(' ', alnum) fails" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(' ', alnum)" {}) + (pl-mk-trail)) + false) + +;; ─── char_type/2 — digit ───────────────────────────────────────── + +(pl-cp-test! + "char_type('5', digit) succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type('5', digit)" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "char_type(a, digit) fails" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(a, digit)" {}) + (pl-mk-trail)) + false) + +;; ─── char_type/2 — digit(Weight) ───────────────────────────────── + +(define pl-cp-env-dw {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type('5', digit(N))" pl-cp-env-dw) + (pl-mk-trail)) +(pl-cp-test! + "char_type('5', digit(N)) -> N=5" + (pl-num-val (pl-walk-deep (dict-get pl-cp-env-dw "N"))) + 5) + +(define pl-cp-env-dw0 {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type('0', digit(N))" pl-cp-env-dw0) + (pl-mk-trail)) +(pl-cp-test! + "char_type('0', digit(N)) -> N=0" + (pl-num-val (pl-walk-deep (dict-get pl-cp-env-dw0 "N"))) + 0) + +;; ─── char_type/2 — space/white ─────────────────────────────────── + +(pl-cp-test! + "char_type(' ', space) succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(' ', space)" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "char_type(a, space) fails" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(a, space)" {}) + (pl-mk-trail)) + false) + +;; ─── char_type/2 — upper(Lower) ────────────────────────────────── + +(define pl-cp-env-ul {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type('A', upper(L))" pl-cp-env-ul) + (pl-mk-trail)) +(pl-cp-test! + "char_type('A', upper(L)) -> L=a" + (pl-atom-name (pl-walk-deep (dict-get pl-cp-env-ul "L"))) + "a") + +(pl-cp-test! + "char_type(a, upper(L)) fails — not uppercase" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(a, upper(_))" {}) + (pl-mk-trail)) + false) + +;; ─── char_type/2 — lower(Upper) ────────────────────────────────── + +(define pl-cp-env-lu {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(a, lower(U))" pl-cp-env-lu) + (pl-mk-trail)) +(pl-cp-test! + "char_type(a, lower(U)) -> U='A'" + (pl-atom-name (pl-walk-deep (dict-get pl-cp-env-lu "U"))) + "A") + +;; ─── char_type/2 — ascii(Code) ─────────────────────────────────── + +(define pl-cp-env-as {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(a, ascii(C))" pl-cp-env-as) + (pl-mk-trail)) +(pl-cp-test! + "char_type(a, ascii(C)) -> C=97" + (pl-num-val (pl-walk-deep (dict-get pl-cp-env-as "C"))) + 97) + +;; ─── char_type/2 — punct ───────────────────────────────────────── + +(pl-cp-test! + "char_type('.', punct) succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type('.', punct)" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "char_type(a, punct) fails" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "char_type(a, punct)" {}) + (pl-mk-trail)) + false) + +;; ─── upcase_atom/2 ─────────────────────────────────────────────── + +(define pl-cp-env-ua {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "upcase_atom(hello, X)" pl-cp-env-ua) + (pl-mk-trail)) +(pl-cp-test! + "upcase_atom(hello, X) -> X='HELLO'" + (pl-atom-name (pl-walk-deep (dict-get pl-cp-env-ua "X"))) + "HELLO") + +(pl-cp-test! + "upcase_atom(hello, 'HELLO') succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "upcase_atom(hello, 'HELLO')" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "upcase_atom('Hello World', 'HELLO WORLD') succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "upcase_atom('Hello World', 'HELLO WORLD')" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "upcase_atom('', '') succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "upcase_atom('', '')" {}) + (pl-mk-trail)) + true) + +;; ─── downcase_atom/2 ───────────────────────────────────────────── + +(define pl-cp-env-da {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "downcase_atom('HELLO', X)" pl-cp-env-da) + (pl-mk-trail)) +(pl-cp-test! + "downcase_atom('HELLO', X) -> X=hello" + (pl-atom-name (pl-walk-deep (dict-get pl-cp-env-da "X"))) + "hello") + +(pl-cp-test! + "downcase_atom('HELLO', hello) succeeds" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "downcase_atom('HELLO', hello)" {}) + (pl-mk-trail)) + true) + +(pl-cp-test! + "downcase_atom(hello, hello) succeeds — already lowercase" + (pl-solve-once! + pl-cp-db + (pl-cp-goal "downcase_atom(hello, hello)" {}) + (pl-mk-trail)) + true) + +;; ─── string_upper/2 + string_lower/2 (aliases) ─────────────────── + +(define pl-cp-env-su {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "string_upper(hello, X)" pl-cp-env-su) + (pl-mk-trail)) +(pl-cp-test! + "string_upper(hello, X) -> X='HELLO'" + (pl-atom-name (pl-walk-deep (dict-get pl-cp-env-su "X"))) + "HELLO") + +(define pl-cp-env-sl {}) +(pl-solve-once! + pl-cp-db + (pl-cp-goal "string_lower('WORLD', X)" pl-cp-env-sl) + (pl-mk-trail)) +(pl-cp-test! + "string_lower('WORLD', X) -> X=world" + (pl-atom-name (pl-walk-deep (dict-get pl-cp-env-sl "X"))) + "world") + +(define pl-char-predicates-tests-run! (fn () {:failed pl-cp-test-fail :passed pl-cp-test-pass :total pl-cp-test-count :failures pl-cp-test-failures})) \ No newline at end of file diff --git a/lib/prolog/tests/clausedb.sx b/lib/prolog/tests/clausedb.sx new file mode 100644 index 00000000..83102713 --- /dev/null +++ b/lib/prolog/tests/clausedb.sx @@ -0,0 +1,99 @@ +;; lib/prolog/tests/clausedb.sx — Clause DB unit tests + +(define pl-db-test-count 0) +(define pl-db-test-pass 0) +(define pl-db-test-fail 0) +(define pl-db-test-failures (list)) + +(define + pl-db-test! + (fn + (name got expected) + (begin + (set! pl-db-test-count (+ pl-db-test-count 1)) + (if + (= got expected) + (set! pl-db-test-pass (+ pl-db-test-pass 1)) + (begin + (set! pl-db-test-fail (+ pl-db-test-fail 1)) + (append! + pl-db-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(pl-db-test! + "head-key atom arity 0" + (pl-head-key (nth (first (pl-parse "foo.")) 1)) + "foo/0") + +(pl-db-test! + "head-key compound arity 2" + (pl-head-key (nth (first (pl-parse "bar(a, b).")) 1)) + "bar/2") + +(pl-db-test! + "clause-key of :- clause" + (pl-clause-key (first (pl-parse "likes(mary, X) :- friendly(X)."))) + "likes/2") + +(pl-db-test! + "empty db lookup returns empty list" + (len (pl-db-lookup (pl-mk-db) "parent/2")) + 0) + +(define pl-db-t1 (pl-mk-db)) +(pl-db-load! pl-db-t1 (pl-parse "foo(a). foo(b). foo(c).")) + +(pl-db-test! + "three facts same functor" + (len (pl-db-lookup pl-db-t1 "foo/1")) + 3) +(pl-db-test! + "mismatching key returns empty" + (len (pl-db-lookup pl-db-t1 "foo/2")) + 0) + +(pl-db-test! + "first clause has arg a" + (pl-atom-name + (first (pl-args (nth (first (pl-db-lookup pl-db-t1 "foo/1")) 1)))) + "a") + +(pl-db-test! + "third clause has arg c" + (pl-atom-name + (first (pl-args (nth (nth (pl-db-lookup pl-db-t1 "foo/1") 2) 1)))) + "c") + +(define pl-db-t2 (pl-mk-db)) +(pl-db-load! pl-db-t2 (pl-parse "foo. bar. foo. parent(a, b). parent(c, d).")) + +(pl-db-test! + "atom heads keyed as foo/0" + (len (pl-db-lookup pl-db-t2 "foo/0")) + 2) +(pl-db-test! + "atom heads keyed as bar/0" + (len (pl-db-lookup pl-db-t2 "bar/0")) + 1) +(pl-db-test! + "compound heads keyed as parent/2" + (len (pl-db-lookup pl-db-t2 "parent/2")) + 2) + +(pl-db-test! + "lookup-goal extracts functor/arity" + (len + (pl-db-lookup-goal pl-db-t2 (nth (first (pl-parse "parent(X, Y).")) 1))) + 2) + +(pl-db-test! + "lookup-goal on atom goal" + (len (pl-db-lookup-goal pl-db-t2 (nth (first (pl-parse "foo.")) 1))) + 2) + +(pl-db-test! + "stored clause is clause form" + (first (first (pl-db-lookup pl-db-t2 "parent/2"))) + "clause") + +(define pl-clausedb-tests-run! (fn () {:failed pl-db-test-fail :passed pl-db-test-pass :total pl-db-test-count :failures pl-db-test-failures})) diff --git a/lib/prolog/tests/compiler.sx b/lib/prolog/tests/compiler.sx new file mode 100644 index 00000000..cf85dd29 --- /dev/null +++ b/lib/prolog/tests/compiler.sx @@ -0,0 +1,185 @@ +;; lib/prolog/tests/compiler.sx — compiled clause dispatch tests + +(define pl-cmp-test-count 0) +(define pl-cmp-test-pass 0) +(define pl-cmp-test-fail 0) +(define pl-cmp-test-failures (list)) + +(define + pl-cmp-test! + (fn + (name got expected) + (set! pl-cmp-test-count (+ pl-cmp-test-count 1)) + (if + (= got expected) + (set! pl-cmp-test-pass (+ pl-cmp-test-pass 1)) + (begin + (set! pl-cmp-test-fail (+ pl-cmp-test-fail 1)) + (append! pl-cmp-test-failures name))))) + +;; Load src, compile, return DB. +(define + pl-cmp-mk + (fn + (src) + (let + ((db (pl-mk-db))) + (pl-db-load! db (pl-parse src)) + (pl-compile-db! db) + db))) + +;; Run goal string against compiled DB; return bool (instantiates vars). +(define + pl-cmp-once + (fn + (db src) + (pl-solve-once! + db + (pl-instantiate (pl-parse-goal src) {}) + (pl-mk-trail)))) + +;; Count solutions for goal string against compiled DB. +(define + pl-cmp-count + (fn + (db src) + (pl-solve-count! + db + (pl-instantiate (pl-parse-goal src) {}) + (pl-mk-trail)))) + +;; ── 1. Simple facts ────────────────────────────────────────────── + +(define pl-cmp-db1 (pl-cmp-mk "color(red). color(green). color(blue).")) + +(pl-cmp-test! "compiled fact hit" (pl-cmp-once pl-cmp-db1 "color(red)") true) +(pl-cmp-test! + "compiled fact miss" + (pl-cmp-once pl-cmp-db1 "color(yellow)") + false) +(pl-cmp-test! "compiled fact count" (pl-cmp-count pl-cmp-db1 "color(X)") 3) + +;; ── 2. Recursive rule: append ──────────────────────────────────── + +(define + pl-cmp-db2 + (pl-cmp-mk "append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")) + +(pl-cmp-test! + "compiled append build" + (pl-cmp-once pl-cmp-db2 "append([1,2],[3],[1,2,3])") + true) +(pl-cmp-test! + "compiled append fail" + (pl-cmp-once pl-cmp-db2 "append([1,2],[3],[1,2])") + false) +(pl-cmp-test! + "compiled append split count" + (pl-cmp-count pl-cmp-db2 "append(X, Y, [a,b])") + 3) + +;; ── 3. Cut ─────────────────────────────────────────────────────── + +(define + pl-cmp-db3 + (pl-cmp-mk "first(X, [X|_]) :- !. first(X, [_|T]) :- first(X, T).")) + +(pl-cmp-test! + "compiled cut: only one solution" + (pl-cmp-count pl-cmp-db3 "first(X, [a,b,c])") + 1) + +(let + ((db pl-cmp-db3) (trail (pl-mk-trail)) (env {})) + (let + ((x (pl-mk-rt-var "X"))) + (dict-set! env "X" x) + (pl-solve-once! + db + (pl-instantiate (pl-parse-goal "first(X, [a,b,c])") env) + trail) + (pl-cmp-test! + "compiled cut: correct binding" + (pl-atom-name (pl-walk x)) + "a"))) + +;; ── 4. member ──────────────────────────────────────────────────── + +(define + pl-cmp-db4 + (pl-cmp-mk "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")) + +(pl-cmp-test! + "compiled member hit" + (pl-cmp-once pl-cmp-db4 "member(b, [a,b,c])") + true) +(pl-cmp-test! + "compiled member miss" + (pl-cmp-once pl-cmp-db4 "member(d, [a,b,c])") + false) +(pl-cmp-test! + "compiled member count" + (pl-cmp-count pl-cmp-db4 "member(X, [a,b,c])") + 3) + +;; ── 5. Arithmetic in body ──────────────────────────────────────── + +(define pl-cmp-db5 (pl-cmp-mk "double(X, Y) :- Y is X * 2.")) + +(let + ((db pl-cmp-db5) (trail (pl-mk-trail)) (env {})) + (let + ((y (pl-mk-rt-var "Y"))) + (dict-set! env "Y" y) + (pl-solve-once! + db + (pl-instantiate (pl-parse-goal "double(5, Y)") env) + trail) + (pl-cmp-test! "compiled arithmetic in body" (pl-num-val (pl-walk y)) 10))) + +;; ── 6. Transitive ancestor ─────────────────────────────────────── + +(define + pl-cmp-db6 + (pl-cmp-mk + (str + "parent(a,b). parent(b,c). parent(c,d)." + "ancestor(X,Y) :- parent(X,Y)." + "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."))) + +(pl-cmp-test! + "compiled ancestor direct" + (pl-cmp-once pl-cmp-db6 "ancestor(a,b)") + true) +(pl-cmp-test! + "compiled ancestor 3-step" + (pl-cmp-once pl-cmp-db6 "ancestor(a,d)") + true) +(pl-cmp-test! + "compiled ancestor fail" + (pl-cmp-once pl-cmp-db6 "ancestor(d,a)") + false) + +;; ── 7. Fallback: uncompiled predicate calls compiled sub-predicate + +(define + pl-cmp-db7 + (let + ((db (pl-mk-db))) + (pl-db-load! db (pl-parse "q(1). q(2).")) + (pl-compile-db! db) + (pl-db-load! db (pl-parse "r(X) :- q(X).")) + db)) + +(pl-cmp-test! + "uncompiled predicate resolves" + (pl-cmp-once pl-cmp-db7 "r(1)") + true) +(pl-cmp-test! + "uncompiled calls compiled sub-pred count" + (pl-cmp-count pl-cmp-db7 "r(X)") + 2) + +;; ── Runner ─────────────────────────────────────────────────────── + +(define pl-compiler-tests-run! (fn () {:failed pl-cmp-test-fail :passed pl-cmp-test-pass :total pl-cmp-test-count :failures pl-cmp-test-failures})) diff --git a/lib/prolog/tests/cross_validate.sx b/lib/prolog/tests/cross_validate.sx new file mode 100644 index 00000000..1a365b11 --- /dev/null +++ b/lib/prolog/tests/cross_validate.sx @@ -0,0 +1,86 @@ +;; lib/prolog/tests/cross_validate.sx +;; Verifies that the compiled solver produces the same solution counts as the +;; interpreter for each classic program + built-in exercise. +;; Interpreter is the reference: if they disagree, the compiler is wrong. + +(define pl-xv-test-count 0) +(define pl-xv-test-pass 0) +(define pl-xv-test-fail 0) +(define pl-xv-test-failures (list)) + +(define + pl-xv-test! + (fn + (name got expected) + (set! pl-xv-test-count (+ pl-xv-test-count 1)) + (if + (= got expected) + (set! pl-xv-test-pass (+ pl-xv-test-pass 1)) + (begin + (set! pl-xv-test-fail (+ pl-xv-test-fail 1)) + (append! pl-xv-test-failures name))))) + +;; Shorthand: assert compiled result matches interpreter. +(define + pl-xv-match! + (fn + (name src goal) + (pl-xv-test! name (pl-compiled-matches-interp? src goal) true))) + +;; ── 1. append/3 ───────────────────────────────────────────────── + +(define + pl-xv-append + "append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).") + +(pl-xv-match! "append build 2+2" pl-xv-append "append([1,2],[3,4],X)") +(pl-xv-match! "append split [a,b,c]" pl-xv-append "append(X, Y, [a,b,c])") +(pl-xv-match! "append member-mode" pl-xv-append "append(_, [3], [1,2,3])") + +;; ── 2. member/2 ───────────────────────────────────────────────── + +(define pl-xv-member "member(X, [X|_]). member(X, [_|T]) :- member(X, T).") + +(pl-xv-match! "member check hit" pl-xv-member "member(b, [a,b,c])") +(pl-xv-match! "member count" pl-xv-member "member(X, [a,b,c])") +(pl-xv-match! "member empty" pl-xv-member "member(X, [])") + +;; ── 3. facts + transitive rules ───────────────────────────────── + +(define + pl-xv-ancestor + (str + "parent(a,b). parent(b,c). parent(c,d). parent(a,c)." + "ancestor(X,Y) :- parent(X,Y)." + "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y).")) + +(pl-xv-match! "ancestor direct" pl-xv-ancestor "ancestor(a,b)") +(pl-xv-match! "ancestor transitive" pl-xv-ancestor "ancestor(a,d)") +(pl-xv-match! "ancestor all from a" pl-xv-ancestor "ancestor(a,Y)") + +;; ── 4. cut semantics ──────────────────────────────────────────── + +(define pl-xv-cut "first(X,[X|_]) :- !. first(X,[_|T]) :- first(X,T).") + +(pl-xv-match! "cut one solution" pl-xv-cut "first(X,[a,b,c])") +(pl-xv-match! "cut empty list" pl-xv-cut "first(X,[])") + +;; ── 5. arithmetic ─────────────────────────────────────────────── + +(define pl-xv-arith "sq(X,Y) :- Y is X * X. even(X) :- 0 is X mod 2.") + +(pl-xv-match! "sq(3,Y) count" pl-xv-arith "sq(3,Y)") +(pl-xv-match! "sq(3,9) check" pl-xv-arith "sq(3,9)") +(pl-xv-match! "even(4) check" pl-xv-arith "even(4)") +(pl-xv-match! "even(3) check" pl-xv-arith "even(3)") + +;; ── 6. if-then-else ───────────────────────────────────────────── + +(define pl-xv-ite "classify(X, pos) :- X > 0, !. classify(_, nonpos).") + +(pl-xv-match! "classify positive" pl-xv-ite "classify(5, C)") +(pl-xv-match! "classify zero" pl-xv-ite "classify(0, C)") + +;; ── Runner ─────────────────────────────────────────────────────── + +(define pl-cross-validate-tests-run! (fn () {:failed pl-xv-test-fail :passed pl-xv-test-pass :total pl-xv-test-count :failures pl-xv-test-failures})) diff --git a/lib/prolog/tests/dynamic.sx b/lib/prolog/tests/dynamic.sx new file mode 100644 index 00000000..fa5bd45b --- /dev/null +++ b/lib/prolog/tests/dynamic.sx @@ -0,0 +1,158 @@ +;; lib/prolog/tests/dynamic.sx — assert/asserta/assertz/retract. + +(define pl-dy-test-count 0) +(define pl-dy-test-pass 0) +(define pl-dy-test-fail 0) +(define pl-dy-test-failures (list)) + +(define + pl-dy-test! + (fn + (name got expected) + (begin + (set! pl-dy-test-count (+ pl-dy-test-count 1)) + (if + (= got expected) + (set! pl-dy-test-pass (+ pl-dy-test-pass 1)) + (begin + (set! pl-dy-test-fail (+ pl-dy-test-fail 1)) + (append! + pl-dy-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-dy-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +;; assertz then query +(define pl-dy-db1 (pl-mk-db)) +(pl-solve-once! + pl-dy-db1 + (pl-dy-goal "assertz(foo(1))" {}) + (pl-mk-trail)) +(pl-dy-test! + "assertz(foo(1)) + foo(1)" + (pl-solve-once! pl-dy-db1 (pl-dy-goal "foo(1)" {}) (pl-mk-trail)) + true) + +(pl-dy-test! + "after one assertz, foo/1 has 1 clause" + (pl-solve-count! pl-dy-db1 (pl-dy-goal "foo(X)" {}) (pl-mk-trail)) + 1) + +;; assertz appends — order preserved +(define pl-dy-db2 (pl-mk-db)) +(pl-solve-once! + pl-dy-db2 + (pl-dy-goal "assertz(p(1))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-dy-db2 + (pl-dy-goal "assertz(p(2))" {}) + (pl-mk-trail)) +(pl-dy-test! + "assertz twice — count 2" + (pl-solve-count! pl-dy-db2 (pl-dy-goal "p(X)" {}) (pl-mk-trail)) + 2) + +(define pl-dy-env-a {}) +(pl-solve-once! pl-dy-db2 (pl-dy-goal "p(X)" pl-dy-env-a) (pl-mk-trail)) +(pl-dy-test! + "assertz: first solution is the first asserted (1)" + (pl-num-val (pl-walk-deep (dict-get pl-dy-env-a "X"))) + 1) + +;; asserta prepends +(define pl-dy-db3 (pl-mk-db)) +(pl-solve-once! + pl-dy-db3 + (pl-dy-goal "assertz(p(1))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-dy-db3 + (pl-dy-goal "asserta(p(99))" {}) + (pl-mk-trail)) +(define pl-dy-env-b {}) +(pl-solve-once! pl-dy-db3 (pl-dy-goal "p(X)" pl-dy-env-b) (pl-mk-trail)) +(pl-dy-test! + "asserta: prepended clause is first solution" + (pl-num-val (pl-walk-deep (dict-get pl-dy-env-b "X"))) + 99) + +;; assert/1 = assertz/1 +(define pl-dy-db4 (pl-mk-db)) +(pl-solve-once! + pl-dy-db4 + (pl-dy-goal "assert(g(7))" {}) + (pl-mk-trail)) +(pl-dy-test! + "assert/1 alias" + (pl-solve-once! pl-dy-db4 (pl-dy-goal "g(7)" {}) (pl-mk-trail)) + true) + +;; retract removes a fact +(define pl-dy-db5 (pl-mk-db)) +(pl-solve-once! + pl-dy-db5 + (pl-dy-goal "assertz(q(1))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-dy-db5 + (pl-dy-goal "assertz(q(2))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-dy-db5 + (pl-dy-goal "assertz(q(3))" {}) + (pl-mk-trail)) +(pl-dy-test! + "before retract: 3 clauses" + (pl-solve-count! pl-dy-db5 (pl-dy-goal "q(X)" {}) (pl-mk-trail)) + 3) +(pl-solve-once! + pl-dy-db5 + (pl-dy-goal "retract(q(2))" {}) + (pl-mk-trail)) +(pl-dy-test! + "after retract(q(2)): 2 clauses left" + (pl-solve-count! pl-dy-db5 (pl-dy-goal "q(X)" {}) (pl-mk-trail)) + 2) + +(define pl-dy-env-c {}) +(pl-solve-once! pl-dy-db5 (pl-dy-goal "q(X)" pl-dy-env-c) (pl-mk-trail)) +(pl-dy-test! + "after retract(q(2)): first remaining is 1" + (pl-num-val (pl-walk-deep (dict-get pl-dy-env-c "X"))) + 1) + +;; retract of non-existent +(pl-dy-test! + "retract(missing(0)) on empty db fails" + (pl-solve-once! + (pl-mk-db) + (pl-dy-goal "retract(missing(0))" {}) + (pl-mk-trail)) + false) + +;; retract with unbound var matches first +(define pl-dy-db6 (pl-mk-db)) +(pl-solve-once! + pl-dy-db6 + (pl-dy-goal "assertz(r(11))" {}) + (pl-mk-trail)) +(pl-solve-once! + pl-dy-db6 + (pl-dy-goal "assertz(r(22))" {}) + (pl-mk-trail)) +(define pl-dy-env-d {}) +(pl-solve-once! + pl-dy-db6 + (pl-dy-goal "retract(r(X))" pl-dy-env-d) + (pl-mk-trail)) +(pl-dy-test! + "retract(r(X)) binds X to first match" + (pl-num-val (pl-walk-deep (dict-get pl-dy-env-d "X"))) + 11) + +(define pl-dynamic-tests-run! (fn () {:failed pl-dy-test-fail :passed pl-dy-test-pass :total pl-dy-test-count :failures pl-dy-test-failures})) diff --git a/lib/prolog/tests/findall.sx b/lib/prolog/tests/findall.sx new file mode 100644 index 00000000..ef98dd89 --- /dev/null +++ b/lib/prolog/tests/findall.sx @@ -0,0 +1,167 @@ +;; lib/prolog/tests/findall.sx — findall/3, bagof/3, setof/3. + +(define pl-fb-test-count 0) +(define pl-fb-test-pass 0) +(define pl-fb-test-fail 0) +(define pl-fb-test-failures (list)) + +(define + pl-fb-test! + (fn + (name got expected) + (begin + (set! pl-fb-test-count (+ pl-fb-test-count 1)) + (if + (= got expected) + (set! pl-fb-test-pass (+ pl-fb-test-pass 1)) + (begin + (set! pl-fb-test-fail (+ pl-fb-test-fail 1)) + (append! + pl-fb-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-fb-term-to-sx + (fn + (t) + (cond + ((pl-num? t) (pl-num-val t)) + ((pl-atom? t) (pl-atom-name t)) + (true (list :complex))))) + +(define + pl-fb-list-walked + (fn + (w) + (cond + ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list)) + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (cons + (pl-fb-term-to-sx (first (pl-args w))) + (pl-fb-list-walked (nth (pl-args w) 1)))) + (true (list :not-list))))) + +(define pl-fb-list-to-sx (fn (t) (pl-fb-list-walked (pl-walk-deep t)))) + +(define + pl-fb-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-fb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).") + +(define pl-fb-db (pl-mk-db)) +(pl-db-load! pl-fb-db (pl-parse pl-fb-prog-src)) + +;; ── findall ── + +(define pl-fb-env-1 {}) +(pl-solve-once! + pl-fb-db + (pl-fb-goal "findall(X, member(X, [a, b, c]), L)" pl-fb-env-1) + (pl-mk-trail)) +(pl-fb-test! + "findall member [a, b, c]" + (pl-fb-list-to-sx (dict-get pl-fb-env-1 "L")) + (list "a" "b" "c")) + +(define pl-fb-env-2 {}) +(pl-solve-once! + pl-fb-db + (pl-fb-goal "findall(X, (member(X, [1, 2, 3]), X >= 2), L)" pl-fb-env-2) + (pl-mk-trail)) +(pl-fb-test! + "findall with comparison filter" + (pl-fb-list-to-sx (dict-get pl-fb-env-2 "L")) + (list 2 3)) + +(define pl-fb-env-3 {}) +(pl-solve-once! + pl-fb-db + (pl-fb-goal "findall(X, fail, L)" pl-fb-env-3) + (pl-mk-trail)) +(pl-fb-test! + "findall on fail succeeds with empty list" + (pl-fb-list-to-sx (dict-get pl-fb-env-3 "L")) + (list)) + +(pl-fb-test! + "findall(X, fail, L) the goal succeeds" + (pl-solve-once! + pl-fb-db + (pl-fb-goal "findall(X, fail, L)" {}) + (pl-mk-trail)) + true) + +(define pl-fb-env-4 {}) +(pl-solve-once! + pl-fb-db + (pl-fb-goal + "findall(p(X, Y), (member(X, [1, 2]), member(Y, [a, b])), L)" + pl-fb-env-4) + (pl-mk-trail)) +(pl-fb-test! + "findall over compound template — count = 4" + (len (pl-fb-list-to-sx (dict-get pl-fb-env-4 "L"))) + 4) + +;; ── bagof ── + +(pl-fb-test! + "bagof succeeds when results exist" + (pl-solve-once! + pl-fb-db + (pl-fb-goal "bagof(X, member(X, [1, 2, 3]), L)" {}) + (pl-mk-trail)) + true) + +(pl-fb-test! + "bagof fails on empty" + (pl-solve-once! + pl-fb-db + (pl-fb-goal "bagof(X, fail, L)" {}) + (pl-mk-trail)) + false) + +(define pl-fb-env-5 {}) +(pl-solve-once! + pl-fb-db + (pl-fb-goal "bagof(X, member(X, [c, a, b]), L)" pl-fb-env-5) + (pl-mk-trail)) +(pl-fb-test! + "bagof preserves order" + (pl-fb-list-to-sx (dict-get pl-fb-env-5 "L")) + (list "c" "a" "b")) + +;; ── setof ── + +(define pl-fb-env-6 {}) +(pl-solve-once! + pl-fb-db + (pl-fb-goal "setof(X, member(X, [c, a, b, a, c]), L)" pl-fb-env-6) + (pl-mk-trail)) +(pl-fb-test! + "setof sorts + dedupes atoms" + (pl-fb-list-to-sx (dict-get pl-fb-env-6 "L")) + (list "a" "b" "c")) + +(pl-fb-test! + "setof fails on empty" + (pl-solve-once! + pl-fb-db + (pl-fb-goal "setof(X, fail, L)" {}) + (pl-mk-trail)) + false) + +(define pl-fb-env-7 {}) +(pl-solve-once! + pl-fb-db + (pl-fb-goal "setof(X, member(X, [3, 1, 2, 1, 3]), L)" pl-fb-env-7) + (pl-mk-trail)) +(pl-fb-test! + "setof sorts + dedupes nums" + (pl-fb-list-to-sx (dict-get pl-fb-env-7 "L")) + (list 1 2 3)) + +(define pl-findall-tests-run! (fn () {:failed pl-fb-test-fail :passed pl-fb-test-pass :total pl-fb-test-count :failures pl-fb-test-failures})) diff --git a/lib/prolog/tests/hs_bridge.sx b/lib/prolog/tests/hs_bridge.sx new file mode 100644 index 00000000..3553c86e --- /dev/null +++ b/lib/prolog/tests/hs_bridge.sx @@ -0,0 +1,165 @@ +;; lib/prolog/tests/hs_bridge.sx — tests for Prolog↔Hyperscript bridge +;; +;; Verifies pl-hs-query, pl-hs-predicate/N, and pl-hs-install. +;; Also demonstrates the end-to-end DSL pattern: +;; (define allowed (pl-hs-predicate/2 db "allowed")) +;; → (allowed "alice" "edit") is what Hyperscript compiles +;; `when allowed(alice, edit)` to. + +(define pl-hsb-test-count 0) +(define pl-hsb-test-pass 0) +(define pl-hsb-test-fail 0) +(define pl-hsb-test-failures (list)) + +(define + pl-hsb-test! + (fn + (name got expected) + (begin + (set! pl-hsb-test-count (+ pl-hsb-test-count 1)) + (if + (= got expected) + (set! pl-hsb-test-pass (+ pl-hsb-test-pass 1)) + (begin + (set! pl-hsb-test-fail (+ pl-hsb-test-fail 1)) + (append! + pl-hsb-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +;; ── shared KB ── + +(define + pl-hsb-perm-src + "role(alice, admin). role(bob, editor). role(charlie, viewer). permission(admin, read). permission(admin, write). permission(admin, delete). permission(editor, read). permission(editor, write). permission(viewer, read). allowed(U, A) :- role(U, R), permission(R, A).") + +(define pl-hsb-db (pl-load pl-hsb-perm-src)) + +;; ── pl-hs-query ── + +(pl-hsb-test! + "pl-hs-query: ground fact succeeds" + (pl-hs-query pl-hsb-db "role(alice, admin)") + true) + +(pl-hsb-test! + "pl-hs-query: absent fact fails" + (pl-hs-query pl-hsb-db "role(alice, viewer)") + false) + +(pl-hsb-test! + "pl-hs-query: rule derivation succeeds" + (pl-hs-query pl-hsb-db "allowed(alice, delete)") + true) + +(pl-hsb-test! + "pl-hs-query: rule derivation fails" + (pl-hs-query pl-hsb-db "allowed(charlie, delete)") + false) + +(pl-hsb-test! + "pl-hs-query: arithmetic goal" + (pl-hs-query pl-hsb-db "X is 3 + 4, X = 7") + true) + +;; ── pl-hs-predicate/2 ── + +(define pl-hsb-allowed (pl-hs-predicate/2 pl-hsb-db "allowed")) + +(pl-hsb-test! + "predicate/2: alice can read" + (pl-hsb-allowed "alice" "read") + true) + +(pl-hsb-test! + "predicate/2: alice can delete" + (pl-hsb-allowed "alice" "delete") + true) + +(pl-hsb-test! + "predicate/2: charlie cannot write" + (pl-hsb-allowed "charlie" "write") + false) + +(pl-hsb-test! + "predicate/2: bob can write" + (pl-hsb-allowed "bob" "write") + true) + +(pl-hsb-test! + "predicate/2: unknown user fails" + (pl-hsb-allowed "eve" "read") + false) + +;; ── DSL simulation ── +;; Hyperscript compiles `when allowed(user, action) then …` +;; to `(allowed user action)` — a direct SX function call. +;; Here we verify that pattern works end-to-end. + +(define pl-hsb-user "alice") +(define pl-hsb-action "write") + +(pl-hsb-test! + "DSL simulation: (allowed user action) true path" + (pl-hsb-allowed pl-hsb-user pl-hsb-action) + true) + +(define pl-hsb-user2 "charlie") + +(pl-hsb-test! + "DSL simulation: (allowed user action) false path" + (pl-hsb-allowed pl-hsb-user2 pl-hsb-action) + false) + +;; ── pl-hs-predicate/1 ── + +(define pl-hsb-viewer-src "color(red). color(green). color(blue).") +(define pl-hsb-color-db (pl-load pl-hsb-viewer-src)) +(define pl-hsb-color? (pl-hs-predicate/1 pl-hsb-color-db "color")) + +(pl-hsb-test! "predicate/1: color(red) succeeds" (pl-hsb-color? "red") true) + +(pl-hsb-test! + "predicate/1: color(purple) fails" + (pl-hsb-color? "purple") + false) + +;; ── pl-hs-predicate/3 ── + +(define pl-hsb-3ary-src "between_vals(X, Lo, Hi) :- X >= Lo, X =< Hi.") +(define pl-hsb-3ary-db (pl-load pl-hsb-3ary-src)) +(define pl-hsb-in-range? (pl-hs-predicate/3 pl-hsb-3ary-db "between_vals")) + +(pl-hsb-test! + "predicate/3: 5 in range [1,10]" + (pl-hsb-in-range? "5" "1" "10") + true) + +(pl-hsb-test! + "predicate/3: 15 not in range [1,10]" + (pl-hsb-in-range? "15" "1" "10") + false) + +;; ── pl-hs-install ── + +(define + pl-hsb-installed + (pl-hs-install + pl-hsb-db + (list (list "allowed" 2) (list "role" 2) (list "permission" 2)))) + +(pl-hsb-test! + "pl-hs-install: returns dict with allowed key" + (not (nil? (dict-get pl-hsb-installed "allowed"))) + true) + +(pl-hsb-test! + "pl-hs-install: installed allowed fn works" + ((dict-get pl-hsb-installed "allowed") "alice" "delete") + true) + +(pl-hsb-test! + "pl-hs-install: installed role fn works" + ((dict-get pl-hsb-installed "role") "bob" "editor") + true) + +(define pl-hs-bridge-tests-run! (fn () {:failed pl-hsb-test-fail :passed pl-hsb-test-pass :total pl-hsb-test-count :failures pl-hsb-test-failures})) diff --git a/lib/prolog/tests/integration.sx b/lib/prolog/tests/integration.sx new file mode 100644 index 00000000..6c2428ff --- /dev/null +++ b/lib/prolog/tests/integration.sx @@ -0,0 +1,172 @@ +;; lib/prolog/tests/integration.sx — end-to-end integration tests via pl-query-* API +;; +;; Tests the full source→parse→load→solve pipeline with real programs. +;; Covers: permission system, graph reachability, quicksort, fibonacci, dynamic KB. + +(define pl-int-test-count 0) +(define pl-int-test-pass 0) +(define pl-int-test-fail 0) +(define pl-int-test-failures (list)) + +(define + pl-int-test! + (fn + (name got expected) + (begin + (set! pl-int-test-count (+ pl-int-test-count 1)) + (if + (= got expected) + (set! pl-int-test-pass (+ pl-int-test-pass 1)) + (begin + (set! pl-int-test-fail (+ pl-int-test-fail 1)) + (append! + pl-int-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +;; ── Permission system ── +;; role/2 + permission/2 facts, allowed/2 rule + +(define + pl-int-perm-src + "role(alice, admin). role(bob, editor). role(charlie, viewer). permission(admin, read). permission(admin, write). permission(admin, delete). permission(editor, read). permission(editor, write). permission(viewer, read). allowed(U, A) :- role(U, R), permission(R, A).") + +(define pl-int-perm-db (pl-load pl-int-perm-src)) + +(pl-int-test! + "alice can read" + (len (pl-query-all pl-int-perm-db "allowed(alice, read)")) + 1) + +(pl-int-test! + "alice can delete" + (len (pl-query-all pl-int-perm-db "allowed(alice, delete)")) + 1) + +(pl-int-test! + "charlie cannot write" + (len (pl-query-all pl-int-perm-db "allowed(charlie, write)")) + 0) + +(pl-int-test! + "alice has 3 permissions" + (len (pl-query-all pl-int-perm-db "allowed(alice, A)")) + 3) + +(pl-int-test! + "only one user can delete" + (len (pl-query-all pl-int-perm-db "allowed(U, delete)")) + 1) + +(pl-int-test! + "the deleter is alice" + (dict-get (first (pl-query-all pl-int-perm-db "allowed(U, delete)")) "U") + "alice") + +;; ── Graph reachability ── +;; Directed edges; path/2 transitive closure via two clauses + +(define + pl-int-graph-src + "edge(a, b). edge(b, c). edge(c, d). edge(b, d). path(X, Y) :- edge(X, Y). path(X, Y) :- edge(X, Z), path(Z, Y).") + +(define pl-int-graph-db (pl-load pl-int-graph-src)) + +(pl-int-test! + "direct edge a→b is a path" + (len (pl-query-all pl-int-graph-db "path(a, b)")) + 1) + +(pl-int-test! + "transitive path a→c" + (len (pl-query-all pl-int-graph-db "path(a, c)")) + 1) + +(pl-int-test! + "no path d→a (no back-edges)" + (len (pl-query-all pl-int-graph-db "path(d, a)")) + 0) + +(pl-int-test! + "4 derivations from a (b,c,d via two routes to d)" + (len (pl-query-all pl-int-graph-db "path(a, Y)")) + 4) + +;; ── Quicksort ── +;; Partition-and-recurse; uses its own append/3 to avoid DB pollution + +(define + pl-int-qs-src + "partition(_, [], [], []). partition(Piv, [H|T], [H|Less], Greater) :- H =< Piv, !, partition(Piv, T, Less, Greater). partition(Piv, [H|T], Less, [H|Greater]) :- partition(Piv, T, Less, Greater). append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R). quicksort([], []). quicksort([H|T], Sorted) :- partition(H, T, Less, Greater), quicksort(Less, SL), quicksort(Greater, SG), append(SL, [H|SG], Sorted).") + +(define pl-int-qs-db (pl-load pl-int-qs-src)) + +(pl-int-test! + "quicksort([]) = [] (ground check)" + (len (pl-query-all pl-int-qs-db "quicksort([], [])")) + 1) + +(pl-int-test! + "quicksort([3,1,2]) = [1,2,3] (ground check)" + (len (pl-query-all pl-int-qs-db "quicksort([3,1,2], [1,2,3])")) + 1) + +(pl-int-test! + "quicksort([5,3,1,4,2]) = [1,2,3,4,5] (ground check)" + (len (pl-query-all pl-int-qs-db "quicksort([5,3,1,4,2], [1,2,3,4,5])")) + 1) + +(pl-int-test! + "quicksort([3,1,2], [3,1,2]) fails — unsorted order rejected" + (len (pl-query-all pl-int-qs-db "quicksort([3,1,2], [3,1,2])")) + 0) + +;; ── Fibonacci ── +;; Naive recursive; ground checks avoid list-format uncertainty + +(define + pl-int-fib-src + "fib(0, 0). fib(1, 1). fib(N, F) :- N > 1, N1 is N - 1, N2 is N - 2, fib(N1, F1), fib(N2, F2), F is F1 + F2.") + +(define pl-int-fib-db (pl-load pl-int-fib-src)) + +(pl-int-test! + "fib(0, 0) succeeds" + (len (pl-query-all pl-int-fib-db "fib(0, 0)")) + 1) + +(pl-int-test! + "fib(5, 5) succeeds" + (len (pl-query-all pl-int-fib-db "fib(5, 5)")) + 1) + +(pl-int-test! + "fib(7, 13) succeeds" + (len (pl-query-all pl-int-fib-db "fib(7, 13)")) + 1) + +;; ── Dynamic knowledge base ── +;; Assert and retract facts; the DB dict is mutable so mutations persist + +(define pl-int-dyn-src "color(red). color(green). color(blue).") +(define pl-int-dyn-db (pl-load pl-int-dyn-src)) + +(pl-int-test! + "initial KB: 3 colors" + (len (pl-query-all pl-int-dyn-db "color(X)")) + 3) + +(pl-int-test! + "after assert(color(yellow)): 4 colors" + (begin + (pl-query-all pl-int-dyn-db "assert(color(yellow))") + (len (pl-query-all pl-int-dyn-db "color(X)"))) + 4) + +(pl-int-test! + "after retract(color(red)): back to 3 colors" + (begin + (pl-query-all pl-int-dyn-db "retract(color(red))") + (len (pl-query-all pl-int-dyn-db "color(X)"))) + 3) + +(define pl-integration-tests-run! (fn () {:failed pl-int-test-fail :passed pl-int-test-pass :total pl-int-test-count :failures pl-int-test-failures})) diff --git a/lib/prolog/tests/io_predicates.sx b/lib/prolog/tests/io_predicates.sx new file mode 100644 index 00000000..dc52c57e --- /dev/null +++ b/lib/prolog/tests/io_predicates.sx @@ -0,0 +1,326 @@ +;; lib/prolog/tests/io_predicates.sx — term_to_atom/2, term_string/2, +;; with_output_to/2, writeln/1, format/1, format/2 + +(define pl-io-test-count 0) +(define pl-io-test-pass 0) +(define pl-io-test-fail 0) +(define pl-io-test-failures (list)) + +(define + pl-io-test! + (fn + (name got expected) + (begin + (set! pl-io-test-count (+ pl-io-test-count 1)) + (if + (= got expected) + (set! pl-io-test-pass (+ pl-io-test-pass 1)) + (begin + (set! pl-io-test-fail (+ pl-io-test-fail 1)) + (append! + pl-io-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-io-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-io-db (pl-mk-db)) + +;; helper: get output buffer after running a goal +(define + pl-io-capture! + (fn + (goal) + (do + (pl-output-clear!) + (pl-solve-once! pl-io-db goal (pl-mk-trail)) + pl-output-buffer))) + +;; ─── term_to_atom/2 — bound Term direction ───────────────────────────────── + +(pl-io-test! + "term_to_atom(foo(a,b), A) — compound" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "term_to_atom(foo(a,b), A)" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "A")))) + "foo(a, b)") + +(pl-io-test! + "term_to_atom(hello, A) — atom" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "term_to_atom(hello, A)" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "A")))) + "hello") + +(pl-io-test! + "term_to_atom(42, A) — number" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "term_to_atom(42, A)" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "A")))) + "42") + +(pl-io-test! + "term_to_atom(foo(a,b), 'foo(a, b)') — succeeds when Atom matches" + (pl-solve-once! + pl-io-db + (pl-io-goal "term_to_atom(foo(a,b), 'foo(a, b)')" {}) + (pl-mk-trail)) + true) + +(pl-io-test! + "term_to_atom(hello, world) — fails on mismatch" + (pl-solve-once! + pl-io-db + (pl-io-goal "term_to_atom(hello, world)" {}) + (pl-mk-trail)) + false) + +;; ─── term_to_atom/2 — parse direction (Atom bound, Term unbound) ─────────── + +(pl-io-test! + "term_to_atom(T, 'foo(a)') — parse direction gives compound" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "term_to_atom(T, 'foo(a)')" env) + (pl-mk-trail)) + (let + ((t (pl-walk-deep (dict-get env "T")))) + (and (pl-compound? t) (= (pl-fun t) "foo")))) + true) + +(pl-io-test! + "term_to_atom(T, hello) — parse direction gives atom" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "term_to_atom(T, hello)" env) + (pl-mk-trail)) + (let + ((t (pl-walk-deep (dict-get env "T")))) + (and (pl-atom? t) (= (pl-atom-name t) "hello")))) + true) + +;; ─── term_string/2 — alias ────────────────────────────────────────────────── + +(pl-io-test! + "term_string(bar(x), A) — same as term_to_atom" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "term_string(bar(x), A)" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "A")))) + "bar(x)") + +(pl-io-test! + "term_string(42, A) — number to string" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "term_string(42, A)" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "A")))) + "42") + +;; ─── writeln/1 ───────────────────────────────────────────────────────────── + +(pl-io-test! + "writeln(hello) writes 'hello\n'" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), writeln(hello))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "hello +") + +(pl-io-test! + "writeln(42) writes '42\n'" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), writeln(42))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "42 +") + +;; ─── with_output_to/2 ────────────────────────────────────────────────────── + +(pl-io-test! + "with_output_to(atom(X), write(foo)) — captures write output" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), write(foo))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "foo") + +(pl-io-test! + "with_output_to(atom(X), (write(a), write(b))) — concat output" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), (write(a), write(b)))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "ab") + +(pl-io-test! + "with_output_to(atom(X), nl) — captures newline" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), nl)" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + " +") + +(pl-io-test! + "with_output_to(atom(X), true) — captures empty string" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), true)" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "") + +(pl-io-test! + "with_output_to(string(X), write(hello)) — string sink works" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(string(X), write(hello))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "hello") + +(pl-io-test! + "with_output_to(atom(X), fail) — fails when goal fails" + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), fail)" {}) + (pl-mk-trail)) + false) + +;; ─── format/1 ────────────────────────────────────────────────────────────── + +(pl-io-test! + "format('hello~n') — tilde-n becomes newline" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), format('hello~n'))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "hello +") + +(pl-io-test! + "format('~~') — double tilde becomes single tilde" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), format('~~'))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "~") + +(pl-io-test! + "format('abc') — plain text passes through" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), format(abc))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "abc") + +;; ─── format/2 ────────────────────────────────────────────────────────────── + +(pl-io-test! + "format('~w+~w', [1,2]) — two ~w args" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), format('~w+~w', [1,2]))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "1+2") + +(pl-io-test! + "format('hello ~a!', [world]) — ~a with atom arg" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), format('hello ~a!', [world]))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "hello world!") + +(pl-io-test! + "format('n=~d', [42]) — ~d with integer arg" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), format('n=~d', [42]))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "n=42") + +(pl-io-test! + "format('~w', [foo(a)]) — ~w with compound" + (let + ((env {})) + (pl-solve-once! + pl-io-db + (pl-io-goal "with_output_to(atom(X), format('~w', [foo(a)]))" env) + (pl-mk-trail)) + (pl-atom-name (pl-walk-deep (dict-get env "X")))) + "foo(a)") + +(define + pl-io-predicates-tests-run! + (fn + () + {:failed pl-io-test-fail + :passed pl-io-test-pass + :total pl-io-test-count + :failures pl-io-test-failures})) diff --git a/lib/prolog/tests/iso_predicates.sx b/lib/prolog/tests/iso_predicates.sx new file mode 100644 index 00000000..bf283a92 --- /dev/null +++ b/lib/prolog/tests/iso_predicates.sx @@ -0,0 +1,320 @@ +;; lib/prolog/tests/iso_predicates.sx — succ/2, plus/3, between/3, length/2, last/2, nth0/3, nth1/3, max/min arith + +(define pl-ip-test-count 0) +(define pl-ip-test-pass 0) +(define pl-ip-test-fail 0) +(define pl-ip-test-failures (list)) + +(define + pl-ip-test! + (fn + (name got expected) + (begin + (set! pl-ip-test-count (+ pl-ip-test-count 1)) + (if + (= got expected) + (set! pl-ip-test-pass (+ pl-ip-test-pass 1)) + (begin + (set! pl-ip-test-fail (+ pl-ip-test-fail 1)) + (append! + pl-ip-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-ip-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-ip-db (pl-mk-db)) + +;; ── succ/2 ── + +(define pl-ip-env-s1 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "succ(3, X)" pl-ip-env-s1) + (pl-mk-trail)) +(pl-ip-test! + "succ(3, X) → X=4" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-s1 "X"))) + 4) + +(define pl-ip-env-s2 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "succ(0, X)" pl-ip-env-s2) + (pl-mk-trail)) +(pl-ip-test! + "succ(0, X) → X=1" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-s2 "X"))) + 1) + +(define pl-ip-env-s3 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "succ(X, 5)" pl-ip-env-s3) + (pl-mk-trail)) +(pl-ip-test! + "succ(X, 5) → X=4" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-s3 "X"))) + 4) + +(pl-ip-test! + "succ(X, 0) fails" + (pl-solve-once! + pl-ip-db + (pl-ip-goal "succ(X, 0)" {}) + (pl-mk-trail)) + false) + +;; ── plus/3 ── + +(define pl-ip-env-p1 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "plus(2, 3, X)" pl-ip-env-p1) + (pl-mk-trail)) +(pl-ip-test! + "plus(2, 3, X) → X=5" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-p1 "X"))) + 5) + +(define pl-ip-env-p2 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "plus(2, X, 7)" pl-ip-env-p2) + (pl-mk-trail)) +(pl-ip-test! + "plus(2, X, 7) → X=5" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-p2 "X"))) + 5) + +(define pl-ip-env-p3 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "plus(X, 3, 7)" pl-ip-env-p3) + (pl-mk-trail)) +(pl-ip-test! + "plus(X, 3, 7) → X=4" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-p3 "X"))) + 4) + +(pl-ip-test! + "plus(0, 0, 0) succeeds" + (pl-solve-once! + pl-ip-db + (pl-ip-goal "plus(0, 0, 0)" {}) + (pl-mk-trail)) + true) + +;; ── between/3 ── + +(pl-ip-test! + "between(1, 3, X): 3 solutions" + (pl-solve-count! + pl-ip-db + (pl-ip-goal "between(1, 3, X)" {}) + (pl-mk-trail)) + 3) + +(pl-ip-test! + "between(1, 3, 2) succeeds" + (pl-solve-once! + pl-ip-db + (pl-ip-goal "between(1, 3, 2)" {}) + (pl-mk-trail)) + true) + +(pl-ip-test! + "between(1, 3, 5) fails" + (pl-solve-once! + pl-ip-db + (pl-ip-goal "between(1, 3, 5)" {}) + (pl-mk-trail)) + false) + +(pl-ip-test! + "between(5, 3, X): 0 solutions (empty range)" + (pl-solve-count! + pl-ip-db + (pl-ip-goal "between(5, 3, X)" {}) + (pl-mk-trail)) + 0) + +(define pl-ip-env-b1 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "between(1, 5, X)" pl-ip-env-b1) + (pl-mk-trail)) +(pl-ip-test! + "between(1, 5, X): first solution X=1" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-b1 "X"))) + 1) + +(pl-ip-test! + "between + condition: between(1,5,X), X > 3 → 2 solutions" + (pl-solve-count! + pl-ip-db + (pl-ip-goal "between(1, 5, X), X > 3" {}) + (pl-mk-trail)) + 2) + +;; ── length/2 ── + +(define pl-ip-env-l1 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "length([1,2,3], N)" pl-ip-env-l1) + (pl-mk-trail)) +(pl-ip-test! + "length([1,2,3], N) → N=3" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-l1 "N"))) + 3) + +(define pl-ip-env-l2 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "length([], N)" pl-ip-env-l2) + (pl-mk-trail)) +(pl-ip-test! + "length([], N) → N=0" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-l2 "N"))) + 0) + +(pl-ip-test! + "length([a,b], 2) check succeeds" + (pl-solve-once! + pl-ip-db + (pl-ip-goal "length([a,b], 2)" {}) + (pl-mk-trail)) + true) + +(define pl-ip-env-l3 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "length(L, 3)" pl-ip-env-l3) + (pl-mk-trail)) +(pl-ip-test! + "length(L, 3): L is a list of length 3" + (pl-solve-once! + pl-ip-db + (pl-ip-goal "length(L, 3), is_list(L)" pl-ip-env-l3) + (pl-mk-trail)) + true) + +;; ── last/2 ── + +(define pl-ip-env-la1 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "last([1,2,3], X)" pl-ip-env-la1) + (pl-mk-trail)) +(pl-ip-test! + "last([1,2,3], X) → X=3" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-la1 "X"))) + 3) + +(define pl-ip-env-la2 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "last([a], X)" pl-ip-env-la2) + (pl-mk-trail)) +(pl-ip-test! + "last([a], X) → X=a" + (pl-atom-name (pl-walk-deep (dict-get pl-ip-env-la2 "X"))) + "a") + +(pl-ip-test! + "last([], X) fails" + (pl-solve-once! + pl-ip-db + (pl-ip-goal "last([], X)" {}) + (pl-mk-trail)) + false) + +;; ── nth0/3 ── + +(define pl-ip-env-n0 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "nth0(0, [a,b,c], X)" pl-ip-env-n0) + (pl-mk-trail)) +(pl-ip-test! + "nth0(0, [a,b,c], X) → X=a" + (pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n0 "X"))) + "a") + +(define pl-ip-env-n1 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "nth0(2, [a,b,c], X)" pl-ip-env-n1) + (pl-mk-trail)) +(pl-ip-test! + "nth0(2, [a,b,c], X) → X=c" + (pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1 "X"))) + "c") + +(pl-ip-test! + "nth0(5, [a,b,c], X) fails" + (pl-solve-once! + pl-ip-db + (pl-ip-goal "nth0(5, [a,b,c], X)" {}) + (pl-mk-trail)) + false) + +;; ── nth1/3 ── + +(define pl-ip-env-n1a {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "nth1(1, [a,b,c], X)" pl-ip-env-n1a) + (pl-mk-trail)) +(pl-ip-test! + "nth1(1, [a,b,c], X) → X=a" + (pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1a "X"))) + "a") + +(define pl-ip-env-n1b {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "nth1(3, [a,b,c], X)" pl-ip-env-n1b) + (pl-mk-trail)) +(pl-ip-test! + "nth1(3, [a,b,c], X) → X=c" + (pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1b "X"))) + "c") + +;; ── max/min in arithmetic ── + +(define pl-ip-env-m1 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "X is max(3, 5)" pl-ip-env-m1) + (pl-mk-trail)) +(pl-ip-test! + "X is max(3, 5) → X=5" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-m1 "X"))) + 5) + +(define pl-ip-env-m2 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "X is min(3, 5)" pl-ip-env-m2) + (pl-mk-trail)) +(pl-ip-test! + "X is min(3, 5) → X=3" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-m2 "X"))) + 3) + +(define pl-ip-env-m3 {}) +(pl-solve-once! + pl-ip-db + (pl-ip-goal "X is max(7, 2) + min(1, 4)" pl-ip-env-m3) + (pl-mk-trail)) +(pl-ip-test! + "X is max(7,2) + min(1,4) → X=8" + (pl-num-val (pl-walk-deep (dict-get pl-ip-env-m3 "X"))) + 8) + +(define pl-iso-predicates-tests-run! (fn () {:failed pl-ip-test-fail :passed pl-ip-test-pass :total pl-ip-test-count :failures pl-ip-test-failures})) \ No newline at end of file diff --git a/lib/prolog/tests/list_predicates.sx b/lib/prolog/tests/list_predicates.sx new file mode 100644 index 00000000..5209958d --- /dev/null +++ b/lib/prolog/tests/list_predicates.sx @@ -0,0 +1,335 @@ +;; lib/prolog/tests/list_predicates.sx — ==/2, \==/2, flatten/2, numlist/3, +;; atomic_list_concat/2,3, sum_list/2, max_list/2, min_list/2, delete/3 + +(define pl-lp-test-count 0) +(define pl-lp-test-pass 0) +(define pl-lp-test-fail 0) +(define pl-lp-test-failures (list)) + +(define + pl-lp-test! + (fn + (name got expected) + (begin + (set! pl-lp-test-count (+ pl-lp-test-count 1)) + (if + (= got expected) + (set! pl-lp-test-pass (+ pl-lp-test-pass 1)) + (begin + (set! pl-lp-test-fail (+ pl-lp-test-fail 1)) + (append! + pl-lp-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-lp-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-lp-db (pl-mk-db)) + +;; ── ==/2 ─────────────────────────────────────────────────────────── + +(pl-lp-test! + "==(a, a) succeeds" + (pl-solve-once! pl-lp-db (pl-lp-goal "==(a, a)" {}) (pl-mk-trail)) + true) + +(pl-lp-test! + "==(a, b) fails" + (pl-solve-once! pl-lp-db (pl-lp-goal "==(a, b)" {}) (pl-mk-trail)) + false) + +(pl-lp-test! + "==(1, 1) succeeds" + (pl-solve-once! pl-lp-db (pl-lp-goal "==(1, 1)" {}) (pl-mk-trail)) + true) + +(pl-lp-test! + "==(1, 2) fails" + (pl-solve-once! pl-lp-db (pl-lp-goal "==(1, 2)" {}) (pl-mk-trail)) + false) + +(pl-lp-test! + "==(f(a,b), f(a,b)) succeeds" + (pl-solve-once! + pl-lp-db + (pl-lp-goal "==(f(a,b), f(a,b))" {}) + (pl-mk-trail)) + true) + +(pl-lp-test! + "==(f(a,b), f(a,c)) fails" + (pl-solve-once! + pl-lp-db + (pl-lp-goal "==(f(a,b), f(a,c))" {}) + (pl-mk-trail)) + false) + +;; unbound var vs atom: fails (different tags) +(pl-lp-test! + "==(X, a) fails (unbound var vs atom)" + (pl-solve-once! pl-lp-db (pl-lp-goal "==(X, a)" {}) (pl-mk-trail)) + false) + +;; two unbound vars with SAME name in same env share the same runtime var +(define pl-lp-env-same-var {}) +(pl-lp-goal "==(X, X)" pl-lp-env-same-var) +(pl-lp-test! + "==(X, X) succeeds (same runtime var)" + (pl-solve-once! + pl-lp-db + (pl-instantiate + (nth (first (pl-parse "g :- ==(X, X).")) 2) + pl-lp-env-same-var) + (pl-mk-trail)) + true) + +;; ── \==/2 ────────────────────────────────────────────────────────── + +(pl-lp-test! + "\\==(a, b) succeeds" + (pl-solve-once! pl-lp-db (pl-lp-goal "\\==(a, b)" {}) (pl-mk-trail)) + true) + +(pl-lp-test! + "\\==(a, a) fails" + (pl-solve-once! pl-lp-db (pl-lp-goal "\\==(a, a)" {}) (pl-mk-trail)) + false) + +(pl-lp-test! + "\\==(X, a) succeeds (unbound var differs from atom)" + (pl-solve-once! pl-lp-db (pl-lp-goal "\\==(X, a)" {}) (pl-mk-trail)) + true) + +(pl-lp-test! + "\\==(1, 2) succeeds" + (pl-solve-once! pl-lp-db (pl-lp-goal "\\==(1, 2)" {}) (pl-mk-trail)) + true) + +;; ── flatten/2 ────────────────────────────────────────────────────── + +(define pl-lp-env-fl1 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "flatten([], F)" pl-lp-env-fl1) + (pl-mk-trail)) +(pl-lp-test! + "flatten([], []) -> empty" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl1 "F"))) + "[]") + +(define pl-lp-env-fl2 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "flatten([1,2,3], F)" pl-lp-env-fl2) + (pl-mk-trail)) +(pl-lp-test! + "flatten([1,2,3], F) -> [1,2,3]" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl2 "F"))) + ".(1, .(2, .(3, [])))") + +(define pl-lp-env-fl3 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "flatten([1,[2,[3]],4], F)" pl-lp-env-fl3) + (pl-mk-trail)) +(pl-lp-test! + "flatten([1,[2,[3]],4], F) -> [1,2,3,4]" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl3 "F"))) + ".(1, .(2, .(3, .(4, []))))") + +(define pl-lp-env-fl4 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "flatten([[a,b],[c]], F)" pl-lp-env-fl4) + (pl-mk-trail)) +(pl-lp-test! + "flatten([[a,b],[c]], F) -> [a,b,c]" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl4 "F"))) + ".(a, .(b, .(c, [])))") + +;; ── numlist/3 ────────────────────────────────────────────────────── + +(define pl-lp-env-nl1 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "numlist(1, 5, L)" pl-lp-env-nl1) + (pl-mk-trail)) +(pl-lp-test! + "numlist(1,5,L) -> [1,2,3,4,5]" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-nl1 "L"))) + ".(1, .(2, .(3, .(4, .(5, [])))))") + +(define pl-lp-env-nl2 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "numlist(3, 3, L)" pl-lp-env-nl2) + (pl-mk-trail)) +(pl-lp-test! + "numlist(3,3,L) -> [3]" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-nl2 "L"))) + ".(3, [])") + +(pl-lp-test! + "numlist(5, 3, L) fails (Low > High)" + (pl-solve-once! + pl-lp-db + (pl-lp-goal "numlist(5, 3, L)" {}) + (pl-mk-trail)) + false) + +;; ── atomic_list_concat/2 ─────────────────────────────────────────── + +(define pl-lp-env-alc1 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "atomic_list_concat([a, b, c], R)" pl-lp-env-alc1) + (pl-mk-trail)) +(pl-lp-test! + "atomic_list_concat([a,b,c], R) -> abc" + (pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alc1 "R"))) + "abc") + +(define pl-lp-env-alc2 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "atomic_list_concat([hello, world], R)" pl-lp-env-alc2) + (pl-mk-trail)) +(pl-lp-test! + "atomic_list_concat([hello,world], R) -> helloworld" + (pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alc2 "R"))) + "helloworld") + +;; ── atomic_list_concat/3 ─────────────────────────────────────────── + +(define pl-lp-env-alcs1 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "atomic_list_concat([a, b, c], '-', R)" pl-lp-env-alcs1) + (pl-mk-trail)) +(pl-lp-test! + "atomic_list_concat([a,b,c], '-', R) -> a-b-c" + (pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alcs1 "R"))) + "a-b-c") + +(define pl-lp-env-alcs2 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "atomic_list_concat([x], '-', R)" pl-lp-env-alcs2) + (pl-mk-trail)) +(pl-lp-test! + "atomic_list_concat([x], '-', R) -> x (single element, no sep)" + (pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alcs2 "R"))) + "x") + +;; ── sum_list/2 ───────────────────────────────────────────────────── + +(define pl-lp-env-sl1 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "sum_list([1,2,3], S)" pl-lp-env-sl1) + (pl-mk-trail)) +(pl-lp-test! + "sum_list([1,2,3], S) -> 6" + (pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl1 "S"))) + 6) + +(define pl-lp-env-sl2 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "sum_list([10], S)" pl-lp-env-sl2) + (pl-mk-trail)) +(pl-lp-test! + "sum_list([10], S) -> 10" + (pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl2 "S"))) + 10) + +(define pl-lp-env-sl3 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "sum_list([], S)" pl-lp-env-sl3) + (pl-mk-trail)) +(pl-lp-test! + "sum_list([], S) -> 0" + (pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl3 "S"))) + 0) + +;; ── max_list/2 ───────────────────────────────────────────────────── + +(define pl-lp-env-mx1 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "max_list([3,1,4,1,5,9,2,6], M)" pl-lp-env-mx1) + (pl-mk-trail)) +(pl-lp-test! + "max_list([3,1,4,1,5,9,2,6], M) -> 9" + (pl-num-val (pl-walk-deep (dict-get pl-lp-env-mx1 "M"))) + 9) + +(define pl-lp-env-mx2 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "max_list([7], M)" pl-lp-env-mx2) + (pl-mk-trail)) +(pl-lp-test! + "max_list([7], M) -> 7" + (pl-num-val (pl-walk-deep (dict-get pl-lp-env-mx2 "M"))) + 7) + +;; ── min_list/2 ───────────────────────────────────────────────────── + +(define pl-lp-env-mn1 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "min_list([3,1,4,1,5,9,2,6], M)" pl-lp-env-mn1) + (pl-mk-trail)) +(pl-lp-test! + "min_list([3,1,4,1,5,9,2,6], M) -> 1" + (pl-num-val (pl-walk-deep (dict-get pl-lp-env-mn1 "M"))) + 1) + +(define pl-lp-env-mn2 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "min_list([5,2,8], M)" pl-lp-env-mn2) + (pl-mk-trail)) +(pl-lp-test! + "min_list([5,2,8], M) -> 2" + (pl-num-val (pl-walk-deep (dict-get pl-lp-env-mn2 "M"))) + 2) + +;; ── delete/3 ─────────────────────────────────────────────────────── + +(define pl-lp-env-del1 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "delete([1,2,3,2,1], 2, R)" pl-lp-env-del1) + (pl-mk-trail)) +(pl-lp-test! + "delete([1,2,3,2,1], 2, R) -> [1,3,1]" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-del1 "R"))) + ".(1, .(3, .(1, [])))") + +(define pl-lp-env-del2 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "delete([a,b,c], d, R)" pl-lp-env-del2) + (pl-mk-trail)) +(pl-lp-test! + "delete([a,b,c], d, R) -> [a,b,c] (nothing deleted)" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-del2 "R"))) + ".(a, .(b, .(c, [])))") + +(define pl-lp-env-del3 {}) +(pl-solve-once! + pl-lp-db + (pl-lp-goal "delete([], x, R)" pl-lp-env-del3) + (pl-mk-trail)) +(pl-lp-test! + "delete([], x, R) -> []" + (pl-format-term (pl-walk-deep (dict-get pl-lp-env-del3 "R"))) + "[]") + +(define pl-list-predicates-tests-run! (fn () {:failed pl-lp-test-fail :passed pl-lp-test-pass :total pl-lp-test-count :failures pl-lp-test-failures})) diff --git a/lib/prolog/tests/meta_call.sx b/lib/prolog/tests/meta_call.sx new file mode 100644 index 00000000..5fcf7519 --- /dev/null +++ b/lib/prolog/tests/meta_call.sx @@ -0,0 +1,197 @@ +;; lib/prolog/tests/meta_call.sx — forall/2, maplist/2, maplist/3, include/3, exclude/3 +(define pl-mc-test-count 0) +(define pl-mc-test-pass 0) +(define pl-mc-test-fail 0) +(define pl-mc-test-failures (list)) + +(define + pl-mc-test! + (fn + (name got expected) + (begin + (set! pl-mc-test-count (+ pl-mc-test-count 1)) + (if + (= got expected) + (set! pl-mc-test-pass (+ pl-mc-test-pass 1)) + (begin + (set! pl-mc-test-fail (+ pl-mc-test-fail 1)) + (append! + pl-mc-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-mc-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define + pl-mc-term-to-sx + (fn + (t) + (cond + ((pl-num? t) (pl-num-val t)) + ((pl-atom? t) (pl-atom-name t)) + (else t)))) + +(define + pl-mc-list-sx + (fn + (t) + (let + ((w (pl-walk-deep t))) + (cond + ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list)) + ((and (pl-compound? w) (= (pl-fun w) ".")) + (cons + (pl-mc-term-to-sx (first (pl-args w))) + (pl-mc-list-sx (nth (pl-args w) 1)))) + (else (list :not-list)))))) + +(define pl-mc-db (pl-mk-db)) + +(pl-db-load! + pl-mc-db + (pl-parse "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")) + +(pl-db-load! pl-mc-db (pl-parse "double(X, Y) :- Y is X * 2.")) + +(pl-db-load! pl-mc-db (pl-parse "even(X) :- 0 is X mod 2.")) + +;; -- forall/2 -- + +(pl-mc-test! + "forall(member(X,[2,4,6]), 0 is X mod 2) — all even" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "forall(member(X,[2,4,6]), 0 is X mod 2)" {}) + (pl-mk-trail)) + true) + +(pl-mc-test! + "forall(member(X,[2,3,6]), 0 is X mod 2) — 3 is odd, fails" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "forall(member(X,[2,3,6]), 0 is X mod 2)" {}) + (pl-mk-trail)) + false) + +(pl-mc-test! + "forall(member(_,[]), true) — vacuously true" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "forall(member(_,[]), true)" {}) + (pl-mk-trail)) + true) + +;; -- maplist/2 -- + +(pl-mc-test! + "maplist(atom, [a,b,c]) — all atoms" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "maplist(atom, [a,b,c])" {}) + (pl-mk-trail)) + true) + +(pl-mc-test! + "maplist(atom, [a,1,c]) — 1 is not atom, fails" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "maplist(atom, [a,1,c])" {}) + (pl-mk-trail)) + false) + +(pl-mc-test! + "maplist(atom, []) — vacuously true" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "maplist(atom, [])" {}) + (pl-mk-trail)) + true) + +;; -- maplist/3 -- + +(pl-mc-test! + "maplist(double, [1,2,3], [2,4,6]) — deterministic check" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "maplist(double, [1,2,3], [2,4,6])" {}) + (pl-mk-trail)) + true) + +(pl-mc-test! + "maplist(double, [1,2,3], [2,4,7]) — wrong result fails" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "maplist(double, [1,2,3], [2,4,7])" {}) + (pl-mk-trail)) + false) + +(define pl-mc-env-ml3 {:L (pl-mk-rt-var "L")}) +(pl-solve-once! + pl-mc-db + (pl-mc-goal "maplist(double, [1,2,3], L)" pl-mc-env-ml3) + (pl-mk-trail)) +(pl-mc-test! + "maplist(double, [1,2,3], L) — L bound to [2,4,6]" + (pl-mc-list-sx (dict-get pl-mc-env-ml3 "L")) + (list 2 4 6)) + +;; -- include/3 -- + +(pl-mc-test! + "include(even, [1,2,3,4,5,6], [2,4,6])" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "include(even, [1,2,3,4,5,6], [2,4,6])" {}) + (pl-mk-trail)) + true) + +(pl-mc-test! + "include(even, [], [])" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "include(even, [], [])" {}) + (pl-mk-trail)) + true) + +(define pl-mc-env-inc {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-mc-db + (pl-mc-goal "include(even, [1,2,3,4,5,6], R)" pl-mc-env-inc) + (pl-mk-trail)) +(pl-mc-test! + "include(even, [1,2,3,4,5,6], R) — R bound to [2,4,6]" + (pl-mc-list-sx (dict-get pl-mc-env-inc "R")) + (list 2 4 6)) + +;; -- exclude/3 -- + +(pl-mc-test! + "exclude(even, [1,2,3,4,5,6], [1,3,5])" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "exclude(even, [1,2,3,4,5,6], [1,3,5])" {}) + (pl-mk-trail)) + true) + +(pl-mc-test! + "exclude(even, [], [])" + (pl-solve-once! + pl-mc-db + (pl-mc-goal "exclude(even, [], [])" {}) + (pl-mk-trail)) + true) + +(define pl-mc-env-exc {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-mc-db + (pl-mc-goal "exclude(even, [1,2,3,4,5,6], R)" pl-mc-env-exc) + (pl-mk-trail)) +(pl-mc-test! + "exclude(even, [1,2,3,4,5,6], R) — R bound to [1,3,5]" + (pl-mc-list-sx (dict-get pl-mc-env-exc "R")) + (list 1 3 5)) + +(define pl-meta-call-tests-run! (fn () {:failed pl-mc-test-fail :passed pl-mc-test-pass :total pl-mc-test-count :failures pl-mc-test-failures})) \ No newline at end of file diff --git a/lib/prolog/tests/meta_predicates.sx b/lib/prolog/tests/meta_predicates.sx new file mode 100644 index 00000000..97fc886b --- /dev/null +++ b/lib/prolog/tests/meta_predicates.sx @@ -0,0 +1,252 @@ +;; lib/prolog/tests/meta_predicates.sx — \+/1, not/1, once/1, ignore/1, ground/1, sort/2, msort/2, atom_number/2, number_string/2 + +(define pl-mp-test-count 0) +(define pl-mp-test-pass 0) +(define pl-mp-test-fail 0) +(define pl-mp-test-failures (list)) + +(define + pl-mp-test! + (fn + (name got expected) + (begin + (set! pl-mp-test-count (+ pl-mp-test-count 1)) + (if + (= got expected) + (set! pl-mp-test-pass (+ pl-mp-test-pass 1)) + (begin + (set! pl-mp-test-fail (+ pl-mp-test-fail 1)) + (append! + pl-mp-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-mp-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-mp-db (pl-mk-db)) +(pl-db-load! + pl-mp-db + (pl-parse "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")) + +;; -- \+/1 -- + +(pl-mp-test! + "\\+(fail) succeeds" + (pl-solve-once! pl-mp-db (pl-mp-goal "\\+(fail)" {}) (pl-mk-trail)) + true) + +(pl-mp-test! + "\\+(true) fails" + (pl-solve-once! pl-mp-db (pl-mp-goal "\\+(true)" {}) (pl-mk-trail)) + false) + +(pl-mp-test! + "\\+(member(d, [a,b,c])) succeeds" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "\\+(member(d, [a,b,c]))" {}) + (pl-mk-trail)) + true) + +(pl-mp-test! + "\\+(member(a, [a,b,c])) fails" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "\\+(member(a, [a,b,c]))" {}) + (pl-mk-trail)) + false) + +(define pl-mp-env-neg {}) +(pl-solve-once! + pl-mp-db + (pl-mp-goal "\\+(X = 5)" pl-mp-env-neg) + (pl-mk-trail)) +(pl-mp-test! + "\\+(X=5) fails, X stays unbound (bindings undone)" + (nil? (pl-var-binding (dict-get pl-mp-env-neg "X"))) + true) + +;; -- not/1 -- + +(pl-mp-test! + "not(fail) succeeds" + (pl-solve-once! pl-mp-db (pl-mp-goal "not(fail)" {}) (pl-mk-trail)) + true) + +(pl-mp-test! + "not(true) fails" + (pl-solve-once! pl-mp-db (pl-mp-goal "not(true)" {}) (pl-mk-trail)) + false) + +;; -- once/1 -- + +(pl-mp-test! + "once(member(X,[1,2,3])) succeeds once" + (pl-solve-count! + pl-mp-db + (pl-mp-goal "once(member(X,[1,2,3]))" {}) + (pl-mk-trail)) + 1) + +(define pl-mp-env-once {}) +(pl-solve-once! + pl-mp-db + (pl-mp-goal "once(member(X,[1,2,3]))" pl-mp-env-once) + (pl-mk-trail)) +(pl-mp-test! + "once(member(X,[1,2,3])): X=1 (first solution)" + (pl-num-val (pl-walk-deep (dict-get pl-mp-env-once "X"))) + 1) + +(pl-mp-test! + "once(fail) fails" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "once(fail)" {}) + (pl-mk-trail)) + false) + +;; -- ignore/1 -- + +(pl-mp-test! + "ignore(true) succeeds" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "ignore(true)" {}) + (pl-mk-trail)) + true) + +(pl-mp-test! + "ignore(fail) still succeeds" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "ignore(fail)" {}) + (pl-mk-trail)) + true) + +;; -- ground/1 -- + +(pl-mp-test! + "ground(foo(1, a)) succeeds" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "ground(foo(1, a))" {}) + (pl-mk-trail)) + true) + +(pl-mp-test! + "ground(foo(X, a)) fails (X unbound)" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "ground(foo(X, a))" {}) + (pl-mk-trail)) + false) + +(pl-mp-test! + "ground(42) succeeds" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "ground(42)" {}) + (pl-mk-trail)) + true) + +;; -- sort/2 -- + +(pl-mp-test! + "sort([b,a,c], [a,b,c])" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "sort([b,a,c], [a,b,c])" {}) + (pl-mk-trail)) + true) + +(pl-mp-test! + "sort([b,a,a,c], [a,b,c]) (removes duplicates)" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "sort([b,a,a,c], [a,b,c])" {}) + (pl-mk-trail)) + true) + +(pl-mp-test! + "sort([], [])" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "sort([], [])" {}) + (pl-mk-trail)) + true) + +;; -- msort/2 -- + +(pl-mp-test! + "msort([b,a,a,c], [a,a,b,c]) (keeps duplicates)" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "msort([b,a,a,c], [a,a,b,c])" {}) + (pl-mk-trail)) + true) + +(pl-mp-test! + "msort([3,1,2,1], [1,1,2,3])" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "msort([3,1,2,1], [1,1,2,3])" {}) + (pl-mk-trail)) + true) + +;; -- atom_number/2 -- + +(define pl-mp-env-an1 {}) +(pl-solve-once! + pl-mp-db + (pl-mp-goal "atom_number('42', N)" pl-mp-env-an1) + (pl-mk-trail)) +(pl-mp-test! + "atom_number('42', N) -> N=42" + (pl-num-val (pl-walk-deep (dict-get pl-mp-env-an1 "N"))) + 42) + +(define pl-mp-env-an2 {}) +(pl-solve-once! + pl-mp-db + (pl-mp-goal "atom_number(A, 7)" pl-mp-env-an2) + (pl-mk-trail)) +(pl-mp-test! + "atom_number(A, 7) -> A='7'" + (pl-atom-name (pl-walk-deep (dict-get pl-mp-env-an2 "A"))) + "7") + +(pl-mp-test! + "atom_number(foo, N) fails (not a number)" + (pl-solve-once! + pl-mp-db + (pl-mp-goal "atom_number(foo, N)" {}) + (pl-mk-trail)) + false) + +;; -- number_string/2 -- + +(define pl-mp-env-ns1 {}) +(pl-solve-once! + pl-mp-db + (pl-mp-goal "number_string(42, S)" pl-mp-env-ns1) + (pl-mk-trail)) +(pl-mp-test! + "number_string(42, S) -> S='42'" + (pl-atom-name (pl-walk-deep (dict-get pl-mp-env-ns1 "S"))) + "42") + +(define pl-mp-env-ns2 {}) +(pl-solve-once! + pl-mp-db + (pl-mp-goal "number_string(N, '3.14')" pl-mp-env-ns2) + (pl-mk-trail)) +(pl-mp-test! + "number_string(N, '3.14') -> N=3.14" + (pl-num-val (pl-walk-deep (dict-get pl-mp-env-ns2 "N"))) + 3.14) + +(define pl-meta-predicates-tests-run! (fn () {:failed pl-mp-test-fail :passed pl-mp-test-pass :total pl-mp-test-count :failures pl-mp-test-failures})) \ No newline at end of file diff --git a/lib/prolog/tests/operators.sx b/lib/prolog/tests/operators.sx new file mode 100644 index 00000000..a992ad51 --- /dev/null +++ b/lib/prolog/tests/operators.sx @@ -0,0 +1,193 @@ +;; lib/prolog/tests/operators.sx — operator-table parsing + comparison built-ins. + +(define pl-op-test-count 0) +(define pl-op-test-pass 0) +(define pl-op-test-fail 0) +(define pl-op-test-failures (list)) + +(define + pl-op-test! + (fn + (name got expected) + (begin + (set! pl-op-test-count (+ pl-op-test-count 1)) + (if + (= got expected) + (set! pl-op-test-pass (+ pl-op-test-pass 1)) + (begin + (set! pl-op-test-fail (+ pl-op-test-fail 1)) + (append! + pl-op-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define pl-op-empty-db (pl-mk-db)) + +(define + pl-op-body + (fn (src) (nth (first (pl-parse (str "g :- " src "."))) 2))) + +(define pl-op-goal (fn (src env) (pl-instantiate (pl-op-body src) env))) + +;; ── parsing tests ── + +(pl-op-test! + "infix +" + (pl-op-body "a + b") + (list "compound" "+" (list (list "atom" "a") (list "atom" "b")))) + +(pl-op-test! + "infix * tighter than +" + (pl-op-body "a + b * c") + (list + "compound" + "+" + (list + (list "atom" "a") + (list "compound" "*" (list (list "atom" "b") (list "atom" "c")))))) + +(pl-op-test! + "parens override precedence" + (pl-op-body "(a + b) * c") + (list + "compound" + "*" + (list + (list "compound" "+" (list (list "atom" "a") (list "atom" "b"))) + (list "atom" "c")))) + +(pl-op-test! + "+ is yfx (left-assoc)" + (pl-op-body "a + b + c") + (list + "compound" + "+" + (list + (list "compound" "+" (list (list "atom" "a") (list "atom" "b"))) + (list "atom" "c")))) + +(pl-op-test! + "; is xfy (right-assoc)" + (pl-op-body "a ; b ; c") + (list + "compound" + ";" + (list + (list "atom" "a") + (list "compound" ";" (list (list "atom" "b") (list "atom" "c")))))) + +(pl-op-test! + "= folds at 700" + (pl-op-body "X = 5") + (list "compound" "=" (list (list "var" "X") (list "num" 5)))) + +(pl-op-test! + "is + nests via 700>500>400" + (pl-op-body "X is 2 + 3 * 4") + (list + "compound" + "is" + (list + (list "var" "X") + (list + "compound" + "+" + (list + (list "num" 2) + (list "compound" "*" (list (list "num" 3) (list "num" 4)))))))) + +(pl-op-test! + "< parses at 700" + (pl-op-body "2 < 3") + (list "compound" "<" (list (list "num" 2) (list "num" 3)))) + +(pl-op-test! + "mod parses as yfx 400" + (pl-op-body "10 mod 3") + (list "compound" "mod" (list (list "num" 10) (list "num" 3)))) + +(pl-op-test! + "comma in body folds right-assoc" + (pl-op-body "a, b, c") + (list + "compound" + "," + (list + (list "atom" "a") + (list "compound" "," (list (list "atom" "b") (list "atom" "c")))))) + +;; ── solver tests via infix ── + +(pl-op-test! + "X is 2 + 3 binds X = 5" + (let + ((env {}) (trail (pl-mk-trail))) + (begin + (pl-solve-once! pl-op-empty-db (pl-op-goal "X is 2 + 3" env) trail) + (pl-num-val (pl-walk-deep (dict-get env "X"))))) + 5) + +(pl-op-test! + "infix conjunction parses + solves" + (pl-solve-once! + pl-op-empty-db + (pl-op-goal "X = 5, X = 5" {}) + (pl-mk-trail)) + true) + +(pl-op-test! + "infix mismatch fails" + (pl-solve-once! + pl-op-empty-db + (pl-op-goal "X = 5, X = 6" {}) + (pl-mk-trail)) + false) + +(pl-op-test! + "infix disjunction picks left" + (pl-solve-once! + pl-op-empty-db + (pl-op-goal "true ; fail" {}) + (pl-mk-trail)) + true) + +(pl-op-test! + "2 < 5 succeeds" + (pl-solve-once! + pl-op-empty-db + (pl-op-goal "2 < 5" {}) + (pl-mk-trail)) + true) + +(pl-op-test! + "5 < 2 fails" + (pl-solve-once! + pl-op-empty-db + (pl-op-goal "5 < 2" {}) + (pl-mk-trail)) + false) + +(pl-op-test! + "5 >= 5 succeeds" + (pl-solve-once! + pl-op-empty-db + (pl-op-goal "5 >= 5" {}) + (pl-mk-trail)) + true) + +(pl-op-test! + "3 =< 5 succeeds" + (pl-solve-once! + pl-op-empty-db + (pl-op-goal "3 =< 5" {}) + (pl-mk-trail)) + true) + +(pl-op-test! + "infix < with arithmetic both sides" + (pl-solve-once! + pl-op-empty-db + (pl-op-goal "1 + 2 < 2 * 3" {}) + (pl-mk-trail)) + true) + +(define pl-operators-tests-run! (fn () {:failed pl-op-test-fail :passed pl-op-test-pass :total pl-op-test-count :failures pl-op-test-failures})) diff --git a/lib/prolog/tests/programs/append.pl b/lib/prolog/tests/programs/append.pl new file mode 100644 index 00000000..938666e6 --- /dev/null +++ b/lib/prolog/tests/programs/append.pl @@ -0,0 +1,5 @@ +%% append/3 — list concatenation, classic Prolog +%% Two clauses: empty-prefix base case + recursive cons-prefix. +%% Bidirectional — works in all modes: build, check, split. +append([], L, L). +append([H|T], L, [H|R]) :- append(T, L, R). diff --git a/lib/prolog/tests/programs/append.sx b/lib/prolog/tests/programs/append.sx new file mode 100644 index 00000000..bc3fab58 --- /dev/null +++ b/lib/prolog/tests/programs/append.sx @@ -0,0 +1,114 @@ +;; lib/prolog/tests/programs/append.sx — append/3 test runner +;; +;; Mirrors the Prolog source in append.pl (embedded as a string here because +;; the SX runtime has no file-read primitive yet). + +(define pl-ap-test-count 0) +(define pl-ap-test-pass 0) +(define pl-ap-test-fail 0) +(define pl-ap-test-failures (list)) + +(define + pl-ap-test! + (fn + (name got expected) + (begin + (set! pl-ap-test-count (+ pl-ap-test-count 1)) + (if + (= got expected) + (set! pl-ap-test-pass (+ pl-ap-test-pass 1)) + (begin + (set! pl-ap-test-fail (+ pl-ap-test-fail 1)) + (append! + pl-ap-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-ap-term-to-sx + (fn + (t) + (cond + ((pl-num? t) (pl-num-val t)) + ((pl-atom? t) (pl-atom-name t)) + (true (list :complex))))) + +(define + pl-ap-list-walked + (fn + (w) + (cond + ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list)) + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (cons + (pl-ap-term-to-sx (first (pl-args w))) + (pl-ap-list-walked (nth (pl-args w) 1)))) + (true (list :not-list))))) + +(define pl-ap-list-to-sx (fn (t) (pl-ap-list-walked (pl-walk-deep t)))) + +(define + pl-ap-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define + pl-ap-prog-src + "append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).") + +(define pl-ap-db (pl-mk-db)) + +(pl-db-load! pl-ap-db (pl-parse pl-ap-prog-src)) + +(define pl-ap-env-1 {}) +(define pl-ap-goal-1 (pl-ap-goal "append([], [a, b], X)" pl-ap-env-1)) +(pl-solve-once! pl-ap-db pl-ap-goal-1 (pl-mk-trail)) + +(pl-ap-test! + "append([], [a, b], X) → X = [a, b]" + (pl-ap-list-to-sx (dict-get pl-ap-env-1 "X")) + (list "a" "b")) + +(define pl-ap-env-2 {}) +(define pl-ap-goal-2 (pl-ap-goal "append([1, 2], [3, 4], X)" pl-ap-env-2)) +(pl-solve-once! pl-ap-db pl-ap-goal-2 (pl-mk-trail)) + +(pl-ap-test! + "append([1, 2], [3, 4], X) → X = [1, 2, 3, 4]" + (pl-ap-list-to-sx (dict-get pl-ap-env-2 "X")) + (list 1 2 3 4)) + +(pl-ap-test! + "append([1], [2, 3], [1, 2, 3]) succeeds" + (pl-solve-once! + pl-ap-db + (pl-ap-goal "append([1], [2, 3], [1, 2, 3])" {}) + (pl-mk-trail)) + true) + +(pl-ap-test! + "append([1, 2], [3], [1, 2, 4]) fails" + (pl-solve-once! + pl-ap-db + (pl-ap-goal "append([1, 2], [3], [1, 2, 4])" {}) + (pl-mk-trail)) + false) + +(pl-ap-test! + "append(X, Y, [1, 2, 3]) backtracks 4 times" + (pl-solve-count! + pl-ap-db + (pl-ap-goal "append(X, Y, [1, 2, 3])" {}) + (pl-mk-trail)) + 4) + +(define pl-ap-env-6 {}) +(define pl-ap-goal-6 (pl-ap-goal "append(X, [3], [1, 2, 3])" pl-ap-env-6)) +(pl-solve-once! pl-ap-db pl-ap-goal-6 (pl-mk-trail)) + +(pl-ap-test! + "append(X, [3], [1, 2, 3]) deduces X = [1, 2]" + (pl-ap-list-to-sx (dict-get pl-ap-env-6 "X")) + (list 1 2)) + +(define pl-append-tests-run! (fn () {:failed pl-ap-test-fail :passed pl-ap-test-pass :total pl-ap-test-count :failures pl-ap-test-failures})) diff --git a/lib/prolog/tests/programs/family.pl b/lib/prolog/tests/programs/family.pl new file mode 100644 index 00000000..cb24a9c3 --- /dev/null +++ b/lib/prolog/tests/programs/family.pl @@ -0,0 +1,24 @@ +%% family — facts + transitive ancestor + derived relations. +%% Five-generation tree: tom -> bob -> {ann, pat} -> jim, plus tom's +%% other child liz. + +parent(tom, bob). +parent(tom, liz). +parent(bob, ann). +parent(bob, pat). +parent(pat, jim). + +male(tom). +male(bob). +male(jim). +male(pat). +female(liz). +female(ann). + +father(F, C) :- parent(F, C), male(F). +mother(M, C) :- parent(M, C), female(M). + +ancestor(X, Y) :- parent(X, Y). +ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y). + +sibling(X, Y) :- parent(P, X), parent(P, Y), \=(X, Y). diff --git a/lib/prolog/tests/programs/family.sx b/lib/prolog/tests/programs/family.sx new file mode 100644 index 00000000..0c139499 --- /dev/null +++ b/lib/prolog/tests/programs/family.sx @@ -0,0 +1,116 @@ +;; lib/prolog/tests/programs/family.sx — facts + ancestor + sibling relations. + +(define pl-fa-test-count 0) +(define pl-fa-test-pass 0) +(define pl-fa-test-fail 0) +(define pl-fa-test-failures (list)) + +(define + pl-fa-test! + (fn + (name got expected) + (begin + (set! pl-fa-test-count (+ pl-fa-test-count 1)) + (if + (= got expected) + (set! pl-fa-test-pass (+ pl-fa-test-pass 1)) + (begin + (set! pl-fa-test-fail (+ pl-fa-test-fail 1)) + (append! + pl-fa-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-fa-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define + pl-fa-prog-src + "parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(bob, pat). parent(pat, jim). male(tom). male(bob). male(jim). male(pat). female(liz). female(ann). father(F, C) :- parent(F, C), male(F). mother(M, C) :- parent(M, C), female(M). ancestor(X, Y) :- parent(X, Y). ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y). sibling(X, Y) :- parent(P, X), parent(P, Y), \\=(X, Y).") + +(define pl-fa-db (pl-mk-db)) +(pl-db-load! pl-fa-db (pl-parse pl-fa-prog-src)) + +(pl-fa-test! + "parent(tom, bob) is a fact" + (pl-solve-once! + pl-fa-db + (pl-fa-goal "parent(tom, bob)" {}) + (pl-mk-trail)) + true) + +(pl-fa-test! + "parent(tom, ann) — not a direct parent" + (pl-solve-once! + pl-fa-db + (pl-fa-goal "parent(tom, ann)" {}) + (pl-mk-trail)) + false) + +(pl-fa-test! + "5 parent/2 facts in total" + (pl-solve-count! + pl-fa-db + (pl-fa-goal "parent(X, Y)" {}) + (pl-mk-trail)) + 5) + +(pl-fa-test! + "ancestor(tom, jim) — three-step transitive" + (pl-solve-once! + pl-fa-db + (pl-fa-goal "ancestor(tom, jim)" {}) + (pl-mk-trail)) + true) + +(pl-fa-test! + "tom has 5 ancestors-of: bob, liz, ann, pat, jim" + (pl-solve-count! + pl-fa-db + (pl-fa-goal "ancestor(tom, X)" {}) + (pl-mk-trail)) + 5) + +(pl-fa-test! + "father(bob, ann) succeeds" + (pl-solve-once! + pl-fa-db + (pl-fa-goal "father(bob, ann)" {}) + (pl-mk-trail)) + true) + +(pl-fa-test! + "father(liz, ann) fails (liz is female)" + (pl-solve-once! + pl-fa-db + (pl-fa-goal "father(liz, ann)" {}) + (pl-mk-trail)) + false) + +(pl-fa-test! + "mother(liz, X) fails (liz has no children)" + (pl-solve-once! + pl-fa-db + (pl-fa-goal "mother(liz, X)" {}) + (pl-mk-trail)) + false) + +(pl-fa-test! + "sibling(ann, pat) succeeds" + (pl-solve-once! + pl-fa-db + (pl-fa-goal "sibling(ann, pat)" {}) + (pl-mk-trail)) + true) + +(pl-fa-test! + "sibling(ann, ann) fails by \\=" + (pl-solve-once! + pl-fa-db + (pl-fa-goal "sibling(ann, ann)" {}) + (pl-mk-trail)) + false) + +(define pl-family-tests-run! (fn () {:failed pl-fa-test-fail :passed pl-fa-test-pass :total pl-fa-test-count :failures pl-fa-test-failures})) diff --git a/lib/prolog/tests/programs/member.pl b/lib/prolog/tests/programs/member.pl new file mode 100644 index 00000000..ca078b78 --- /dev/null +++ b/lib/prolog/tests/programs/member.pl @@ -0,0 +1,4 @@ +%% member/2 — list membership. +%% Generates all solutions on backtracking when the element is unbound. +member(X, [X|_]). +member(X, [_|T]) :- member(X, T). diff --git a/lib/prolog/tests/programs/member.sx b/lib/prolog/tests/programs/member.sx new file mode 100644 index 00000000..51e7846f --- /dev/null +++ b/lib/prolog/tests/programs/member.sx @@ -0,0 +1,91 @@ +;; lib/prolog/tests/programs/member.sx — member/2 generator. + +(define pl-mb-test-count 0) +(define pl-mb-test-pass 0) +(define pl-mb-test-fail 0) +(define pl-mb-test-failures (list)) + +(define + pl-mb-test! + (fn + (name got expected) + (begin + (set! pl-mb-test-count (+ pl-mb-test-count 1)) + (if + (= got expected) + (set! pl-mb-test-pass (+ pl-mb-test-pass 1)) + (begin + (set! pl-mb-test-fail (+ pl-mb-test-fail 1)) + (append! + pl-mb-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-mb-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-mb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).") + +(define pl-mb-db (pl-mk-db)) +(pl-db-load! pl-mb-db (pl-parse pl-mb-prog-src)) + +(pl-mb-test! + "member(2, [1, 2, 3]) succeeds" + (pl-solve-once! + pl-mb-db + (pl-mb-goal "member(2, [1, 2, 3])" {}) + (pl-mk-trail)) + true) + +(pl-mb-test! + "member(4, [1, 2, 3]) fails" + (pl-solve-once! + pl-mb-db + (pl-mb-goal "member(4, [1, 2, 3])" {}) + (pl-mk-trail)) + false) + +(pl-mb-test! + "member(X, []) fails" + (pl-solve-once! + pl-mb-db + (pl-mb-goal "member(X, [])" {}) + (pl-mk-trail)) + false) + +(pl-mb-test! + "member(X, [a, b, c]) generates 3 solutions" + (pl-solve-count! + pl-mb-db + (pl-mb-goal "member(X, [a, b, c])" {}) + (pl-mk-trail)) + 3) + +(define pl-mb-env-1 {}) +(define pl-mb-goal-1 (pl-mb-goal "member(X, [11, 22, 33])" pl-mb-env-1)) +(pl-solve-once! pl-mb-db pl-mb-goal-1 (pl-mk-trail)) + +(pl-mb-test! + "member(X, [11, 22, 33]) first solution X = 11" + (pl-num-val (pl-walk-deep (dict-get pl-mb-env-1 "X"))) + 11) + +(pl-mb-test! + "member(2, [1, 2, 3, 2, 1]) matches twice on backtrack" + (pl-solve-count! + pl-mb-db + (pl-mb-goal "member(2, [1, 2, 3, 2, 1])" {}) + (pl-mk-trail)) + 2) + +(pl-mb-test! + "member with unbound list cell unifies" + (pl-solve-once! + pl-mb-db + (pl-mb-goal "member(a, [X, b, c])" {}) + (pl-mk-trail)) + true) + +(define pl-member-tests-run! (fn () {:failed pl-mb-test-fail :passed pl-mb-test-pass :total pl-mb-test-count :failures pl-mb-test-failures})) diff --git a/lib/prolog/tests/programs/nqueens.pl b/lib/prolog/tests/programs/nqueens.pl new file mode 100644 index 00000000..c5fc43c9 --- /dev/null +++ b/lib/prolog/tests/programs/nqueens.pl @@ -0,0 +1,27 @@ +%% nqueens — permutation-and-test formulation. +%% Caller passes the row list [1..N]; queens/2 finds N column placements +%% s.t. no two queens attack on a diagonal. Same-column attacks are +%% structurally impossible — Qs is a permutation, all distinct. +%% +%% No `>/2` ` S=10" + (pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl1 "S"))) + 10) + +(define pl-sp-env-fl2 {:S (pl-mk-rt-var "S")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "foldl(add, [], 5, S)" pl-sp-env-fl2) + (pl-mk-trail)) +(pl-sp-test! + "foldl(add,[],5,S) -> S=5" + (pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl2 "S"))) + 5) + +(define pl-sp-env-fl3 {:S (pl-mk-rt-var "S")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "foldl(add, [1,2,3], 0, S)" pl-sp-env-fl3) + (pl-mk-trail)) +(pl-sp-test! + "foldl(add,[1,2,3],0,S) -> S=6" + (pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl3 "S"))) + 6) + +;; ── list_to_set/2 ────────────────────────────────────────────────── + +(define pl-sp-env-lts1 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "list_to_set([1,2,3,2,1], R)" pl-sp-env-lts1) + (pl-mk-trail)) +(pl-sp-test! + "list_to_set([1,2,3,2,1],R) -> [1,2,3]" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts1 "R"))) + ".(1, .(2, .(3, [])))") + +(define pl-sp-env-lts2 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "list_to_set([], R)" pl-sp-env-lts2) + (pl-mk-trail)) +(pl-sp-test! + "list_to_set([],R) -> []" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts2 "R"))) + "[]") + +(define pl-sp-env-lts3 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "list_to_set([a,b,a,c], R)" pl-sp-env-lts3) + (pl-mk-trail)) +(pl-sp-test! + "list_to_set([a,b,a,c],R) -> [a,b,c]" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts3 "R"))) + ".(a, .(b, .(c, [])))") + +;; ── intersection/3 ───────────────────────────────────────────────── + +(define pl-sp-env-int1 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "intersection([1,2,3,4], [2,4,6], R)" pl-sp-env-int1) + (pl-mk-trail)) +(pl-sp-test! + "intersection([1,2,3,4],[2,4,6],R) -> [2,4]" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-int1 "R"))) + ".(2, .(4, []))") + +(define pl-sp-env-int2 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "intersection([1,2,3], [4,5,6], R)" pl-sp-env-int2) + (pl-mk-trail)) +(pl-sp-test! + "intersection([1,2,3],[4,5,6],R) -> []" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-int2 "R"))) + "[]") + +(define pl-sp-env-int3 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "intersection([], [1,2,3], R)" pl-sp-env-int3) + (pl-mk-trail)) +(pl-sp-test! + "intersection([],[1,2,3],R) -> []" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-int3 "R"))) + "[]") + +;; ── subtract/3 ───────────────────────────────────────────────────── + +(define pl-sp-env-sub1 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "subtract([1,2,3,4], [2,4], R)" pl-sp-env-sub1) + (pl-mk-trail)) +(pl-sp-test! + "subtract([1,2,3,4],[2,4],R) -> [1,3]" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub1 "R"))) + ".(1, .(3, []))") + +(define pl-sp-env-sub2 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "subtract([1,2,3], [], R)" pl-sp-env-sub2) + (pl-mk-trail)) +(pl-sp-test! + "subtract([1,2,3],[],R) -> [1,2,3]" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub2 "R"))) + ".(1, .(2, .(3, [])))") + +(define pl-sp-env-sub3 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "subtract([], [1,2], R)" pl-sp-env-sub3) + (pl-mk-trail)) +(pl-sp-test! + "subtract([],[1,2],R) -> []" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub3 "R"))) + "[]") + +;; ── union/3 ──────────────────────────────────────────────────────── + +(define pl-sp-env-uni1 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "union([1,2,3], [2,3,4], R)" pl-sp-env-uni1) + (pl-mk-trail)) +(pl-sp-test! + "union([1,2,3],[2,3,4],R) -> [1,2,3,4]" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni1 "R"))) + ".(1, .(2, .(3, .(4, []))))") + +(define pl-sp-env-uni2 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "union([], [1,2], R)" pl-sp-env-uni2) + (pl-mk-trail)) +(pl-sp-test! + "union([],[1,2],R) -> [1,2]" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni2 "R"))) + ".(1, .(2, []))") + +(define pl-sp-env-uni3 {:R (pl-mk-rt-var "R")}) +(pl-solve-once! + pl-sp-db + (pl-sp-goal "union([1,2], [], R)" pl-sp-env-uni3) + (pl-mk-trail)) +(pl-sp-test! + "union([1,2],[],R) -> [1,2]" + (pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni3 "R"))) + ".(1, .(2, []))") + +;; ── Runner ───────────────────────────────────────────────────────── + +(define pl-set-predicates-tests-run! (fn () {:failed pl-sp-test-fail :passed pl-sp-test-pass :total pl-sp-test-count :failures pl-sp-test-failures})) diff --git a/lib/prolog/tests/solve.sx b/lib/prolog/tests/solve.sx new file mode 100644 index 00000000..f043c729 --- /dev/null +++ b/lib/prolog/tests/solve.sx @@ -0,0 +1,618 @@ +;; lib/prolog/tests/solve.sx — DFS solver unit tests + +(define pl-s-test-count 0) +(define pl-s-test-pass 0) +(define pl-s-test-fail 0) +(define pl-s-test-failures (list)) + +(define + pl-s-test! + (fn + (name got expected) + (begin + (set! pl-s-test-count (+ pl-s-test-count 1)) + (if + (= got expected) + (set! pl-s-test-pass (+ pl-s-test-pass 1)) + (begin + (set! pl-s-test-fail (+ pl-s-test-fail 1)) + (append! + pl-s-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-s-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-s-empty-db (pl-mk-db)) + +(pl-s-test! + "true succeeds" + (pl-solve-once! pl-s-empty-db (pl-s-goal "true" {}) (pl-mk-trail)) + true) + +(pl-s-test! + "fail fails" + (pl-solve-once! pl-s-empty-db (pl-s-goal "fail" {}) (pl-mk-trail)) + false) + +(pl-s-test! + "= identical atoms" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "=(a, a)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "= different atoms" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "=(a, b)" {}) + (pl-mk-trail)) + false) + +(pl-s-test! + "= var to atom" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "=(X, foo)" {}) + (pl-mk-trail)) + true) + +(define pl-s-env-bind {}) +(define pl-s-trail-bind (pl-mk-trail)) +(define pl-s-goal-bind (pl-s-goal "=(X, foo)" pl-s-env-bind)) +(pl-solve-once! pl-s-empty-db pl-s-goal-bind pl-s-trail-bind) + +(pl-s-test! + "X bound to foo after =(X, foo)" + (pl-atom-name (pl-walk-deep (dict-get pl-s-env-bind "X"))) + "foo") + +(pl-s-test! + "true , true succeeds" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "true, true" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "true , fail fails" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "true, fail" {}) + (pl-mk-trail)) + false) + +(pl-s-test! + "consistent X bindings succeed" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "=(X, a), =(X, a)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "conflicting X bindings fail" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "=(X, a), =(X, b)" {}) + (pl-mk-trail)) + false) + +(define pl-s-db1 (pl-mk-db)) +(pl-db-load! + pl-s-db1 + (pl-parse "parent(tom, bob). parent(bob, liz). parent(bob, ann).")) + +(pl-s-test! + "fact lookup hit" + (pl-solve-once! + pl-s-db1 + (pl-s-goal "parent(tom, bob)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "fact lookup miss" + (pl-solve-once! + pl-s-db1 + (pl-s-goal "parent(tom, liz)" {}) + (pl-mk-trail)) + false) + +(pl-s-test! + "all parent solutions" + (pl-solve-count! + pl-s-db1 + (pl-s-goal "parent(X, Y)" {}) + (pl-mk-trail)) + 3) + +(pl-s-test! + "fixed first arg solutions" + (pl-solve-count! + pl-s-db1 + (pl-s-goal "parent(bob, Y)" {}) + (pl-mk-trail)) + 2) + +(define pl-s-db2 (pl-mk-db)) +(pl-db-load! + pl-s-db2 + (pl-parse + "parent(tom, bob). parent(bob, ann). ancestor(X, Y) :- parent(X, Y). ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")) + +(pl-s-test! + "rule direct ancestor" + (pl-solve-once! + pl-s-db2 + (pl-s-goal "ancestor(tom, bob)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "rule transitive ancestor" + (pl-solve-once! + pl-s-db2 + (pl-s-goal "ancestor(tom, ann)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "rule no path" + (pl-solve-once! + pl-s-db2 + (pl-s-goal "ancestor(ann, tom)" {}) + (pl-mk-trail)) + false) + +(define pl-s-env-undo {}) +(define pl-s-trail-undo (pl-mk-trail)) +(define pl-s-goal-undo (pl-s-goal "=(X, a), fail" pl-s-env-undo)) +(pl-solve-once! pl-s-empty-db pl-s-goal-undo pl-s-trail-undo) + +(pl-s-test! + "trail undone after failure leaves X unbound" + (pl-var-bound? (dict-get pl-s-env-undo "X")) + false) + +(define pl-s-db-cut1 (pl-mk-db)) + +(pl-db-load! pl-s-db-cut1 (pl-parse "g :- !. g :- true.")) + +(pl-s-test! + "bare cut succeeds" + (pl-solve-once! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail)) + true) + +(pl-s-test! + "cut commits to first matching clause" + (pl-solve-count! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail)) + 1) + +(define pl-s-db-cut2 (pl-mk-db)) + +(pl-db-load! pl-s-db-cut2 (pl-parse "a(1). a(2). g(X) :- a(X), !.")) + +(pl-s-test! + "cut commits to first a solution" + (pl-solve-count! pl-s-db-cut2 (pl-s-goal "g(X)" {}) (pl-mk-trail)) + 1) + +(define pl-s-db-cut3 (pl-mk-db)) + +(pl-db-load! + pl-s-db-cut3 + (pl-parse "a(1). a(2). g(X) :- a(X), !, fail. g(99).")) + +(pl-s-test! + "cut then fail blocks alt clauses" + (pl-solve-count! pl-s-db-cut3 (pl-s-goal "g(X)" {}) (pl-mk-trail)) + 0) + +(define pl-s-db-cut4 (pl-mk-db)) + +(pl-db-load! + pl-s-db-cut4 + (pl-parse "a(1). b(10). b(20). g(X, Y) :- a(X), !, b(Y).")) + +(pl-s-test! + "post-cut goal backtracks freely" + (pl-solve-count! + pl-s-db-cut4 + (pl-s-goal "g(X, Y)" {}) + (pl-mk-trail)) + 2) + +(define pl-s-db-cut5 (pl-mk-db)) + +(pl-db-load! + pl-s-db-cut5 + (pl-parse "r(1). r(2). q :- r(X), !. p :- q. p :- true.")) + +(pl-s-test! + "inner cut does not commit outer predicate" + (pl-solve-count! pl-s-db-cut5 (pl-s-goal "p" {}) (pl-mk-trail)) + 2) + +(pl-s-test! + "\\= different atoms succeeds" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "\\=(a, b)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "\\= same atoms fails" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "\\=(a, a)" {}) + (pl-mk-trail)) + false) + +(pl-s-test! + "\\= var-vs-atom would unify so fails" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "\\=(X, a)" {}) + (pl-mk-trail)) + false) + +(define pl-s-env-ne {}) + +(define pl-s-trail-ne (pl-mk-trail)) + +(define pl-s-goal-ne (pl-s-goal "\\=(X, a)" pl-s-env-ne)) + +(pl-solve-once! pl-s-empty-db pl-s-goal-ne pl-s-trail-ne) + +(pl-s-test! + "\\= leaves no bindings" + (pl-var-bound? (dict-get pl-s-env-ne "X")) + false) + +(pl-s-test! + "; left succeeds" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal ";(true, fail)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "; right succeeds when left fails" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal ";(fail, true)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "; both fail" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal ";(fail, fail)" {}) + (pl-mk-trail)) + false) + +(pl-s-test! + "; both branches counted" + (pl-solve-count! + pl-s-empty-db + (pl-s-goal ";(true, true)" {}) + (pl-mk-trail)) + 2) + +(define pl-s-db-call (pl-mk-db)) + +(pl-db-load! pl-s-db-call (pl-parse "p(1). p(2).")) + +(pl-s-test! + "call(true) succeeds" + (pl-solve-once! + pl-s-db-call + (pl-s-goal "call(true)" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "call(p(X)) yields all solutions" + (pl-solve-count! + pl-s-db-call + (pl-s-goal "call(p(X))" {}) + (pl-mk-trail)) + 2) + +(pl-s-test! + "call of bound goal var resolves" + (pl-solve-once! + pl-s-db-call + (pl-s-goal "=(G, true), call(G)" {}) + (pl-mk-trail)) + true) + +(define pl-s-db-ite (pl-mk-db)) + +(pl-db-load! pl-s-db-ite (pl-parse "p(1). p(2). q(yes). q(no).")) + +(pl-s-test! + "if-then-else: cond true → then runs" + (pl-solve-once! + pl-s-db-ite + (pl-s-goal ";(->(true, =(X, ok)), =(X, fallback))" {}) + (pl-mk-trail)) + true) + +(define pl-s-env-ite1 {}) + +(pl-solve-once! + pl-s-db-ite + (pl-s-goal ";(->(true, =(X, ok)), =(X, fallback))" pl-s-env-ite1) + (pl-mk-trail)) + +(pl-s-test! + "if-then-else: cond true binds via then" + (pl-atom-name (pl-walk-deep (dict-get pl-s-env-ite1 "X"))) + "ok") + +(pl-s-test! + "if-then-else: cond false → else" + (pl-solve-once! + pl-s-db-ite + (pl-s-goal ";(->(fail, =(X, ok)), =(X, fallback))" {}) + (pl-mk-trail)) + true) + +(define pl-s-env-ite2 {}) + +(pl-solve-once! + pl-s-db-ite + (pl-s-goal ";(->(fail, =(X, ok)), =(X, fallback))" pl-s-env-ite2) + (pl-mk-trail)) + +(pl-s-test! + "if-then-else: cond false binds via else" + (pl-atom-name (pl-walk-deep (dict-get pl-s-env-ite2 "X"))) + "fallback") + +(pl-s-test! + "if-then-else: cond commits to first solution (count = 1)" + (pl-solve-count! + pl-s-db-ite + (pl-s-goal ";(->(p(X), =(Y, found)), =(Y, none))" {}) + (pl-mk-trail)) + 1) + +(pl-s-test! + "if-then-else: then can backtrack" + (pl-solve-count! + pl-s-db-ite + (pl-s-goal ";(->(true, p(X)), =(X, none))" {}) + (pl-mk-trail)) + 2) + +(pl-s-test! + "if-then-else: else can backtrack" + (pl-solve-count! + pl-s-db-ite + (pl-s-goal ";(->(fail, =(X, ignored)), p(X))" {}) + (pl-mk-trail)) + 2) + +(pl-s-test! + "standalone -> with true cond succeeds" + (pl-solve-once! + pl-s-db-ite + (pl-s-goal "->(true, =(X, hi))" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "standalone -> with false cond fails" + (pl-solve-once! + pl-s-db-ite + (pl-s-goal "->(fail, =(X, hi))" {}) + (pl-mk-trail)) + false) + +(pl-s-test! + "write(hello)" + (begin + (pl-output-clear!) + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "write(hello)" {}) + (pl-mk-trail)) + pl-output-buffer) + "hello") + +(pl-s-test! + "nl outputs newline" + (begin + (pl-output-clear!) + (pl-solve-once! pl-s-empty-db (pl-s-goal "nl" {}) (pl-mk-trail)) + pl-output-buffer) + "\n") + +(pl-s-test! + "write(42) outputs digits" + (begin + (pl-output-clear!) + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "write(42)" {}) + (pl-mk-trail)) + pl-output-buffer) + "42") + +(pl-s-test! + "write(foo(a, b)) formats compound" + (begin + (pl-output-clear!) + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "write(foo(a, b))" {}) + (pl-mk-trail)) + pl-output-buffer) + "foo(a, b)") + +(pl-s-test! + "write conjunction" + (begin + (pl-output-clear!) + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "write(a), write(b)" {}) + (pl-mk-trail)) + pl-output-buffer) + "ab") + +(pl-s-test! + "write of bound var walks binding" + (begin + (pl-output-clear!) + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "=(X, hello), write(X)" {}) + (pl-mk-trail)) + pl-output-buffer) + "hello") + +(pl-s-test! + "write then nl" + (begin + (pl-output-clear!) + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "write(hi), nl" {}) + (pl-mk-trail)) + pl-output-buffer) + "hi\n") + +(define pl-s-env-arith1 {}) + +(pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(X, 42)" pl-s-env-arith1) + (pl-mk-trail)) + +(pl-s-test! + "is(X, 42) binds X to 42" + (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith1 "X"))) + 42) + +(define pl-s-env-arith2 {}) + +(pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(X, +(2, 3))" pl-s-env-arith2) + (pl-mk-trail)) + +(pl-s-test! + "is(X, +(2, 3)) binds X to 5" + (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith2 "X"))) + 5) + +(define pl-s-env-arith3 {}) + +(pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(X, *(2, 3))" pl-s-env-arith3) + (pl-mk-trail)) + +(pl-s-test! + "is(X, *(2, 3)) binds X to 6" + (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith3 "X"))) + 6) + +(define pl-s-env-arith4 {}) + +(pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(X, -(10, 3))" pl-s-env-arith4) + (pl-mk-trail)) + +(pl-s-test! + "is(X, -(10, 3)) binds X to 7" + (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith4 "X"))) + 7) + +(define pl-s-env-arith5 {}) + +(pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(X, /(10, 2))" pl-s-env-arith5) + (pl-mk-trail)) + +(pl-s-test! + "is(X, /(10, 2)) binds X to 5" + (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith5 "X"))) + 5) + +(define pl-s-env-arith6 {}) + +(pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(X, mod(10, 3))" pl-s-env-arith6) + (pl-mk-trail)) + +(pl-s-test! + "is(X, mod(10, 3)) binds X to 1" + (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith6 "X"))) + 1) + +(define pl-s-env-arith7 {}) + +(pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(X, abs(-(0, 5)))" pl-s-env-arith7) + (pl-mk-trail)) + +(pl-s-test! + "is(X, abs(-(0, 5))) binds X to 5" + (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith7 "X"))) + 5) + +(define pl-s-env-arith8 {}) + +(pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(X, +(2, *(3, 4)))" pl-s-env-arith8) + (pl-mk-trail)) + +(pl-s-test! + "is(X, +(2, *(3, 4))) binds X to 14 (nested)" + (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith8 "X"))) + 14) + +(pl-s-test! + "is(5, +(2, 3)) succeeds (LHS num matches)" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(5, +(2, 3))" {}) + (pl-mk-trail)) + true) + +(pl-s-test! + "is(6, +(2, 3)) fails (LHS num mismatch)" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "is(6, +(2, 3))" {}) + (pl-mk-trail)) + false) + +(pl-s-test! + "is propagates bound vars on RHS" + (pl-solve-once! + pl-s-empty-db + (pl-s-goal "=(Y, 4), is(X, +(Y, 1)), =(X, 5)" {}) + (pl-mk-trail)) + true) + +(define pl-solve-tests-run! (fn () {:failed pl-s-test-fail :passed pl-s-test-pass :total pl-s-test-count :failures pl-s-test-failures})) diff --git a/lib/prolog/tests/string_agg.sx b/lib/prolog/tests/string_agg.sx new file mode 100644 index 00000000..3ec3b2f6 --- /dev/null +++ b/lib/prolog/tests/string_agg.sx @@ -0,0 +1,273 @@ +;; lib/prolog/tests/string_agg.sx -- sub_atom/5 + aggregate_all/3 + +(define pl-sa-test-count 0) +(define pl-sa-test-pass 0) +(define pl-sa-test-fail 0) +(define pl-sa-test-failures (list)) + +(define + pl-sa-test! + (fn + (name got expected) + (begin + (set! pl-sa-test-count (+ pl-sa-test-count 1)) + (if + (= got expected) + (set! pl-sa-test-pass (+ pl-sa-test-pass 1)) + (begin + (set! pl-sa-test-fail (+ pl-sa-test-fail 1)) + (append! + pl-sa-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-sa-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-sa-db (pl-mk-db)) + +(define + pl-sa-num-val + (fn (env key) (pl-num-val (pl-walk-deep (dict-get env key))))) + +(define + pl-sa-list-to-atoms + (fn + (t) + (let + ((w (pl-walk-deep t))) + (cond + ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list)) + ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2)) + (cons + (pl-atom-name (first (pl-args w))) + (pl-sa-list-to-atoms (nth (pl-args w) 1)))) + (true (list)))))) + +(define pl-sa-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).") +(pl-db-load! pl-sa-db (pl-parse pl-sa-prog-src)) + +;; -- sub_atom/5 -- + +(pl-sa-test! + "sub_atom ground: sub_atom(abcde,0,3,2,abc)" + (pl-solve-once! + pl-sa-db + (pl-sa-goal "sub_atom(abcde, 0, 3, 2, abc)" {}) + (pl-mk-trail)) + true) + +(pl-sa-test! + "sub_atom ground: sub_atom(abcde,2,2,1,cd)" + (pl-solve-once! + pl-sa-db + (pl-sa-goal "sub_atom(abcde, 2, 2, 1, cd)" {}) + (pl-mk-trail)) + true) + +(pl-sa-test! + "sub_atom ground mismatch fails" + (pl-solve-once! + pl-sa-db + (pl-sa-goal "sub_atom(abcde, 0, 2, 3, cd)" {}) + (pl-mk-trail)) + false) + +(pl-sa-test! + "sub_atom empty sub at start" + (pl-solve-once! + pl-sa-db + (pl-sa-goal "sub_atom(abcde, 0, 0, 5, '')" {}) + (pl-mk-trail)) + true) + +(pl-sa-test! + "sub_atom whole string" + (pl-solve-once! + pl-sa-db + (pl-sa-goal "sub_atom(hello, 0, 5, 0, hello)" {}) + (pl-mk-trail)) + true) + +(define pl-sa-env-b1 {}) +(pl-solve-once! + pl-sa-db + (pl-sa-goal "sub_atom(abcde, B, 2, A, cd)" pl-sa-env-b1) + (pl-mk-trail)) +(pl-sa-test! + "sub_atom bound SubAtom gives B=2" + (pl-sa-num-val pl-sa-env-b1 "B") + 2) +(pl-sa-test! + "sub_atom bound SubAtom gives A=1" + (pl-sa-num-val pl-sa-env-b1 "A") + 1) + +(define pl-sa-env-b2 {}) +(pl-solve-once! + pl-sa-db + (pl-sa-goal "sub_atom(hello, B, L, A, ello)" pl-sa-env-b2) + (pl-mk-trail)) +(pl-sa-test! "sub_atom ello: B=1" (pl-sa-num-val pl-sa-env-b2 "B") 1) +(pl-sa-test! "sub_atom ello: L=4" (pl-sa-num-val pl-sa-env-b2 "L") 4) +(pl-sa-test! "sub_atom ello: A=0" (pl-sa-num-val pl-sa-env-b2 "A") 0) + +(pl-sa-test! + "sub_atom ab: 6 total solutions" + (let + ((env {})) + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(count, sub_atom(ab, _, _, _, _), N)" env) + (pl-mk-trail)) + (pl-sa-num-val env "N")) + 6) + +(pl-sa-test! + "sub_atom a: 3 total solutions" + (let + ((env {})) + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(count, sub_atom(a, _, _, _, _), N)" env) + (pl-mk-trail)) + (pl-sa-num-val env "N")) + 3) + +;; -- aggregate_all/3 -- + +(pl-sa-test! + "aggregate_all count member [a,b,c] = 3" + (let + ((env {})) + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(count, member(_, [a,b,c]), N)" env) + (pl-mk-trail)) + (pl-sa-num-val env "N")) + 3) + +(pl-sa-test! + "aggregate_all count fail = 0" + (let + ((env {})) + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(count, fail, N)" env) + (pl-mk-trail)) + (pl-sa-num-val env "N")) + 0) + +(pl-sa-test! + "aggregate_all count always succeeds" + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(count, fail, _)" {}) + (pl-mk-trail)) + true) + +(define pl-sa-env-bag1 {}) +(pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(bag(X), member(X, [a,b,c]), L)" pl-sa-env-bag1) + (pl-mk-trail)) +(pl-sa-test! + "aggregate_all bag [a,b,c]" + (pl-sa-list-to-atoms (dict-get pl-sa-env-bag1 "L")) + (list "a" "b" "c")) + +(define pl-sa-env-bag2 {}) +(pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(bag(X), member(X, []), L)" pl-sa-env-bag2) + (pl-mk-trail)) +(pl-sa-test! + "aggregate_all bag empty goal = []" + (pl-sa-list-to-atoms (dict-get pl-sa-env-bag2 "L")) + (list)) + +(pl-sa-test! + "aggregate_all sum [1,2,3,4] = 10" + (let + ((env {})) + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(sum(X), member(X, [1,2,3,4]), S)" env) + (pl-mk-trail)) + (pl-sa-num-val env "S")) + 10) + +(pl-sa-test! + "aggregate_all max [3,1,4,1,5,9,2,6] = 9" + (let + ((env {})) + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(max(X), member(X, [3,1,4,1,5,9,2,6]), M)" env) + (pl-mk-trail)) + (pl-sa-num-val env "M")) + 9) + +(pl-sa-test! + "aggregate_all max empty fails" + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(max(X), member(X, []), M)" {}) + (pl-mk-trail)) + false) + +(pl-sa-test! + "aggregate_all min [3,1,4,1,5,9,2,6] = 1" + (let + ((env {})) + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(min(X), member(X, [3,1,4,1,5,9,2,6]), M)" env) + (pl-mk-trail)) + (pl-sa-num-val env "M")) + 1) + +(pl-sa-test! + "aggregate_all min empty fails" + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(min(X), member(X, []), M)" {}) + (pl-mk-trail)) + false) + +(define pl-sa-env-set1 {}) +(pl-solve-once! + pl-sa-db + (pl-sa-goal + "aggregate_all(set(X), member(X, [b,a,c,a,b]), S)" + pl-sa-env-set1) + (pl-mk-trail)) +(pl-sa-test! + "aggregate_all set [b,a,c,a,b] = [a,b,c]" + (pl-sa-list-to-atoms (dict-get pl-sa-env-set1 "S")) + (list "a" "b" "c")) + +(define pl-sa-env-set2 {}) +(pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(set(X), fail, S)" pl-sa-env-set2) + (pl-mk-trail)) +(pl-sa-test! + "aggregate_all set fail = []" + (pl-sa-list-to-atoms (dict-get pl-sa-env-set2 "S")) + (list)) + +(pl-sa-test! + "aggregate_all sum empty = 0" + (let + ((env {})) + (pl-solve-once! + pl-sa-db + (pl-sa-goal "aggregate_all(sum(X), fail, S)" env) + (pl-mk-trail)) + (pl-sa-num-val env "S")) + 0) + +(define pl-string-agg-tests-run! (fn () {:failed pl-sa-test-fail :passed pl-sa-test-pass :total pl-sa-test-count :failures pl-sa-test-failures})) diff --git a/lib/prolog/tests/term_inspect.sx b/lib/prolog/tests/term_inspect.sx new file mode 100644 index 00000000..ca207db7 --- /dev/null +++ b/lib/prolog/tests/term_inspect.sx @@ -0,0 +1,147 @@ +;; lib/prolog/tests/term_inspect.sx — copy_term/2, functor/3, arg/3. + +(define pl-tt-test-count 0) +(define pl-tt-test-pass 0) +(define pl-tt-test-fail 0) +(define pl-tt-test-failures (list)) + +(define + pl-tt-test! + (fn + (name got expected) + (begin + (set! pl-tt-test-count (+ pl-tt-test-count 1)) + (if + (= got expected) + (set! pl-tt-test-pass (+ pl-tt-test-pass 1)) + (begin + (set! pl-tt-test-fail (+ pl-tt-test-fail 1)) + (append! + pl-tt-test-failures + (str name "\n expected: " expected "\n got: " got))))))) + +(define + pl-tt-goal + (fn + (src env) + (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env))) + +(define pl-tt-db (pl-mk-db)) + +;; ── copy_term/2 ── + +(pl-tt-test! + "copy_term ground compound succeeds + copy = original" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "copy_term(foo(a, b), X), X = foo(a, b)" {}) + (pl-mk-trail)) + true) + +(pl-tt-test! + "copy_term preserves var aliasing in source" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "copy_term(p(Y, Y), p(A, B)), A = 5, B = 5" {}) + (pl-mk-trail)) + true) + +(pl-tt-test! + "copy_term distinct vars stay distinct" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "copy_term(p(Y, Y), p(A, B)), A = 5, B = 6" {}) + (pl-mk-trail)) + false) + +(define pl-tt-env-1 {}) +(pl-solve-once! + pl-tt-db + (pl-tt-goal "copy_term(X, Y), Y = 5" pl-tt-env-1) + (pl-mk-trail)) +(pl-tt-test! + "copy_term: binding the copy doesn't bind the source" + (pl-var-bound? (dict-get pl-tt-env-1 "X")) + false) + +;; ── functor/3 ── + +(define pl-tt-env-2 {}) +(pl-solve-once! + pl-tt-db + (pl-tt-goal "functor(foo(a, b, c), F, N)" pl-tt-env-2) + (pl-mk-trail)) +(pl-tt-test! + "functor of compound: F = foo" + (pl-atom-name (pl-walk-deep (dict-get pl-tt-env-2 "F"))) + "foo") +(pl-tt-test! + "functor of compound: N = 3" + (pl-num-val (pl-walk-deep (dict-get pl-tt-env-2 "N"))) + 3) + +(define pl-tt-env-3 {}) +(pl-solve-once! + pl-tt-db + (pl-tt-goal "functor(hello, F, N)" pl-tt-env-3) + (pl-mk-trail)) +(pl-tt-test! + "functor of atom: F = hello" + (pl-atom-name (pl-walk-deep (dict-get pl-tt-env-3 "F"))) + "hello") +(pl-tt-test! + "functor of atom: N = 0" + (pl-num-val (pl-walk-deep (dict-get pl-tt-env-3 "N"))) + 0) + +(pl-tt-test! + "functor construct compound: T unifies with foo(a, b)" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "functor(T, foo, 2), T = foo(a, b)" {}) + (pl-mk-trail)) + true) + +(pl-tt-test! + "functor construct atom: T = hello" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "functor(T, hello, 0), T = hello" {}) + (pl-mk-trail)) + true) + +;; ── arg/3 ── + +(pl-tt-test! + "arg(1, foo(a, b, c), a)" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "arg(1, foo(a, b, c), a)" {}) + (pl-mk-trail)) + true) + +(pl-tt-test! + "arg(2, foo(a, b, c), X) → X = b" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "arg(2, foo(a, b, c), X), X = b" {}) + (pl-mk-trail)) + true) + +(pl-tt-test! + "arg out-of-range high fails" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "arg(4, foo(a, b, c), X)" {}) + (pl-mk-trail)) + false) + +(pl-tt-test! + "arg(0, ...) fails (1-indexed)" + (pl-solve-once! + pl-tt-db + (pl-tt-goal "arg(0, foo(a), X)" {}) + (pl-mk-trail)) + false) + +(define pl-term-inspect-tests-run! (fn () {:failed pl-tt-test-fail :passed pl-tt-test-pass :total pl-tt-test-count :failures pl-tt-test-failures})) diff --git a/lib/r7rs.sx b/lib/r7rs.sx index 9e157f53..b2b303dd 100644 --- a/lib/r7rs.sx +++ b/lib/r7rs.sx @@ -73,7 +73,10 @@ (define string->symbol make-symbol) -(define number->string (fn (n) (str n))) +(define number->string + (let ((prim-n->s number->string)) + (fn (n &rest r) + (if (= (len r) 0) (str n) (prim-n->s n (first r)))))) (define string->number diff --git a/lib/ruby/runtime.sx b/lib/ruby/runtime.sx new file mode 100644 index 00000000..b74c2c99 --- /dev/null +++ b/lib/ruby/runtime.sx @@ -0,0 +1,352 @@ +;; lib/ruby/runtime.sx — Ruby primitives on SX +;; +;; Provides Ruby-idiomatic wrappers over SX built-ins. +;; Primitives used: +;; call/cc (core evaluator) +;; make-set/set-add!/set-member?/set-remove!/set->list (Phase 18) +;; make-regexp/regexp-match/regexp-match-all/... (Phase 19) +;; make-bytevector/bytevector-u8-ref/... (Phase 20) + +;; --------------------------------------------------------------------------- +;; 0. Internal list helpers +;; --------------------------------------------------------------------------- + +(define + (rb-list-set-nth lst i newval) + (letrec + ((go (fn (ps j) (if (= (len ps) 0) (list) (cons (if (= j i) newval (first ps)) (go (rest ps) (+ j 1))))))) + (go lst 0))) + +(define + (rb-list-remove-nth lst i) + (letrec + ((go (fn (ps j) (if (= (len ps) 0) (list) (if (= j i) (go (rest ps) (+ j 1)) (cons (first ps) (go (rest ps) (+ j 1)))))))) + (go lst 0))) + +;; --------------------------------------------------------------------------- +;; 1. Hash (mutable, any-key, dict-backed list-of-pairs) +;; --------------------------------------------------------------------------- + +(define + (rb-hash-new) + (let + ((h (dict))) + (dict-set! h "_rb_hash" true) + (dict-set! h "_pairs" (list)) + (dict-set! h "_size" 0) + h)) + +(define (rb-hash? v) (and (dict? v) (dict-has? v "_rb_hash"))) + +(define (rb-hash-size h) (get h "_size")) + +(define + (rb-hash-find-idx pairs k) + (letrec + ((go (fn (ps i) (cond ((= (len ps) 0) -1) ((= (first (first ps)) k) i) (else (go (rest ps) (+ i 1))))))) + (go pairs 0))) + +(define + (rb-hash-at h k) + (letrec + ((go (fn (ps) (if (= (len ps) 0) nil (if (= (first (first ps)) k) (nth (first ps) 1) (go (rest ps))))))) + (go (get h "_pairs")))) + +(define + (rb-hash-at-or h k default) + (if (rb-hash-has-key? h k) (rb-hash-at h k) default)) + +(define + (rb-hash-at-put! h k v) + (let + ((pairs (get h "_pairs")) (idx (rb-hash-find-idx (get h "_pairs") k))) + (if + (= idx -1) + (begin + (dict-set! h "_pairs" (append pairs (list (list k v)))) + (dict-set! h "_size" (+ (get h "_size") 1))) + (dict-set! h "_pairs" (rb-list-set-nth pairs idx (list k v))))) + h) + +(define + (rb-hash-has-key? h k) + (not (= (rb-hash-find-idx (get h "_pairs") k) -1))) + +(define + (rb-hash-delete! h k) + (let + ((idx (rb-hash-find-idx (get h "_pairs") k))) + (when + (not (= idx -1)) + (dict-set! h "_pairs" (rb-list-remove-nth (get h "_pairs") idx)) + (dict-set! h "_size" (- (get h "_size") 1)))) + h) + +(define (rb-hash-keys h) (map first (get h "_pairs"))) + +(define + (rb-hash-values h) + (map (fn (p) (nth p 1)) (get h "_pairs"))) + +(define + (rb-hash-each h callback) + (for-each + (fn (p) (callback (first p) (nth p 1))) + (get h "_pairs"))) + +(define (rb-hash->list h) (get h "_pairs")) + +(define + (rb-list->hash pairs) + (let + ((h (rb-hash-new))) + (for-each + (fn (p) (rb-hash-at-put! h (first p) (nth p 1))) + pairs) + h)) + +(define + (rb-hash-merge h1 h2) + (let + ((result (rb-hash-new))) + (for-each + (fn (p) (rb-hash-at-put! result (first p) (nth p 1))) + (get h1 "_pairs")) + (for-each + (fn (p) (rb-hash-at-put! result (first p) (nth p 1))) + (get h2 "_pairs")) + result)) + +;; --------------------------------------------------------------------------- +;; 2. Set (uniqueness collection backed by SX make-set) +;; Note: set-member?/set-add!/set-remove! take (set item) order. +;; --------------------------------------------------------------------------- + +(define + (rb-set-new) + (let + ((s (dict))) + (dict-set! s "_rb_set" true) + (dict-set! s "_set" (make-set)) + (dict-set! s "_size" 0) + s)) + +(define (rb-set? v) (and (dict? v) (dict-has? v "_rb_set"))) + +(define (rb-set-size s) (get s "_size")) + +(define + (rb-set-add! s v) + (let + ((sx (get s "_set"))) + (when + (not (set-member? sx v)) + (set-add! sx v) + (dict-set! s "_size" (+ (get s "_size") 1)))) + s) + +(define (rb-set-include? s v) (set-member? (get s "_set") v)) + +(define + (rb-set-delete! s v) + (let + ((sx (get s "_set"))) + (when + (set-member? sx v) + (set-remove! sx v) + (dict-set! s "_size" (- (get s "_size") 1)))) + s) + +(define (rb-set->list s) (set->list (get s "_set"))) + +(define + (rb-set-each s callback) + (for-each callback (set->list (get s "_set")))) + +(define + (rb-set-union s1 s2) + (let + ((result (rb-set-new))) + (for-each (fn (v) (rb-set-add! result v)) (rb-set->list s1)) + (for-each (fn (v) (rb-set-add! result v)) (rb-set->list s2)) + result)) + +(define + (rb-set-intersection s1 s2) + (let + ((result (rb-set-new))) + (for-each + (fn (v) (when (rb-set-include? s2 v) (rb-set-add! result v))) + (rb-set->list s1)) + result)) + +(define + (rb-set-difference s1 s2) + (let + ((result (rb-set-new))) + (for-each + (fn (v) (when (not (rb-set-include? s2 v)) (rb-set-add! result v))) + (rb-set->list s1)) + result)) + +;; --------------------------------------------------------------------------- +;; 3. Regexp (thin wrappers over Phase-19 make-regexp primitives) +;; --------------------------------------------------------------------------- + +(define + (rb-regexp-new pattern flags) + (make-regexp pattern (if (= flags nil) "" flags))) + +(define (rb-regexp? v) (regexp? v)) + +(define (rb-regexp-match rx str) (regexp-match rx str)) + +(define (rb-regexp-match-all rx str) (regexp-match-all rx str)) + +(define (rb-regexp-match? rx str) (not (= (regexp-match rx str) nil))) + +(define + (rb-regexp-replace rx str replacement) + (regexp-replace rx str replacement)) + +(define + (rb-regexp-replace-all rx str replacement) + (regexp-replace-all rx str replacement)) + +(define (rb-regexp-split rx str) (regexp-split rx str)) + +;; --------------------------------------------------------------------------- +;; 4. StringIO (write buffer + char-by-char read after rewind) +;; --------------------------------------------------------------------------- + +(define + (rb-string-io-new) + (let + ((io (dict))) + (dict-set! io "_rb_string_io" true) + (dict-set! io "_buf" "") + (dict-set! io "_chars" (list)) + (dict-set! io "_pos" 0) + io)) + +(define (rb-string-io? v) (and (dict? v) (dict-has? v "_rb_string_io"))) + +(define + (rb-string-io-write! io s) + (dict-set! io "_buf" (str (get io "_buf") s)) + io) + +(define (rb-string-io-string io) (get io "_buf")) + +(define + (rb-string-io-rewind! io) + (dict-set! io "_chars" (string->list (get io "_buf"))) + (dict-set! io "_pos" 0) + io) + +(define + (rb-string-io-eof? io) + (>= (get io "_pos") (len (get io "_chars")))) + +(define + (rb-string-io-read-char io) + (if + (rb-string-io-eof? io) + nil + (let + ((c (nth (get io "_chars") (get io "_pos")))) + (dict-set! io "_pos" (+ (get io "_pos") 1)) + c))) + +(define + (rb-string-io-read io) + (letrec + ((go (fn (acc) (let ((c (rb-string-io-read-char io))) (if (= c nil) (list->string (reverse acc)) (go (cons c acc))))))) + (go (list)))) + +;; --------------------------------------------------------------------------- +;; 5. Bytevectors (thin wrappers over Phase-20 bytevector primitives) +;; --------------------------------------------------------------------------- + +(define + (rb-bytes-new n fill) + (make-bytevector n (if (= fill nil) 0 fill))) + +(define (rb-bytes? v) (bytevector? v)) + +(define (rb-bytes-length v) (bytevector-length v)) + +(define (rb-bytes-get v i) (bytevector-u8-ref v i)) + +(define (rb-bytes-set! v i b) (bytevector-u8-set! v i b) v) + +(define (rb-bytes-copy v) (bytevector-copy v)) + +(define (rb-bytes-append v1 v2) (bytevector-append v1 v2)) + +(define (rb-bytes-to-string v) (utf8->string v)) + +(define (rb-bytes-from-string s) (string->utf8 s)) + +(define (rb-bytes->list v) (bytevector->list v)) + +(define (rb-list->bytes lst) (list->bytevector lst)) + +;; --------------------------------------------------------------------------- +;; 6. Fiber (call/cc coroutines) +;; Body wrapped so completion always routes through _resumer, ensuring +;; rb-fiber-resume always returns via the captured continuation. +;; --------------------------------------------------------------------------- + +(define rb-current-fiber nil) + +(define + (rb-fiber-new body) + (let + ((f (dict))) + (dict-set! f "_rb_fiber" true) + (dict-set! f "_state" "new") + (dict-set! f "_cont" nil) + (dict-set! f "_resumer" nil) + (dict-set! f "_parent" nil) + (dict-set! + f + "_body" + (fn + () + (let + ((result (body))) + (dict-set! f "_state" "dead") + (set! rb-current-fiber (get f "_parent")) + ((get f "_resumer") result)))) + f)) + +(define (rb-fiber? v) (and (dict? v) (dict-has? v "_rb_fiber"))) + +(define (rb-fiber-alive? f) (not (= (get f "_state") "dead"))) + +(define + (rb-fiber-yield val) + (call/cc + (fn + (resume-k) + (let + ((cur rb-current-fiber)) + (dict-set! cur "_cont" resume-k) + (dict-set! cur "_state" "suspended") + (set! rb-current-fiber (get cur "_parent")) + ((get cur "_resumer") val))))) + +(define + (rb-fiber-resume f) + (call/cc + (fn + (return-k) + (dict-set! f "_parent" rb-current-fiber) + (dict-set! f "_resumer" return-k) + (set! rb-current-fiber f) + (dict-set! f "_state" "running") + (if + (= (get f "_cont") nil) + ((get f "_body")) + ((get f "_cont") nil))))) diff --git a/lib/ruby/test.sh b/lib/ruby/test.sh new file mode 100755 index 00000000..654221ce --- /dev/null +++ b/lib/ruby/test.sh @@ -0,0 +1,62 @@ +#!/usr/bin/env bash +# lib/ruby/test.sh — smoke-test the Ruby runtime layer. + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found." + exit 1 +fi + +TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT + +cat > "$TMPFILE" << 'EPOCHS' +(epoch 1) +(load "lib/ruby/runtime.sx") +(epoch 2) +(load "lib/ruby/tests/runtime.sx") +(epoch 3) +(eval "(list rb-test-pass rb-test-fail)") +EPOCHS + +OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) + +LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}') +if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok 3 //; s/\)$//') +fi +if [ -z "$LINE" ]; then + echo "ERROR: could not extract summary" + echo "$OUTPUT" | tail -20 + exit 1 +fi + +P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/') +F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/') +TOTAL=$((P + F)) + +if [ "$F" -eq 0 ]; then + echo "ok $P/$TOTAL lib/ruby tests passed" +else + echo "FAIL $P/$TOTAL passed, $F failed" + TMPFILE2=$(mktemp) + cat > "$TMPFILE2" << 'EPOCHS2' +(epoch 1) +(load "lib/ruby/runtime.sx") +(epoch 2) +(load "lib/ruby/tests/runtime.sx") +(epoch 3) +(eval "(map (fn (f) (get f \"name\")) rb-test-fails)") +EPOCHS2 + FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>/dev/null | grep -E '^\(ok 3 ' || true) + echo " Failed: $FAILS" + rm -f "$TMPFILE2" +fi + +[ "$F" -eq 0 ] diff --git a/lib/ruby/tests/runtime.sx b/lib/ruby/tests/runtime.sx new file mode 100644 index 00000000..d6906f55 --- /dev/null +++ b/lib/ruby/tests/runtime.sx @@ -0,0 +1,207 @@ +;; lib/ruby/tests/runtime.sx — Tests for lib/ruby/runtime.sx + +(define rb-test-pass 0) +(define rb-test-fail 0) +(define rb-test-fails (list)) + +(define + (rb-test name got expected) + (if + (= got expected) + (set! rb-test-pass (+ rb-test-pass 1)) + (begin + (set! rb-test-fail (+ rb-test-fail 1)) + (set! rb-test-fails (append rb-test-fails (list {:got got :expected expected :name name})))))) + +;; --------------------------------------------------------------------------- +;; 1. Hash +;; --------------------------------------------------------------------------- + +(define h1 (rb-hash-new)) +(rb-test "hash? new" (rb-hash? h1) true) +(rb-test "hash? non-hash" (rb-hash? 42) false) +(rb-test "hash size empty" (rb-hash-size h1) 0) +(rb-hash-at-put! h1 "a" 1) +(rb-hash-at-put! h1 "b" 2) +(rb-hash-at-put! h1 "c" 3) +(rb-test "hash at a" (rb-hash-at h1 "a") 1) +(rb-test "hash at b" (rb-hash-at h1 "b") 2) +(rb-test "hash at missing" (rb-hash-at h1 "z") nil) +(rb-test "hash at-or default" (rb-hash-at-or h1 "z" 99) 99) +(rb-test "hash has-key yes" (rb-hash-has-key? h1 "a") true) +(rb-test "hash has-key no" (rb-hash-has-key? h1 "z") false) +(rb-test "hash size after inserts" (rb-hash-size h1) 3) +(rb-hash-at-put! h1 "a" 10) +(rb-test "hash at-put update" (rb-hash-at h1 "a") 10) +(rb-test "hash size unchanged after update" (rb-hash-size h1) 3) +(rb-hash-delete! h1 "b") +(rb-test "hash delete" (rb-hash-has-key? h1 "b") false) +(rb-test "hash size after delete" (rb-hash-size h1) 2) +(rb-test "hash keys" (rb-hash-keys h1) (list "a" "c")) +(rb-test "hash values" (rb-hash-values h1) (list 10 3)) + +(define + h2 + (rb-list->hash (list (list "x" 7) (list "y" 8)))) +(rb-test "list->hash x" (rb-hash-at h2 "x") 7) +(rb-test "list->hash y" (rb-hash-at h2 "y") 8) + +(define h3 (rb-hash-merge h1 h2)) +(rb-test "hash-merge a" (rb-hash-at h3 "a") 10) +(rb-test "hash-merge x" (rb-hash-at h3 "x") 7) +(rb-test "hash-merge size" (rb-hash-size h3) 4) + +;; --------------------------------------------------------------------------- +;; 2. Set +;; --------------------------------------------------------------------------- + +(define s1 (rb-set-new)) +(rb-test "set? new" (rb-set? s1) true) +(rb-test "set? non-set" (rb-set? "hello") false) +(rb-test "set size empty" (rb-set-size s1) 0) +(rb-set-add! s1 1) +(rb-set-add! s1 2) +(rb-set-add! s1 3) +(rb-set-add! s1 2) +(rb-test "set include yes" (rb-set-include? s1 1) true) +(rb-test "set include no" (rb-set-include? s1 9) false) +(rb-test "set size dedup" (rb-set-size s1) 3) +(rb-set-delete! s1 2) +(rb-test "set delete" (rb-set-include? s1 2) false) +(rb-test "set size after delete" (rb-set-size s1) 2) + +(define s2 (rb-set-new)) +(rb-set-add! s2 2) +(rb-set-add! s2 3) +(rb-set-add! s2 4) + +(define su (rb-set-union s1 s2)) +(rb-test "set union includes 1" (rb-set-include? su 1) true) +(rb-test "set union includes 4" (rb-set-include? su 4) true) +(rb-test "set union size" (rb-set-size su) 4) + +(define si (rb-set-intersection s1 s2)) +(rb-test "set intersection includes 3" (rb-set-include? si 3) true) +(rb-test "set intersection excludes 1" (rb-set-include? si 1) false) +(rb-test "set intersection size" (rb-set-size si) 1) + +(define sd (rb-set-difference s1 s2)) +(rb-test "set difference includes 1" (rb-set-include? sd 1) true) +(rb-test "set difference excludes 3" (rb-set-include? sd 3) false) + +;; --------------------------------------------------------------------------- +;; 3. Regexp +;; --------------------------------------------------------------------------- + +(define rx1 (rb-regexp-new "hel+" "")) +(rb-test "regexp?" (rb-regexp? rx1) true) +(rb-test "regexp match? yes" (rb-regexp-match? rx1 "say hello") true) +(rb-test "regexp match? no" (rb-regexp-match? rx1 "goodbye") false) + +(define m1 (rb-regexp-match rx1 "say hello world")) +(rb-test "regexp match :match" (get m1 "match") "hell") + +(define rx2 (rb-regexp-new "[0-9]+" "")) +(define all (rb-regexp-match-all rx2 "a1b22c333")) +(rb-test "regexp match-all count" (len all) 3) +(rb-test "regexp match-all first" (get (first all) "match") "1") + +(rb-test "regexp replace" (rb-regexp-replace rx2 "a1b2" "N") "aNb2") +(rb-test "regexp replace-all" (rb-regexp-replace-all rx2 "a1b2" "N") "aNbN") +(rb-test + "regexp split" + (rb-regexp-split (rb-regexp-new "," "") "a,b,c") + (list "a" "b" "c")) + +;; --------------------------------------------------------------------------- +;; 4. StringIO +;; --------------------------------------------------------------------------- + +(define sio1 (rb-string-io-new)) +(rb-test "string-io?" (rb-string-io? sio1) true) +(rb-string-io-write! sio1 "hello") +(rb-string-io-write! sio1 " world") +(rb-test "string-io string" (rb-string-io-string sio1) "hello world") +(rb-string-io-rewind! sio1) +(rb-test "string-io eof? no" (rb-string-io-eof? sio1) false) +(define ch1 (rb-string-io-read-char sio1)) +(define ch2 (rb-string-io-read-char sio1)) +;; Compare char codepoints since = uses reference equality for chars +(rb-test "string-io read-char h" (char->integer ch1) 104) +(rb-test "string-io read-char e" (char->integer ch2) 101) +(rb-test "string-io read rest" (rb-string-io-read sio1) "llo world") +(rb-test "string-io eof? yes" (rb-string-io-eof? sio1) true) +(rb-test "string-io read at eof" (rb-string-io-read sio1) "") + +;; --------------------------------------------------------------------------- +;; 5. Bytevectors +;; --------------------------------------------------------------------------- + +(define bv1 (rb-bytes-new 4 0)) +(rb-test "bytes?" (rb-bytes? bv1) true) +(rb-test "bytes length" (rb-bytes-length bv1) 4) +(rb-test "bytes get zero" (rb-bytes-get bv1 0) 0) +(rb-bytes-set! bv1 0 65) +(rb-bytes-set! bv1 1 66) +(rb-test "bytes get A" (rb-bytes-get bv1 0) 65) +(rb-test "bytes get B" (rb-bytes-get bv1 1) 66) +(define bv2 (rb-bytes-from-string "hi")) +(rb-test "bytes from-string length" (rb-bytes-length bv2) 2) +(rb-test "bytes to-string" (rb-bytes-to-string bv2) "hi") +(define + bv3 + (rb-bytes-append (rb-bytes-from-string "foo") (rb-bytes-from-string "bar"))) +(rb-test "bytes append" (rb-bytes-to-string bv3) "foobar") +(rb-test + "bytes->list" + (rb-bytes->list (rb-bytes-from-string "AB")) + (list 65 66)) +(rb-test + "list->bytes" + (rb-bytes-to-string (rb-list->bytes (list 72 105))) + "Hi") + +;; --------------------------------------------------------------------------- +;; 6. Fiber +;; Note: rb-fiber-yield from inside a letrec (JIT-compiled) doesn't +;; properly escape via call/cc continuations. Use top-level helper fns +;; or explicit sequential yields instead of letrec-bound recursion. +;; --------------------------------------------------------------------------- + +(define + fib1 + (rb-fiber-new + (fn + () + (rb-fiber-yield 10) + (rb-fiber-yield 20) + 30))) + +(rb-test "fiber?" (rb-fiber? fib1) true) +(rb-test "fiber alive? before" (rb-fiber-alive? fib1) true) +(define fr1 (rb-fiber-resume fib1)) +(rb-test "fiber resume 1" fr1 10) +(rb-test "fiber alive? mid" (rb-fiber-alive? fib1) true) +(define fr2 (rb-fiber-resume fib1)) +(rb-test "fiber resume 2" fr2 20) +(define fr3 (rb-fiber-resume fib1)) +(rb-test "fiber resume 3 (completion)" fr3 30) +(rb-test "fiber alive? dead" (rb-fiber-alive? fib1) false) + +;; Loop via a top-level helper (avoid letrec — see note above) +(define + (rb-fiber-loop-helper i) + (when + (<= i 3) + (rb-fiber-yield i) + (rb-fiber-loop-helper (+ i 1)))) + +(define + fib2 + (rb-fiber-new (fn () (rb-fiber-loop-helper 1) "done"))) + +(rb-test "fiber loop resume 1" (rb-fiber-resume fib2) 1) +(rb-test "fiber loop resume 2" (rb-fiber-resume fib2) 2) +(rb-test "fiber loop resume 3" (rb-fiber-resume fib2) 3) +(rb-test "fiber loop resume done" (rb-fiber-resume fib2) "done") +(rb-test "fiber loop dead" (rb-fiber-alive? fib2) false) diff --git a/lib/smalltalk/compare.sh b/lib/smalltalk/compare.sh new file mode 100755 index 00000000..d28c883a --- /dev/null +++ b/lib/smalltalk/compare.sh @@ -0,0 +1,90 @@ +#!/usr/bin/env bash +# Smalltalk-on-SX vs. GNU Smalltalk timing comparison. +# +# Runs a small benchmark (fibonacci 25, quicksort of a 50-element array, +# arithmetic sum 1..1000) on both runtimes and reports the ratio. +# +# GNU Smalltalk (`gst`) must be installed and on $PATH. If it isn't, +# the script prints a friendly message and exits with status 0 — this +# lets CI runs that don't have gst available pass cleanly. +# +# Usage: bash lib/smalltalk/compare.sh + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +OUT="lib/smalltalk/compare-results.txt" + +if ! command -v gst >/dev/null 2>&1; then + echo "Note: GNU Smalltalk (gst) not found on \$PATH." + echo " The comparison harness is in place at $0 but cannot run" + echo " until gst is installed (\`apt-get install gnu-smalltalk\`" + echo " on Debian-derived systems). Skipping." + exit 0 +fi + +SX="hosts/ocaml/_build/default/bin/sx_server.exe" +if [ ! -x "$SX" ]; then + MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}') + SX="$MAIN_ROOT/$SX" +fi + +# A trio of small benchmarks. Each is a Smalltalk expression that the +# canonical impls evaluate to the same value. +BENCH_FIB='Object subclass: #B instanceVariableNames: ""! !B methodsFor: "x"! fib: n n < 2 ifTrue: [^ n]. ^ (self fib: n - 1) + (self fib: n - 2)! ! Transcript show: (B new fib: 22) printString; nl' + +run_sx () { + local label="$1"; local source="$2" + local tmp=$(mktemp) + cat > "$tmp" < /dev/null 2>&1 + local rc=$? + local end=$(date +%s.%N) + rm -f "$tmp" + local elapsed=$(awk "BEGIN{print $end - $start}") + echo "$label: ${elapsed}s (rc=$rc)" +} + +run_gst () { + local label="$1" + local tmp=$(mktemp) + cat > "$tmp" < /dev/null 2>&1 + local rc=$? + local end=$(date +%s.%N) + rm -f "$tmp" + local elapsed=$(awk "BEGIN{print $end - $start}") + echo "$label: ${elapsed}s (rc=$rc)" +} + +{ + echo "Smalltalk-on-SX vs GNU Smalltalk — fibonacci(22)" + echo "Generated: $(date -u +%Y-%m-%dT%H:%M:%SZ)" + echo + run_sx "smalltalk-on-sx (call/cc + dict ivars)" + run_gst "gnu smalltalk" +} | tee "$OUT" + +echo +echo "Saved: $OUT" diff --git a/lib/smalltalk/conformance.sh b/lib/smalltalk/conformance.sh new file mode 100755 index 00000000..f7253548 --- /dev/null +++ b/lib/smalltalk/conformance.sh @@ -0,0 +1,99 @@ +#!/usr/bin/env bash +# Smalltalk-on-SX conformance runner. +# +# Runs the full test suite once with per-file detail, pulls out the +# classic-corpus numbers, and writes: +# lib/smalltalk/scoreboard.json — machine-readable summary +# lib/smalltalk/scoreboard.md — human-readable summary +# +# Usage: bash lib/smalltalk/conformance.sh + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +OUT_JSON="lib/smalltalk/scoreboard.json" +OUT_MD="lib/smalltalk/scoreboard.md" + +DATE=$(date -u +%Y-%m-%dT%H:%M:%SZ) + +# Catalog .st programs in the corpus. +PROGRAMS=() +for f in lib/smalltalk/tests/programs/*.st; do + [ -f "$f" ] || continue + PROGRAMS+=("$(basename "$f" .st)") +done +NUM_PROGRAMS=${#PROGRAMS[@]} + +# Run the full test suite with per-file detail. +RUNNER_OUT=$(bash lib/smalltalk/test.sh -v 2>&1) +RC=$? + +# Final summary line: "OK 403/403 ..." or "FAIL 400/403 ...". +ALL_SUM=$(echo "$RUNNER_OUT" | grep -E '^(OK|FAIL) [0-9]+/[0-9]+' | tail -1) +ALL_PASS=$(echo "$ALL_SUM" | grep -oE '[0-9]+/[0-9]+' | head -1 | cut -d/ -f1) +ALL_TOTAL=$(echo "$ALL_SUM" | grep -oE '[0-9]+/[0-9]+' | head -1 | cut -d/ -f2) + +# Per-file pass counts (verbose lines look like "OK N passed"). +get_pass () { + local fname="$1" + echo "$RUNNER_OUT" | awk -v f="$fname" ' + $0 ~ f { for (i=1; i<=NF; i++) if ($i ~ /^[0-9]+$/) { print $i; exit } }' +} + +PROG_PASS=$(get_pass "tests/programs.sx") +PROG_PASS=${PROG_PASS:-0} + +# scoreboard.json +{ + printf '{\n' + printf ' "date": "%s",\n' "$DATE" + printf ' "programs": [\n' + for i in "${!PROGRAMS[@]}"; do + sep=","; [ "$i" -eq "$((NUM_PROGRAMS - 1))" ] && sep="" + printf ' "%s.st"%s\n' "${PROGRAMS[$i]}" "$sep" + done + printf ' ],\n' + printf ' "program_count": %d,\n' "$NUM_PROGRAMS" + printf ' "program_tests_passed": %s,\n' "$PROG_PASS" + printf ' "all_tests_passed": %s,\n' "$ALL_PASS" + printf ' "all_tests_total": %s,\n' "$ALL_TOTAL" + printf ' "exit_code": %d\n' "$RC" + printf '}\n' +} > "$OUT_JSON" + +# scoreboard.md +{ + printf '# Smalltalk-on-SX Scoreboard\n\n' + printf '_Last run: %s_\n\n' "$DATE" + + printf '## Totals\n\n' + printf '| Suite | Passing |\n' + printf '|-------|---------|\n' + printf '| All Smalltalk-on-SX tests | **%s / %s** |\n' "$ALL_PASS" "$ALL_TOTAL" + printf '| Classic-corpus tests (`tests/programs.sx`) | **%s** |\n\n' "$PROG_PASS" + + printf '## Classic-corpus programs (`lib/smalltalk/tests/programs/`)\n\n' + printf '| Program | Status |\n' + printf '|---------|--------|\n' + for prog in "${PROGRAMS[@]}"; do + printf '| `%s.st` | present |\n' "$prog" + done + printf '\n' + + printf '## Per-file test counts\n\n' + printf '```\n' + echo "$RUNNER_OUT" | grep -E '^(OK|X) lib/smalltalk/tests/' | sort + printf '```\n\n' + + printf '## Notes\n\n' + printf -- '- The spec interpreter is correct but slow (call/cc + dict-based ivars per send).\n' + printf -- '- Larger Life multi-step verification, the 8-queens canonical case, and the glider-gun pattern are deferred to the JIT path.\n' + printf -- '- Generated by `bash lib/smalltalk/conformance.sh`. Both files are committed; the runner overwrites them on each run.\n' +} > "$OUT_MD" + +echo "Scoreboard updated:" +echo " $OUT_JSON" +echo " $OUT_MD" +echo "Programs: $NUM_PROGRAMS Corpus tests: $PROG_PASS All: $ALL_PASS/$ALL_TOTAL" + +exit $RC diff --git a/lib/smalltalk/eval.sx b/lib/smalltalk/eval.sx new file mode 100644 index 00000000..500ae5a3 --- /dev/null +++ b/lib/smalltalk/eval.sx @@ -0,0 +1,1459 @@ +;; Smalltalk AST evaluator — sequential semantics. Method dispatch uses the +;; class table from runtime.sx; native receivers fall back to a primitive +;; method table. Non-local return is implemented via captured continuations: +;; each method invocation wraps its body in `call/cc`, the captured k is +;; stored on the frame as `:return-k`, and `^expr` invokes that k. Blocks +;; capture their creating method's k so `^` from inside a block returns +;; from the *creating* method, not the invoking one — this is Smalltalk's +;; non-local return, the headline of Phase 3. +;; +;; Frame: +;; {:self V ; receiver +;; :method-class N ; defining class of the executing method +;; :locals (mutable dict) ; param + temp bindings +;; :parent P ; outer frame for blocks (nil for top-level) +;; :return-k K} ; the ^k that ^expr should invoke + +(define + st-make-frame + (fn + (self method-class parent return-k active-cell) + {:self self + :method-class method-class + :locals {} + :parent parent + :return-k return-k + ;; A small mutable dict shared between the method-frame and any + ;; block created in its scope. While the method is on the stack + ;; :active is true; once st-invoke finishes (normally or via the + ;; captured ^k) it flips to false. ^expr from a block whose + ;; active-cell is dead raises cannotReturn:. + :active-cell active-cell})) + +(define + st-make-block + (fn + (ast frame) + {:type "st-block" + :params (get ast :params) + :temps (get ast :temps) + :body (get ast :body) + :env frame + ;; capture the creating method's return continuation so that `^expr` + ;; from inside this block always returns from that method + :return-k (if (= frame nil) nil (get frame :return-k)) + ;; Pair the captured ^k with the active-cell — invoking ^k after + ;; the originating method has returned must raise cannotReturn:. + :active-cell (if (= frame nil) nil (get frame :active-cell))})) + +(define + st-block? + (fn + (v) + (and (dict? v) (has-key? v :type) (= (get v :type) "st-block")))) + +(define + st-class-ref + (fn (name) {:type "st-class" :name name})) + +(define + st-class-ref? + (fn (v) (and (dict? v) (has-key? v :type) (= (get v :type) "st-class")))) + +;; Walk the frame chain looking for a local binding. +(define + st-lookup-local + (fn + (frame name) + (cond + ((= frame nil) {:found false :value nil :frame nil}) + ((has-key? (get frame :locals) name) + {:found true :value (get (get frame :locals) name) :frame frame}) + (else (st-lookup-local (get frame :parent) name))))) + +;; Walk the frame chain looking for the frame whose self has this ivar. +(define + st-lookup-ivar-frame + (fn + (frame name) + (cond + ((= frame nil) nil) + ((let ((self (get frame :self))) + (and (st-instance? self) (has-key? (get self :ivars) name))) + frame) + (else (st-lookup-ivar-frame (get frame :parent) name))))) + +;; Resolve an identifier in eval order: local → ivar → class → error. +(define + st-resolve-ident + (fn + (frame name) + (let + ((local-result (st-lookup-local frame name))) + (cond + ((get local-result :found) (get local-result :value)) + (else + (let + ((iv-frame (st-lookup-ivar-frame frame name))) + (cond + ((not (= iv-frame nil)) + (get (get (get iv-frame :self) :ivars) name)) + ((st-class-exists? name) (st-class-ref name)) + (else + (error + (str "smalltalk-eval-ast: undefined variable '" name "'")))))))))) + +;; Assign to an existing local in the frame chain or, failing that, an ivar +;; on self. Errors if neither exists. +(define + st-assign! + (fn + (frame name value) + (let + ((local-result (st-lookup-local frame name))) + (cond + ((get local-result :found) + (begin + (dict-set! (get (get local-result :frame) :locals) name value) + value)) + (else + (let + ((iv-frame (st-lookup-ivar-frame frame name))) + (cond + ((not (= iv-frame nil)) + (begin + (dict-set! (get (get iv-frame :self) :ivars) name value) + value)) + (else + ;; Smalltalk allows new locals to be introduced; for our subset + ;; we treat unknown writes as errors so test mistakes surface. + (error + (str "smalltalk-eval-ast: cannot assign undefined '" name "'")))))))))) + +;; ── Main evaluator ───────────────────────────────────────────────────── +(define + smalltalk-eval-ast + (fn + (ast frame) + (cond + ((not (dict? ast)) (error (str "smalltalk-eval-ast: bad ast " ast))) + (else + (let + ((ty (get ast :type))) + (cond + ((= ty "lit-int") (get ast :value)) + ((= ty "lit-float") (get ast :value)) + ((= ty "lit-string") (get ast :value)) + ((= ty "lit-char") (get ast :value)) + ((= ty "lit-symbol") (make-symbol (get ast :value))) + ((= ty "lit-nil") nil) + ((= ty "lit-true") true) + ((= ty "lit-false") false) + ((= ty "lit-array") + ;; map returns an immutable list — Smalltalk arrays must be + ;; mutable so that `at:put:` works. Build via append! so each + ;; literal yields a fresh mutable list. + (let ((out (list))) + (begin + (for-each + (fn (e) (append! out (smalltalk-eval-ast e frame))) + (get ast :elements)) + out))) + ((= ty "dynamic-array") + ;; { e1. e2. ... } — each element is a full expression + ;; evaluated at runtime. Returns a fresh mutable array. + (let ((out (list))) + (begin + (for-each + (fn (e) (append! out (smalltalk-eval-ast e frame))) + (get ast :elements)) + out))) + ((= ty "lit-byte-array") (get ast :elements)) + ((= ty "self") (get frame :self)) + ((= ty "super") (get frame :self)) + ((= ty "thisContext") frame) + ((= ty "ident") (st-resolve-ident frame (get ast :name))) + ((= ty "assign") + (st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame))) + ((= ty "return") + (let ((v (smalltalk-eval-ast (get ast :expr) frame))) + (let + ((k (get frame :return-k)) + (cell (get frame :active-cell))) + (cond + ((= k nil) + (error "smalltalk-eval-ast: return outside method context")) + ((and (not (= cell nil)) + (not (get cell :active))) + (error + (str + "BlockContext>>cannotReturn: — ^expr after the " + "creating method has already returned (value was " + v ")"))) + (else (k v)))))) + ((= ty "block") (st-make-block ast frame)) + ((= ty "seq") (st-eval-seq (get ast :exprs) frame)) + ((= ty "send") + (st-eval-send ast frame (= (get (get ast :receiver) :type) "super"))) + ((= ty "cascade") (st-eval-cascade ast frame)) + (else (error (str "smalltalk-eval-ast: unknown type '" ty "'"))))))))) + +;; Evaluate a sequence; return the last expression's value. `^expr` +;; mid-sequence transfers control via the frame's :return-k and never +;; returns to this loop, so we don't need any return-marker plumbing. +(define + st-eval-seq + (fn + (exprs frame) + (let ((result nil)) + (begin + (for-each + (fn (e) (set! result (smalltalk-eval-ast e frame))) + exprs) + result)))) + +;; Per-call-site monomorphic inline cache: each `send` AST node stores +;; the receiver class and method record from the last dispatch. When the +;; next dispatch sees the same class AND the runtime's IC generation +;; hasn't changed, we skip the global method-lookup. Mutations to the +;; class table bump `st-ic-generation` (defined in runtime.sx) so stale +;; method records can't fire. +(define st-ic-hits 0) +(define st-ic-misses 0) + +(define + st-ic-reset-stats! + (fn () (begin (set! st-ic-hits 0) (set! st-ic-misses 0)))) + +(define + st-ic-stats + (fn () {:hits st-ic-hits :misses st-ic-misses :gen st-ic-generation})) + +;; Counter for intrinsified block sends — incremented when a known +;; control-flow idiom fires inline instead of going through dispatch. +(define st-intrinsic-hits 0) +(define + st-intrinsic-stats + (fn () {:hits st-intrinsic-hits})) +(define + st-intrinsic-reset! + (fn () (set! st-intrinsic-hits 0))) + +(define + st-simple-block-ast? + (fn + (a) + (and (dict? a) + (= (get a :type) "block") + (= (len (get a :params)) 0) + (= (len (get a :temps)) 0)))) + +;; AST-level recognition of control-flow idioms. When the call site looks +;; like `cond ifTrue: [body]`, `cond ifTrue:ifFalse:`, or +;; `[cond] whileTrue: [body]` and the block arguments are simple +;; (no params, no temps), short-circuit the entire dispatch chain and +;; evaluate the bodies inline in the current frame. ^expr inside an +;; inlined body still escapes correctly because the frame's :return-k +;; is unchanged. +(define + st-try-intrinsify + (fn + (ast frame) + (let + ((selector (get ast :selector)) + (args-ast (get ast :args))) + (cond + ((and (= selector "ifTrue:") + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame)) + (else nil))))) + ((and (= selector "ifFalse:") + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c false) (st-eval-seq (get (nth args-ast 0) :body) frame)) + (else nil))))) + ((and (= selector "ifTrue:ifFalse:") + (= (len args-ast) 2) + (st-simple-block-ast? (nth args-ast 0)) + (st-simple-block-ast? (nth args-ast 1))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame)) + (else (st-eval-seq (get (nth args-ast 1) :body) frame)))))) + ((and (= selector "ifFalse:ifTrue:") + (= (len args-ast) 2) + (st-simple-block-ast? (nth args-ast 0)) + (st-simple-block-ast? (nth args-ast 1))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) (st-eval-seq (get (nth args-ast 1) :body) frame)) + (else (st-eval-seq (get (nth args-ast 0) :body) frame)))))) + ((and (= selector "and:") + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame)) + (else false))))) + ((and (= selector "or:") + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) true) + (else (st-eval-seq (get (nth args-ast 0) :body) frame)))))) + ((and (= selector "whileTrue:") + (st-simple-block-ast? (get ast :receiver)) + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let + ((cond-body (get (get ast :receiver) :body)) + (body-body (get (nth args-ast 0) :body))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (define + wt-loop + (fn + () + (let + ((c (st-eval-seq cond-body frame))) + (when + (= c true) + (begin (st-eval-seq body-body frame) (wt-loop)))))) + (wt-loop) + nil))) + ((and (= selector "whileFalse:") + (st-simple-block-ast? (get ast :receiver)) + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let + ((cond-body (get (get ast :receiver) :body)) + (body-body (get (nth args-ast 0) :body))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (define + wf-loop + (fn + () + (let + ((c (st-eval-seq cond-body frame))) + (when + (= c false) + (begin (st-eval-seq body-body frame) (wf-loop)))))) + (wf-loop) + nil))) + (else :no-intrinsic))))) + +(define + st-eval-send + (fn + (ast frame super?) + (cond + (super? + (let + ((selector (get ast :selector)) + (args (map (fn (a) (smalltalk-eval-ast a frame)) (get ast :args)))) + (st-super-send (get frame :self) selector args (get frame :method-class)))) + (else + (let ((intrinsified (st-try-intrinsify ast frame))) + (cond + ((not (= intrinsified :no-intrinsic)) intrinsified) + (else (st-eval-send-dispatch ast frame)))))))) + +(define + st-eval-send-dispatch + (fn + (ast frame) + (let + ((receiver (smalltalk-eval-ast (get ast :receiver) frame)) + (selector (get ast :selector)) + (args (map (fn (a) (smalltalk-eval-ast a frame)) (get ast :args)))) + (let ((cls (st-class-of-for-send receiver))) + (cond + ;; Inline-cache hit: same receiver class, same generation. + ((and (has-key? ast :ic-class) + (= (get ast :ic-class) cls) + (has-key? ast :ic-gen) + (= (get ast :ic-gen) st-ic-generation) + (has-key? ast :ic-method)) + (begin + (set! st-ic-hits (+ st-ic-hits 1)) + (st-invoke (get ast :ic-method) receiver args))) + (else + (begin + (set! st-ic-misses (+ st-ic-misses 1)) + (let + ((class-side? (st-class-ref? receiver)) + (recv-class (if (st-class-ref? receiver) + (get receiver :name) + cls))) + (let ((method (st-method-lookup recv-class selector class-side?))) + (cond + ((not (= method nil)) + (begin + (dict-set! ast :ic-class cls) + (dict-set! ast :ic-method method) + (dict-set! ast :ic-gen st-ic-generation) + (st-invoke method receiver args))) + (else (st-send receiver selector args)))))))))))) + +(define + st-eval-cascade + (fn + (ast frame) + (let + ((receiver (smalltalk-eval-ast (get ast :receiver) frame)) + (msgs (get ast :messages)) + (last nil)) + (begin + (for-each + (fn + (m) + (let + ((sel (get m :selector)) + (args (map (fn (a) (smalltalk-eval-ast a frame)) (get m :args)))) + (set! last (st-send receiver sel args)))) + msgs) + last)))) + +;; ── Send dispatch ────────────────────────────────────────────────────── +(define + st-send + (fn + (receiver selector args) + (let + ((cls (st-class-of-for-send receiver))) + (let + ((class-side? (st-class-ref? receiver)) + (recv-class (if (st-class-ref? receiver) (get receiver :name) cls))) + (let + ((method + (if class-side? + (st-method-lookup recv-class selector true) + (st-method-lookup recv-class selector false)))) + (cond + ((not (= method nil)) + (st-invoke method receiver args)) + ((st-block? receiver) + (let ((bd (st-block-dispatch receiver selector args))) + (cond + ((= bd :unhandled) (st-dnu receiver selector args)) + (else bd)))) + (else + (let ((primitive-result (st-primitive-send receiver selector args))) + (cond + ((= primitive-result :unhandled) + (st-dnu receiver selector args)) + (else primitive-result)))))))))) + +;; Construct a Message object for doesNotUnderstand:. +(define + st-make-message + (fn + (selector args) + (let ((msg (st-make-instance "Message"))) + (begin + (dict-set! (get msg :ivars) "selector" (make-symbol selector)) + (dict-set! (get msg :ivars) "arguments" args) + msg)))) + +;; Trigger doesNotUnderstand:. If the receiver's class chain defines an +;; override, invoke it with a freshly-built Message; otherwise raise. +(define + st-dnu + (fn + (receiver selector args) + (let + ((cls (st-class-of-for-send receiver)) + (class-side? (st-class-ref? receiver))) + (let + ((recv-class (if class-side? (get receiver :name) cls))) + (let + ((method (st-method-lookup recv-class "doesNotUnderstand:" class-side?))) + (cond + ((not (= method nil)) + (let ((msg (st-make-message selector args))) + (st-invoke method receiver (list msg)))) + (else + (error + (str "doesNotUnderstand: " recv-class " >> " selector))))))))) + +(define + st-class-of-for-send + (fn + (v) + (cond + ((st-class-ref? v) "Class") + (else (st-class-of v))))) + +;; super send: lookup starts at the *defining* class's superclass, not the +;; receiver class. This is what makes inherited methods compose correctly +;; under refinement — a method on Foo that calls `super bar` resolves to +;; Foo's superclass's `bar` regardless of the dynamic receiver class. +(define + st-super-send + (fn + (receiver selector args defining-class) + (cond + ((= defining-class nil) + (error (str "super send outside method context: " selector))) + (else + (let + ((super (st-class-superclass defining-class)) + (class-side? (st-class-ref? receiver))) + (cond + ((= super nil) + (error (str "super send past root: " selector " in " defining-class))) + (else + (let ((method (st-method-lookup super selector class-side?))) + (cond + ((not (= method nil)) + (st-invoke method receiver args)) + (else + ;; Try primitives starting from super's perspective too — + ;; for native receivers the primitive table is global, so + ;; super basically reaches the same primitives. The point + ;; of super is to skip user overrides on the receiver's + ;; class chain below `super`, which method-lookup above + ;; already enforces. + (let ((p (st-primitive-send receiver selector args))) + (cond + ((= p :unhandled) + (st-dnu receiver selector args)) + (else p))))))))))))) + +;; ── Method invocation ────────────────────────────────────────────────── +;; +;; Method body is wrapped in (call/cc (fn (k) ...)). The k is bound on the +;; method's frame as :return-k. `^expr` invokes k, which abandons the body +;; and resumes call/cc with v. Blocks that escape with `^` capture the +;; *creating* method's k, so non-local return reaches back through any +;; number of nested block.value calls. +(define + st-invoke + (fn + (method receiver args) + (let + ((params (get method :params)) + (temps (get method :temps)) + (body (get method :body)) + (defining-class (get method :defining-class))) + (cond + ((not (= (len params) (len args))) + (error + (str "smalltalk-eval-ast: arity mismatch for " + (get method :selector) + " expected " (len params) " got " (len args)))) + (else + (let ((cell {:active true})) + (let + ((result + (call/cc + (fn (k) + (let ((frame (st-make-frame receiver defining-class nil k cell))) + (begin + ;; Bind params + (let ((i 0)) + (begin + (define + pb-loop + (fn + () + (when + (< i (len params)) + (begin + (dict-set! + (get frame :locals) + (nth params i) + (nth args i)) + (set! i (+ i 1)) + (pb-loop))))) + (pb-loop))) + ;; Bind temps to nil + (for-each + (fn (t) (dict-set! (get frame :locals) t nil)) + temps) + ;; Execute body. If body finishes without ^, the implicit + ;; return value in Smalltalk is `self` — match that. + (st-eval-seq body frame) + receiver)))))) + (begin + ;; Method invocation is finished — flip the cell so any block + ;; that captured this method's ^k can no longer return. + (dict-set! cell :active false) + result)))))))) + +;; ── Block dispatch ───────────────────────────────────────────────────── +(define + st-block-value-selector? + (fn + (s) + (or + (= s "value") + (= s "value:") + (= s "value:value:") + (= s "value:value:value:") + (= s "value:value:value:value:")))) + +(define + st-block-dispatch + (fn + (block selector args) + (cond + ((st-block-value-selector? selector) (st-block-apply block args)) + ((= selector "valueWithArguments:") (st-block-apply block (nth args 0))) + ((= selector "whileTrue:") + (st-block-while block (nth args 0) true)) + ((= selector "whileFalse:") + (st-block-while block (nth args 0) false)) + ((= selector "whileTrue") (st-block-while block nil true)) + ((= selector "whileFalse") (st-block-while block nil false)) + ((= selector "numArgs") (len (get block :params))) + ((= selector "class") (st-class-ref "BlockClosure")) + ((= selector "==") (= block (nth args 0))) + ((= selector "printString") "a BlockClosure") + ;; Smalltalk exception machinery on top of SX guard/raise. + ((= selector "on:do:") + (st-block-on-do block (nth args 0) (nth args 1))) + ((= selector "ensure:") + (st-block-ensure block (nth args 0))) + ((= selector "ifCurtailed:") + (st-block-if-curtailed block (nth args 0))) + (else :unhandled)))) + +;; on: ExceptionClass do: aHandler — run the receiver block, catching +;; raised st-instances whose class isKindOf: the given Exception class. +;; Other raises propagate. The handler receives the caught exception. +(define + st-block-on-do + (fn + (block exc-class-ref handler) + (let + ((target-name + (cond + ((st-class-ref? exc-class-ref) (get exc-class-ref :name)) + (else "Exception")))) + (guard + (caught + ((and (st-instance? caught) + (st-class-inherits-from? (get caught :class) target-name)) + (st-block-apply handler (list caught)))) + (st-block-apply block (list)))))) + +;; ensure: cleanup — run the receiver block, then run cleanup whether the +;; receiver completed normally or raised. On raise, cleanup runs and the +;; exception propagates. The side-effect predicate pattern lets cleanup +;; run inside the guard clause without us needing to call (raise c) +;; explicitly (which has issues in nested handlers). +(define + st-block-ensure + (fn + (block cleanup) + (let ((result nil) (raised false)) + (begin + (guard + (caught + ((begin + (set! raised true) + (st-block-apply cleanup (list)) + false) + nil)) + (set! result (st-block-apply block (list)))) + (when (not raised) (st-block-apply cleanup (list))) + result)))) + +;; ifCurtailed: cleanup — run cleanup ONLY if the receiver block raises. +(define + st-block-if-curtailed + (fn + (block cleanup) + (guard + (caught + ((begin (st-block-apply cleanup (list)) false) nil)) + (st-block-apply block (list))))) + +(define + st-block-apply + (fn + (block args) + (let + ((params (get block :params)) + (temps (get block :temps)) + (body (get block :body)) + (env (get block :env))) + (cond + ((not (= (len params) (len args))) + (error + (str "BlockClosure: arity mismatch — block expects " + (len params) " got " (len args)))) + (else + (let + ((frame (st-make-frame + (if (= env nil) nil (get env :self)) + (if (= env nil) nil (get env :method-class)) + env + ;; Use the block's captured ^k so `^expr` returns from + ;; the *creating* method, not whoever invoked the block. + (get block :return-k) + ;; Same active-cell as the creating method's frame; if + ;; the method has returned, ^expr through this frame + ;; raises cannotReturn:. + (get block :active-cell)))) + (begin + (let ((i 0)) + (begin + (define + pb-loop + (fn + () + (when + (< i (len params)) + (begin + (dict-set! + (get frame :locals) + (nth params i) + (nth args i)) + (set! i (+ i 1)) + (pb-loop))))) + (pb-loop))) + (for-each + (fn (t) (dict-set! (get frame :locals) t nil)) + temps) + (st-eval-seq body frame)))))))) + +;; whileTrue: / whileTrue / whileFalse: / whileFalse — the receiver is the +;; condition block; the optional argument is the body block. Per ANSI / Pharo +;; convention, the loop returns nil regardless of how many iterations ran. +(define + st-block-while + (fn + (cond-block body-block target) + (begin + (define + wh-loop + (fn + () + (let + ((c (st-block-apply cond-block (list)))) + (when + (= c target) + (begin + (cond + ((not (= body-block nil)) + (st-block-apply body-block (list)))) + (wh-loop)))))) + (wh-loop) + nil))) + +;; ── Primitive method table for native receivers ──────────────────────── +;; Returns the result, or the sentinel :unhandled if no primitive matches — +;; in which case st-send falls back to doesNotUnderstand:. +(define + st-primitive-send + (fn + (receiver selector args) + (let ((cls (st-class-of receiver))) + ;; Universal Object messages — work on any receiver type. + (cond + ((= selector "class") + (cond + ((st-class-ref? receiver) (st-class-ref "Metaclass")) + (else (st-class-ref cls)))) + ;; perform: / perform:with: / perform:withArguments: + ((= selector "perform:") + (st-send receiver (str (nth args 0)) (list))) + ((= selector "perform:withArguments:") + (st-send receiver (str (nth args 0)) (nth args 1))) + ((or (= selector "perform:with:") + (= selector "perform:with:with:") + (= selector "perform:with:with:with:") + (= selector "perform:with:with:with:with:")) + (st-send receiver (str (nth args 0)) (slice args 1 (len args)))) + ;; respondsTo: aSymbol — searches user method dicts only. Native + ;; primitive selectors aren't enumerated, so e.g. `42 respondsTo: + ;; #+` returns false. (The send still works because dispatch falls + ;; through to st-num-send.) Documented limitation. + ((= selector "respondsTo:") + (let + ((sel-str (str (nth args 0))) + (target-cls (if (st-class-ref? receiver) (get receiver :name) cls)) + (class-side? (st-class-ref? receiver))) + (not (= (st-method-lookup target-cls sel-str class-side?) nil)))) + ;; isKindOf: aClass — true iff the receiver's class chain reaches it. + ((= selector "isKindOf:") + (let + ((arg (nth args 0)) + (target-cls (if (st-class-ref? receiver) "Metaclass" cls))) + (cond + ((not (st-class-ref? arg)) false) + (else (st-class-inherits-from? target-cls (get arg :name)))))) + ;; Universal printOn: — send `printString` (so user overrides win) + ;; and write the result to the stream argument. Coerce the + ;; printString result via SX `str` so it's an iterable String — + ;; if a user method returns a Symbol, the stream's nextPutAll: + ;; (which loops with `do:`) needs a String to walk character by + ;; character. + ((= selector "printOn:") + (let + ((stream (nth args 0)) + (s (str (st-send receiver "printString" (list))))) + (begin + (st-send stream "nextPutAll:" (list s)) + receiver))) + ;; Universal printString fallback for receivers no primitive table + ;; handles (notably user st-instances). Native types implement + ;; their own printString in the primitive senders below. + ((and (= selector "printString") + (or (st-instance? receiver) (st-class-ref? receiver))) + (st-printable-string receiver)) + ;; isMemberOf: aClass — exact class match. + ((= selector "isMemberOf:") + (let + ((arg (nth args 0)) + (target-cls (if (st-class-ref? receiver) "Metaclass" cls))) + (cond + ((not (st-class-ref? arg)) false) + (else (= target-cls (get arg :name)))))) + ;; Smalltalk Exception system — `signal` raises the receiver via + ;; SX raise. The argument to signal: sets messageText. + ;; on:do: / ensure: / ifCurtailed: are implemented on BlockClosure + ;; in `st-block-dispatch`. + ((and (= selector "signal") + (st-instance? receiver) + (st-class-inherits-from? cls "Exception")) + (raise receiver)) + ((and (= selector "signal:") + (st-instance? receiver) + (st-class-inherits-from? cls "Exception")) + (begin + (dict-set! (get receiver :ivars) "messageText" (nth args 0)) + (raise receiver))) + ((and (= selector "signal") + (st-class-ref? receiver) + (st-class-inherits-from? (get receiver :name) "Exception")) + (raise (st-make-instance (get receiver :name)))) + ((and (= selector "signal:") + (st-class-ref? receiver) + (st-class-inherits-from? (get receiver :name) "Exception")) + (let ((inst (st-make-instance (get receiver :name)))) + (begin + (dict-set! (get inst :ivars) "messageText" (nth args 0)) + (raise inst)))) + ;; Object>>becomeForward: aReceiver — one-way become. The receiver's + ;; class and ivars are mutated in place to match the target. Every + ;; existing reference to the receiver dict sees the new identity. + ;; Note: receiver and target remain distinct dicts (not == in the + ;; SX-identity sense), but receiver behaves as though it were the + ;; target — which is the practical Pharo guarantee. + ((= selector "becomeForward:") + (let ((other (nth args 0))) + (cond + ((not (st-instance? receiver)) + (error "becomeForward: only supported on user instances")) + ((not (st-instance? other)) + (error "becomeForward: target must be a user instance")) + (else + (begin + (dict-set! receiver :class (get other :class)) + (dict-set! receiver :ivars (get other :ivars)) + receiver))))) + ((or (= cls "SmallInteger") (= cls "Float")) + (st-num-send receiver selector args)) + ((or (= cls "String") (= cls "Symbol")) + (st-string-send receiver selector args)) + ((= cls "True") (st-bool-send true selector args)) + ((= cls "False") (st-bool-send false selector args)) + ((= cls "UndefinedObject") (st-nil-send selector args)) + ((= cls "Array") (st-array-send receiver selector args)) + ((st-class-ref? receiver) (st-class-side-send receiver selector args)) + (else :unhandled))))) + +;; Default printable representation. User instances render as +;; "an X" (or "a X" for vowel-initial classes); class-refs render as +;; their name. Native types are handled by their primitive senders. +(define + st-printable-string + (fn + (v) + (cond + ((st-class-ref? v) (get v :name)) + ((st-instance? v) + (let ((cls (get v :class))) + (let ((article (if (st-vowel-initial? cls) "an " "a "))) + (str article cls)))) + (else (str v))))) + +(define + st-vowel-initial? + (fn + (s) + (cond + ((= (len s) 0) false) + (else + (let ((c (nth s 0))) + (or (= c "A") (= c "E") (= c "I") (= c "O") (= c "U") + (= c "a") (= c "e") (= c "i") (= c "o") (= c "u"))))))) + +;; Pharo-style {N}-substitution. Walks the source, when a '{' starts a +;; valid numeric index, substitutes the corresponding (1-indexed) item +;; from the args collection. Unmatched braces are preserved. +(define + st-format-step + (fn + (src args out i n) + (let ((c (nth src i))) + (cond + ((not (= c "{")) + {:emit c :advance 1}) + (else + (let ((close (st-find-close-brace src i))) + (cond + ((= close -1) {:emit c :advance 1}) + (else + (let ((idx (parse-number (slice src (+ i 1) close)))) + (cond + ((and (number? idx) + (integer? idx) + (> idx 0) + (<= idx (len args))) + {:emit (str (nth args (- idx 1))) + :advance (- (+ close 1) i)}) + (else + {:emit c :advance 1}))))))))))) + +(define + st-format-string + (fn + (src args) + (let ((out (list)) (i 0) (n (len src))) + (begin + (define + fmt-loop + (fn + () + (when + (< i n) + (let ((step (st-format-step src args out i n))) + (begin + (append! out (get step :emit)) + (set! i (+ i (get step :advance))) + (fmt-loop)))))) + (fmt-loop) + (join "" out))))) + +(define + st-find-close-brace + (fn + (src start) + (let ((i (+ start 1)) (n (len src)) (found -1)) + (begin + (define + fc-loop + (fn + () + (when + (and (< i n) (= found -1)) + (cond + ((= (nth src i) "}") (set! found i)) + (else (begin (set! i (+ i 1)) (fc-loop))))))) + (fc-loop) + found)))) + +(define + st-num-send + (fn + (n selector args) + (cond + ((= selector "+") (+ n (nth args 0))) + ((= selector "-") (- n (nth args 0))) + ((= selector "*") (* n (nth args 0))) + ((= selector "/") (/ n (nth args 0))) + ((= selector "//") (/ n (nth args 0))) + ((= selector "\\\\") (mod n (nth args 0))) + ((= selector "<") (< n (nth args 0))) + ((= selector ">") (> n (nth args 0))) + ((= selector "<=") (<= n (nth args 0))) + ((= selector ">=") (>= n (nth args 0))) + ((= selector "=") (= n (nth args 0))) + ((= selector "~=") (not (= n (nth args 0)))) + ((= selector "==") (= n (nth args 0))) + ((= selector "~~") (not (= n (nth args 0)))) + ((= selector "negated") (- 0 n)) + ((= selector "abs") (if (< n 0) (- 0 n) n)) + ((= selector "floor") (floor n)) + ((= selector "ceiling") + ;; ceiling(x) = -floor(-x); fast for both signs. + (- 0 (floor (- 0 n)))) + ((= selector "truncated") (truncate n)) + ((= selector "rounded") (round n)) + ((= selector "sqrt") (sqrt n)) + ((= selector "squared") (* n n)) + ((= selector "raisedTo:") + (let ((p (nth args 0)) (acc 1) (i 0)) + (begin + (define + rt-loop + (fn () + (when (< i p) + (begin (set! acc (* acc n)) (set! i (+ i 1)) (rt-loop))))) + (rt-loop) + acc))) + ((= selector "factorial") + (let ((acc 1) (i 2)) + (begin + (define + ft-loop + (fn () + (when (<= i n) + (begin (set! acc (* acc i)) (set! i (+ i 1)) (ft-loop))))) + (ft-loop) + acc))) + ((= selector "even") (= (mod n 2) 0)) + ((= selector "odd") (= (mod n 2) 1)) + ((= selector "isInteger") (integer? n)) + ((= selector "isFloat") (and (number? n) (not (integer? n)))) + ((= selector "isNumber") true) + ((= selector "gcd:") + (let ((a (if (< n 0) (- 0 n) n)) + (b (if (< (nth args 0) 0) (- 0 (nth args 0)) (nth args 0)))) + (begin + (define + gcd-loop + (fn () + (cond + ((= b 0) a) + (else + (let ((t (mod a b))) + (begin (set! a b) (set! b t) (gcd-loop))))))) + (gcd-loop)))) + ((= selector "lcm:") + (let ((g (st-num-send n "gcd:" args))) + (cond ((= g 0) 0) + (else (* (/ n g) (nth args 0)))))) + ((= selector "max:") (if (> n (nth args 0)) n (nth args 0))) + ((= selector "min:") (if (< n (nth args 0)) n (nth args 0))) + ((= selector "printString") (str n)) + ((= selector "asString") (str n)) + ((= selector "class") + (st-class-ref (st-class-of n))) + ((= selector "isNil") false) + ((= selector "notNil") true) + ((= selector "isZero") (= n 0)) + ((= selector "between:and:") + (and (>= n (nth args 0)) (<= n (nth args 1)))) + ((= selector "to:do:") + (let ((i n) (stop (nth args 0)) (block (nth args 1))) + (begin + (define + td-loop + (fn + () + (when + (<= i stop) + (begin + (st-block-apply block (list i)) + (set! i (+ i 1)) + (td-loop))))) + (td-loop) + n))) + ((= selector "timesRepeat:") + (let ((i 0) (block (nth args 0))) + (begin + (define + tr-loop + (fn + () + (when + (< i n) + (begin + (st-block-apply block (list)) + (set! i (+ i 1)) + (tr-loop))))) + (tr-loop) + n))) + (else :unhandled)))) + +(define + st-string-send + (fn + (s selector args) + (cond + ((= selector ",") (str s (nth args 0))) + ((= selector "size") (len s)) + ((= selector "=") (= s (nth args 0))) + ((= selector "~=") (not (= s (nth args 0)))) + ((= selector "==") (= s (nth args 0))) + ((= selector "~~") (not (= s (nth args 0)))) + ((= selector "isEmpty") (= (len s) 0)) + ((= selector "notEmpty") (> (len s) 0)) + ((= selector "printString") (str "'" s "'")) + ((= selector "asString") s) + ((= selector "asSymbol") (make-symbol (if (symbol? s) (str s) s))) + ;; 1-indexed character access; returns the character (a 1-char string). + ((= selector "at:") (nth s (- (nth args 0) 1))) + ((= selector "do:") + (let ((i 0) (n (len s)) (block (nth args 0))) + (begin + (define + sd-loop + (fn () + (when (< i n) + (begin + (st-block-apply block (list (nth s i))) + (set! i (+ i 1)) + (sd-loop))))) + (sd-loop) + s))) + ((= selector "first") (nth s 0)) + ((= selector "last") (nth s (- (len s) 1))) + ((= selector "copyFrom:to:") + (slice s (- (nth args 0) 1) (nth args 1))) + ;; String>>format: — Pharo-style {N}-substitution. + ;; '{1} loves {2}' format: #('Alice' 'Bob') → 'Alice loves Bob' + ;; Indexes are 1-based. Unmatched braces are kept literally. + ((= selector "format:") + (st-format-string s (nth args 0))) + ((= selector "class") (st-class-ref (st-class-of s))) + ((= selector "isNil") false) + ((= selector "notNil") true) + (else :unhandled)))) + +(define + st-bool-send + (fn + (b selector args) + (cond + ((= selector "not") (not b)) + ((= selector "&") (and b (nth args 0))) + ((= selector "|") (or b (nth args 0))) + ((= selector "and:") + (cond (b (st-block-apply (nth args 0) (list))) (else false))) + ((= selector "or:") + (cond (b true) (else (st-block-apply (nth args 0) (list))))) + ((= selector "ifTrue:") + (cond (b (st-block-apply (nth args 0) (list))) (else nil))) + ((= selector "ifFalse:") + (cond (b nil) (else (st-block-apply (nth args 0) (list))))) + ((= selector "ifTrue:ifFalse:") + (cond + (b (st-block-apply (nth args 0) (list))) + (else (st-block-apply (nth args 1) (list))))) + ((= selector "ifFalse:ifTrue:") + (cond + (b (st-block-apply (nth args 1) (list))) + (else (st-block-apply (nth args 0) (list))))) + ((= selector "=") (= b (nth args 0))) + ((= selector "~=") (not (= b (nth args 0)))) + ((= selector "==") (= b (nth args 0))) + ((= selector "printString") (if b "true" "false")) + ((= selector "class") (st-class-ref (if b "True" "False"))) + ((= selector "isNil") false) + ((= selector "notNil") true) + (else :unhandled)))) + +(define + st-nil-send + (fn + (selector args) + (cond + ((= selector "isNil") true) + ((= selector "notNil") false) + ((= selector "ifNil:") (st-block-apply (nth args 0) (list))) + ((= selector "ifNotNil:") nil) + ((= selector "ifNil:ifNotNil:") (st-block-apply (nth args 0) (list))) + ((= selector "ifNotNil:ifNil:") (st-block-apply (nth args 1) (list))) + ((= selector "=") (= nil (nth args 0))) + ((= selector "~=") (not (= nil (nth args 0)))) + ((= selector "==") (= nil (nth args 0))) + ((= selector "printString") "nil") + ((= selector "class") (st-class-ref "UndefinedObject")) + (else :unhandled)))) + +(define + st-array-send + (fn + (a selector args) + (cond + ((= selector "size") (len a)) + ((= selector "at:") + ;; 1-indexed + (nth a (- (nth args 0) 1))) + ((= selector "at:put:") + (begin + (set-nth! a (- (nth args 0) 1) (nth args 1)) + (nth args 1))) + ((= selector "first") (nth a 0)) + ((= selector "last") (nth a (- (len a) 1))) + ((= selector "isEmpty") (= (len a) 0)) + ((= selector "notEmpty") (> (len a) 0)) + ((= selector "do:") + (begin + (for-each + (fn (e) (st-block-apply (nth args 0) (list e))) + a) + a)) + ((= selector "add:") + (begin (append! a (nth args 0)) (nth args 0))) + ((= selector "collect:") + (map (fn (e) (st-block-apply (nth args 0) (list e))) a)) + ((= selector "select:") + (filter (fn (e) (st-block-apply (nth args 0) (list e))) a)) + ((= selector ",") + (let ((out (list))) + (begin + (for-each (fn (e) (append! out e)) a) + (for-each (fn (e) (append! out e)) (nth args 0)) + out))) + ((= selector "=") (= a (nth args 0))) + ((= selector "==") (= a (nth args 0))) + ((= selector "printString") + (str "#(" (join " " (map (fn (e) (str e)) a)) ")")) + ((= selector "class") (st-class-ref "Array")) + ((= selector "isNil") false) + ((= selector "notNil") true) + (else :unhandled)))) + +;; Split a Smalltalk-style "x y z" instance-variable string into a list of +;; ivar names. Whitespace-delimited. +(define + st-split-ivars + (fn + (s) + (let ((out (list)) (n (len s)) (i 0) (start nil)) + (begin + (define + flush! + (fn () + (when + (not (= start nil)) + (begin (append! out (slice s start i)) (set! start nil))))) + (define + si-loop + (fn () + (when + (< i n) + (let ((c (nth s i))) + (cond + ((or (= c " ") (= c "\t") (= c "\n") (= c "\r")) + (begin (flush!) (set! i (+ i 1)) (si-loop))) + (else + (begin + (when (= start nil) (set! start i)) + (set! i (+ i 1)) + (si-loop)))))))) + (si-loop) + (flush!) + out)))) + +(define + st-class-side-send + (fn + (cref selector args) + (let ((name (get cref :name))) + (cond + ((= selector "new") + (cond + ((= name "Array") (list)) + (else (st-make-instance name)))) + ((= selector "new:") + (cond + ((= name "Array") + (let ((size (nth args 0)) (out (list))) + (begin + (let ((i 0)) + (begin + (define + an-loop + (fn () + (when + (< i size) + (begin + (append! out nil) + (set! i (+ i 1)) + (an-loop))))) + (an-loop))) + out))) + (else (st-make-instance name)))) + ((= selector "name") name) + ((= selector "superclass") + (let ((s (st-class-superclass name))) + (cond ((= s nil) nil) (else (st-class-ref s))))) + ((= selector "methodDict") + ;; The class's own method dictionary (instance side). + (get (st-class-get name) :methods)) + ((= selector "classMethodDict") + (get (st-class-get name) :class-methods)) + ((= selector "selectors") + ;; Own instance-side selectors as an Array of symbols. + (let ((out (list))) + (begin + (for-each + (fn (k) (append! out (make-symbol k))) + (keys (get (st-class-get name) :methods))) + out))) + ((= selector "classSelectors") + (let ((out (list))) + (begin + (for-each + (fn (k) (append! out (make-symbol k))) + (keys (get (st-class-get name) :class-methods))) + out))) + ((= selector "instanceVariableNames") + ;; Own ivars as an Array of strings (matches Pharo). + (get (st-class-get name) :ivars)) + ((= selector "allInstVarNames") + ;; Inherited + own ivars in declaration order (root first). + (st-class-all-ivars name)) + ;; Class definition: `Object subclass: #Foo instanceVariableNames: 'x y'`. + ;; Supports the short `subclass:` and the full + ;; `subclass:instanceVariableNames:classVariableNames:package:` form. + ((or (= selector "subclass:") + (= selector "subclass:instanceVariableNames:") + (= selector "subclass:instanceVariableNames:classVariableNames:") + (= selector "subclass:instanceVariableNames:classVariableNames:package:") + (= selector "subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:")) + (let + ((sub-sym (nth args 0)) + (iv-string (if (> (len args) 1) (nth args 1) ""))) + (let + ((sub-name (str sub-sym))) + (begin + (st-class-define! + sub-name + name + (st-split-ivars (if (string? iv-string) iv-string (str iv-string)))) + (st-class-ref sub-name))))) + ;; methodsFor: / methodsFor:stamp: are Pharo file-in markers — at + ;; the expression level they just return the class for further + ;; cascades. Method bodies are loaded by the chunk-stream loader. + ((or (= selector "methodsFor:") + (= selector "methodsFor:stamp:") + (= selector "category:") + (= selector "comment:")) + cref) + ;; Behavior>>compile: parses the source string as a method and + ;; installs it. Returns the selector as a symbol. + ;; Sister forms: compile:classified: and compile:notifying: + ;; ignore the extra arg, mirroring Pharo's tolerant behaviour. + ((or (= selector "compile:") + (= selector "compile:classified:") + (= selector "compile:notifying:")) + (let ((src (nth args 0))) + (let ((method-ast (st-parse-method (str src)))) + (st-class-add-method! + name (get method-ast :selector) method-ast) + (make-symbol (get method-ast :selector))))) + ((or (= selector "addSelector:withMethod:") + (= selector "addSelector:method:")) + (let + ((sel (str (nth args 0))) + (method-ast (nth args 1))) + (begin + (st-class-add-method! name sel method-ast) + (make-symbol sel)))) + ((= selector "removeSelector:") + (let ((sel (str (nth args 0)))) + (st-class-remove-method! name sel))) + ((= selector "printString") name) + ((= selector "class") (st-class-ref "Metaclass")) + ((= selector "==") (and (st-class-ref? (nth args 0)) + (= name (get (nth args 0) :name)))) + ((= selector "=") (and (st-class-ref? (nth args 0)) + (= name (get (nth args 0) :name)))) + ((= selector "isNil") false) + ((= selector "notNil") true) + (else :unhandled))))) + +;; Run a chunk-format Smalltalk program. Do-it expressions execute in a +;; fresh top-level frame (with an active-cell so ^expr works). Method +;; chunks register on the named class. +(define + smalltalk-load + (fn + (src) + (let ((entries (st-parse-chunks src)) (last-result nil)) + (begin + (for-each + (fn (entry) + (let ((kind (get entry :kind))) + (cond + ((= kind "expr") + (let ((cell {:active true})) + (set! + last-result + (call/cc + (fn (k) + (smalltalk-eval-ast + (get entry :ast) + (st-make-frame nil nil nil k cell))))) + (dict-set! cell :active false))) + ((= kind "method") + (cond + ((get entry :class-side?) + (st-class-add-class-method! + (get entry :class) + (get (get entry :ast) :selector) + (get entry :ast))) + (else + (st-class-add-method! + (get entry :class) + (get (get entry :ast) :selector) + (get entry :ast))))) + (else nil)))) + entries) + last-result)))) + +;; Convenience: parse and evaluate a Smalltalk expression with no receiver. +(define + smalltalk-eval + (fn + (src) + (let ((cell {:active true})) + (let + ((result + (call/cc + (fn (k) + (let + ((ast (st-parse-expr src)) + (frame (st-make-frame nil nil nil k cell))) + (smalltalk-eval-ast ast frame)))))) + (begin (dict-set! cell :active false) result))))) + +;; Evaluate a sequence of statements at the top level. +(define + smalltalk-eval-program + (fn + (src) + (let ((cell {:active true})) + (let + ((result + (call/cc + (fn (k) + (let + ((ast (st-parse src)) + (frame (st-make-frame nil nil nil k cell))) + (begin + (when + (and (dict? ast) (has-key? ast :temps)) + (for-each + (fn (t) (dict-set! (get frame :locals) t nil)) + (get ast :temps))) + (smalltalk-eval-ast ast frame))))))) + (begin (dict-set! cell :active false) result))))) diff --git a/lib/smalltalk/parser.sx b/lib/smalltalk/parser.sx new file mode 100644 index 00000000..aae1bac8 --- /dev/null +++ b/lib/smalltalk/parser.sx @@ -0,0 +1,948 @@ +;; Smalltalk parser — produces an AST from the tokenizer's token stream. +;; +;; AST node shapes (dicts): +;; {:type "lit-int" :value N} integer +;; {:type "lit-float" :value F} float +;; {:type "lit-string" :value S} string +;; {:type "lit-char" :value C} character +;; {:type "lit-symbol" :value S} symbol literal (#foo) +;; {:type "lit-array" :elements (list ...)} literal array (#(1 2 #foo)) +;; {:type "lit-byte-array" :elements (...)} byte array (#[1 2 3]) +;; {:type "lit-nil" } / "lit-true" / "lit-false" +;; {:type "ident" :name "x"} variable reference +;; {:type "self"} / "super" / "thisContext" pseudo-variables +;; {:type "assign" :name "x" :expr E} x := E +;; {:type "return" :expr E} ^ E +;; {:type "send" :receiver R :selector S :args (list ...)} +;; {:type "cascade" :receiver R :messages (list {:selector :args} ...)} +;; {:type "block" :params (list "a") :temps (list "t") :body (list expr)} +;; {:type "seq" :exprs (list ...)} statement sequence +;; {:type "method" :selector S :params (list ...) :temps (list ...) :body (list ...) :pragmas (list ...)} +;; +;; A "chunk" / class-definition stream is parsed at a higher level (deferred). + +;; ── Chunk-stream reader ──────────────────────────────────────────────── +;; Pharo chunk format: chunks are separated by `!`. A doubled `!!` inside a +;; chunk represents a single literal `!`. Returns list of chunk strings with +;; surrounding whitespace trimmed. +(define + st-read-chunks + (fn + (src) + (let + ((chunks (list)) + (buf (list)) + (pos 0) + (n (len src))) + (begin + (define + flush! + (fn + () + (let + ((s (st-trim (join "" buf)))) + (begin (append! chunks s) (set! buf (list)))))) + (define + rc-loop + (fn + () + (when + (< pos n) + (let + ((c (nth src pos))) + (cond + ((= c "!") + (cond + ((and (< (+ pos 1) n) (= (nth src (+ pos 1)) "!")) + (begin (append! buf "!") (set! pos (+ pos 2)) (rc-loop))) + (else + (begin (flush!) (set! pos (+ pos 1)) (rc-loop))))) + (else + (begin (append! buf c) (set! pos (+ pos 1)) (rc-loop)))))))) + (rc-loop) + ;; trailing text without a closing `!` — preserve as a chunk + (when (> (len buf) 0) (flush!)) + chunks)))) + +(define + st-trim + (fn + (s) + (let + ((n (len s)) (i 0) (j 0)) + (begin + (set! j n) + (define + tl-loop + (fn + () + (when + (and (< i n) (st-trim-ws? (nth s i))) + (begin (set! i (+ i 1)) (tl-loop))))) + (tl-loop) + (define + tr-loop + (fn + () + (when + (and (> j i) (st-trim-ws? (nth s (- j 1)))) + (begin (set! j (- j 1)) (tr-loop))))) + (tr-loop) + (slice s i j))))) + +(define + st-trim-ws? + (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r")))) + +;; Parse a chunk stream. Walks chunks and applies the Pharo file-in +;; convention: a chunk that evaluates to "X methodsFor: 'cat'" or +;; "X class methodsFor: 'cat'" enters a methods batch — subsequent chunks +;; are method source until an empty chunk closes the batch. +;; +;; Returns list of entries: +;; {:kind "expr" :ast EXPR-AST} +;; {:kind "method" :class CLS :class-side? BOOL :category CAT :ast METHOD-AST} +;; {:kind "blank"} (empty chunks outside a methods batch) +;; {:kind "end-methods"} (empty chunk closing a methods batch) +(define + st-parse-chunks + (fn + (src) + (let + ((chunks (st-read-chunks src)) + (entries (list)) + (mode "do-it") + (cls-name nil) + (class-side? false) + (category nil)) + (begin + (for-each + (fn + (chunk) + (cond + ((= chunk "") + (cond + ((= mode "methods") + (begin + (append! entries {:kind "end-methods"}) + (set! mode "do-it") + (set! cls-name nil) + (set! class-side? false) + (set! category nil))) + (else (append! entries {:kind "blank"})))) + ((= mode "methods") + (append! + entries + {:kind "method" + :class cls-name + :class-side? class-side? + :category category + :ast (st-parse-method chunk)})) + (else + (let + ((ast (st-parse-expr chunk))) + (begin + (append! entries {:kind "expr" :ast ast}) + (let + ((mf (st-detect-methods-for ast))) + (when + (not (= mf nil)) + (begin + (set! mode "methods") + (set! cls-name (get mf :class)) + (set! class-side? (get mf :class-side?)) + (set! category (get mf :category)))))))))) + chunks) + entries)))) + +;; Recognise `Foo methodsFor: 'cat'` (and related) as starting a methods batch. +;; Returns nil if the AST doesn't look like one of these forms. +(define + st-detect-methods-for + (fn + (ast) + (cond + ((not (= (get ast :type) "send")) nil) + ((not (st-is-methods-for-selector? (get ast :selector))) nil) + (else + (let + ((recv (get ast :receiver)) (args (get ast :args))) + (let + ((cat-arg (if (> (len args) 0) (nth args 0) nil))) + (let + ((category + (cond + ((= cat-arg nil) nil) + ((= (get cat-arg :type) "lit-string") (get cat-arg :value)) + ((= (get cat-arg :type) "lit-symbol") (get cat-arg :value)) + (else nil)))) + (cond + ((= (get recv :type) "ident") + {:class (get recv :name) + :class-side? false + :category category}) + ;; `Foo class methodsFor: 'cat'` — recv is a unary send `Foo class` + ((and + (= (get recv :type) "send") + (= (get recv :selector) "class") + (= (get (get recv :receiver) :type) "ident")) + {:class (get (get recv :receiver) :name) + :class-side? true + :category category}) + (else nil))))))))) + +(define + st-is-methods-for-selector? + (fn + (sel) + (or + (= sel "methodsFor:") + (= sel "methodsFor:stamp:") + (= sel "category:")))) + +(define st-tok-type (fn (t) (if (= t nil) "eof" (get t :type)))) + +(define st-tok-value (fn (t) (if (= t nil) nil (get t :value)))) + +;; Parse a *single* Smalltalk expression from source. +(define st-parse-expr (fn (src) (st-parse-with src "expr"))) + +;; Parse a sequence of statements separated by '.' Returns a {:type "seq"} node. +(define st-parse (fn (src) (st-parse-with src "seq"))) + +;; Parse a method body — `selector params | temps | body`. +;; Only the "method header + body" form (no chunk delimiters). +(define st-parse-method (fn (src) (st-parse-with src "method"))) + +(define + st-parse-with + (fn + (src mode) + (let + ((tokens (st-tokenize src)) (idx 0) (tok-len 0)) + (begin + (set! tok-len (len tokens)) + (define peek-tok (fn () (nth tokens idx))) + (define + peek-tok-at + (fn (n) (if (< (+ idx n) tok-len) (nth tokens (+ idx n)) nil))) + (define advance-tok! (fn () (set! idx (+ idx 1)))) + (define + at? + (fn + (type value) + (let + ((t (peek-tok))) + (and + (= (st-tok-type t) type) + (or (= value nil) (= (st-tok-value t) value)))))) + (define at-type? (fn (type) (= (st-tok-type (peek-tok)) type))) + (define + consume! + (fn + (type value) + (if + (at? type value) + (let ((t (peek-tok))) (begin (advance-tok!) t)) + (error + (str + "st-parse: expected " + type + (if (= value nil) "" (str " '" value "'")) + " got " + (st-tok-type (peek-tok)) + " '" + (st-tok-value (peek-tok)) + "' at idx " + idx))))) + + ;; ── Primary: atoms, paren'd expr, blocks, literal arrays, byte arrays. + (define + parse-primary + (fn + () + (let + ((t (peek-tok))) + (let + ((ty (st-tok-type t)) (v (st-tok-value t))) + (cond + ((= ty "number") + (begin + (advance-tok!) + (cond + ((number? v) {:type (if (integer? v) "lit-int" "lit-float") :value v}) + (else {:type "lit-int" :value v})))) + ((= ty "string") + (begin (advance-tok!) {:type "lit-string" :value v})) + ((= ty "char") + (begin (advance-tok!) {:type "lit-char" :value v})) + ((= ty "symbol") + (begin (advance-tok!) {:type "lit-symbol" :value v})) + ((= ty "array-open") (parse-literal-array)) + ((= ty "byte-array-open") (parse-byte-array)) + ((= ty "lparen") + (begin + (advance-tok!) + (let + ((e (parse-expression))) + (begin (consume! "rparen" nil) e)))) + ((= ty "lbracket") (parse-block)) + ((= ty "lbrace") (parse-dynamic-array)) + ((= ty "ident") + (begin + (advance-tok!) + (cond + ((= v "nil") {:type "lit-nil"}) + ((= v "true") {:type "lit-true"}) + ((= v "false") {:type "lit-false"}) + ((= v "self") {:type "self"}) + ((= v "super") {:type "super"}) + ((= v "thisContext") {:type "thisContext"}) + (else {:type "ident" :name v})))) + ((= ty "binary") + ;; Negative numeric literal: '-' immediately before a number. + (cond + ((and (= v "-") (= (st-tok-type (peek-tok-at 1)) "number")) + (let + ((n (st-tok-value (peek-tok-at 1)))) + (begin + (advance-tok!) + (advance-tok!) + (cond + ((dict? n) {:type "lit-int" :value n}) + ((integer? n) {:type "lit-int" :value (- 0 n)}) + (else {:type "lit-float" :value (- 0 n)}))))) + (else + (error + (str "st-parse: unexpected binary '" v "' at idx " idx))))) + (else + (error + (str + "st-parse: unexpected " + ty + " '" + v + "' at idx " + idx)))))))) + + ;; #(elem elem ...) — elements are atoms or nested parenthesised arrays. + (define + parse-literal-array + (fn + () + (let + ((items (list))) + (begin + (consume! "array-open" nil) + (define + arr-loop + (fn + () + (cond + ((at? "rparen" nil) (advance-tok!)) + (else + (begin + (append! items (parse-array-element)) + (arr-loop)))))) + (arr-loop) + {:type "lit-array" :elements items})))) + + ;; { expr. expr. expr } — Pharo dynamic array literal. Each element + ;; is a *full expression* evaluated at runtime; the result is a + ;; fresh mutable array. Empty `{}` is a 0-length array. + (define + parse-dynamic-array + (fn + () + (let ((items (list))) + (begin + (consume! "lbrace" nil) + (define + da-loop + (fn + () + (cond + ((at? "rbrace" nil) (advance-tok!)) + (else + (begin + (append! items (parse-expression)) + (define + dot-loop + (fn + () + (when + (at? "period" nil) + (begin (advance-tok!) (dot-loop))))) + (dot-loop) + (da-loop)))))) + (da-loop) + {:type "dynamic-array" :elements items})))) + + ;; #[1 2 3] + (define + parse-byte-array + (fn + () + (let + ((items (list))) + (begin + (consume! "byte-array-open" nil) + (define + ba-loop + (fn + () + (cond + ((at? "rbracket" nil) (advance-tok!)) + (else + (let + ((t (peek-tok))) + (cond + ((= (st-tok-type t) "number") + (begin + (advance-tok!) + (append! items (st-tok-value t)) + (ba-loop))) + (else + (error + (str + "st-parse: byte array expects number, got " + (st-tok-type t)))))))))) + (ba-loop) + {:type "lit-byte-array" :elements items})))) + + ;; Inside a literal array: bare idents become symbols, nested (...) is a sub-array. + (define + parse-array-element + (fn + () + (let + ((t (peek-tok))) + (let + ((ty (st-tok-type t)) (v (st-tok-value t))) + (cond + ((= ty "number") (begin (advance-tok!) {:type "lit-int" :value v})) + ((= ty "string") (begin (advance-tok!) {:type "lit-string" :value v})) + ((= ty "char") (begin (advance-tok!) {:type "lit-char" :value v})) + ((= ty "symbol") (begin (advance-tok!) {:type "lit-symbol" :value v})) + ((= ty "ident") + (begin + (advance-tok!) + (cond + ((= v "nil") {:type "lit-nil"}) + ((= v "true") {:type "lit-true"}) + ((= v "false") {:type "lit-false"}) + (else {:type "lit-symbol" :value v})))) + ((= ty "keyword") (begin (advance-tok!) {:type "lit-symbol" :value v})) + ((= ty "binary") (begin (advance-tok!) {:type "lit-symbol" :value v})) + ((= ty "lparen") + (let ((items (list))) + (begin + (advance-tok!) + (define + sub-loop + (fn + () + (cond + ((at? "rparen" nil) (advance-tok!)) + (else + (begin (append! items (parse-array-element)) (sub-loop)))))) + (sub-loop) + {:type "lit-array" :elements items}))) + ((= ty "array-open") (parse-literal-array)) + ((= ty "byte-array-open") (parse-byte-array)) + (else + (error + (str "st-parse: bad literal-array element " ty " '" v "'")))))))) + + ;; [:a :b | | t1 t2 | body. body. ...] + (define + parse-block + (fn + () + (begin + (consume! "lbracket" nil) + (let + ((params (list)) (temps (list))) + (begin + ;; Block params + (define + p-loop + (fn + () + (when + (at? "colon" nil) + (begin + (advance-tok!) + (let + ((t (consume! "ident" nil))) + (begin + (append! params (st-tok-value t)) + (p-loop))))))) + (p-loop) + (when (> (len params) 0) (consume! "bar" nil)) + ;; Block temps: | t1 t2 | + (when + (and + (at? "bar" nil) + ;; Not `|` followed immediately by binary content — the only + ;; legitimate `|` inside a block here is the temp delimiter. + true) + (begin + (advance-tok!) + (define + t-loop + (fn + () + (when + (at? "ident" nil) + (let + ((t (peek-tok))) + (begin + (advance-tok!) + (append! temps (st-tok-value t)) + (t-loop)))))) + (t-loop) + (consume! "bar" nil))) + ;; Body: statements terminated by `.` or `]` + (let + ((body (parse-statements "rbracket"))) + (begin + (consume! "rbracket" nil) + {:type "block" :params params :temps temps :body body}))))))) + + ;; Parse statements up to a closing token (rbracket or eof). Returns list. + (define + parse-statements + (fn + (terminator) + (let + ((stmts (list))) + (begin + (define + s-loop + (fn + () + (cond + ((at-type? terminator) nil) + ((at-type? "eof") nil) + (else + (begin + (append! stmts (parse-statement)) + ;; consume optional period(s) + (define + dot-loop + (fn + () + (when + (at? "period" nil) + (begin (advance-tok!) (dot-loop))))) + (dot-loop) + (s-loop)))))) + (s-loop) + stmts)))) + + ;; Statement: ^expr | ident := expr | expr + (define + parse-statement + (fn + () + (cond + ((at? "caret" nil) + (begin + (advance-tok!) + {:type "return" :expr (parse-expression)})) + ((and (at-type? "ident") (= (st-tok-type (peek-tok-at 1)) "assign")) + (let + ((name-tok (peek-tok))) + (begin + (advance-tok!) + (advance-tok!) + {:type "assign" + :name (st-tok-value name-tok) + :expr (parse-expression)}))) + (else (parse-expression))))) + + ;; Top-level expression. Assignment (right-associative chain) sits at + ;; the top; cascade is below. + (define + parse-expression + (fn + () + (cond + ((and (at-type? "ident") (= (st-tok-type (peek-tok-at 1)) "assign")) + (let + ((name-tok (peek-tok))) + (begin + (advance-tok!) + (advance-tok!) + {:type "assign" + :name (st-tok-value name-tok) + :expr (parse-expression)}))) + (else (parse-cascade))))) + + (define + parse-cascade + (fn + () + (let + ((head (parse-keyword-message))) + (cond + ((at? "semi" nil) + (let + ((receiver (cascade-receiver head)) + (first-msg (cascade-first-message head)) + (msgs (list))) + (begin + (append! msgs first-msg) + (define + c-loop + (fn + () + (when + (at? "semi" nil) + (begin + (advance-tok!) + (append! msgs (parse-cascade-message)) + (c-loop))))) + (c-loop) + {:type "cascade" :receiver receiver :messages msgs}))) + (else head))))) + + ;; Extract the receiver from a head send so cascades share it. + (define + cascade-receiver + (fn + (head) + (cond + ((= (get head :type) "send") (get head :receiver)) + (else head)))) + + (define + cascade-first-message + (fn + (head) + (cond + ((= (get head :type) "send") + {:selector (get head :selector) :args (get head :args)}) + (else + ;; Shouldn't happen — cascade requires at least one prior message. + (error "st-parse: cascade with no prior message"))))) + + ;; Subsequent cascade message (after the `;`): unary | binary | keyword + (define + parse-cascade-message + (fn + () + (cond + ((at-type? "ident") + (let ((t (peek-tok))) + (begin + (advance-tok!) + {:selector (st-tok-value t) :args (list)}))) + ((at-type? "binary") + (let ((t (peek-tok))) + (begin + (advance-tok!) + (let + ((arg (parse-unary-message))) + {:selector (st-tok-value t) :args (list arg)})))) + ((at-type? "keyword") + (let + ((sel-parts (list)) (args (list))) + (begin + (define + kw-loop + (fn + () + (when + (at-type? "keyword") + (let ((t (peek-tok))) + (begin + (advance-tok!) + (append! sel-parts (st-tok-value t)) + (append! args (parse-binary-message)) + (kw-loop)))))) + (kw-loop) + {:selector (join "" sel-parts) :args args}))) + (else + (error + (str "st-parse: bad cascade message at idx " idx)))))) + + ;; Keyword message: (kw )+ + (define + parse-keyword-message + (fn + () + (let + ((receiver (parse-binary-message))) + (cond + ((at-type? "keyword") + (let + ((sel-parts (list)) (args (list))) + (begin + (define + kw-loop + (fn + () + (when + (at-type? "keyword") + (let ((t (peek-tok))) + (begin + (advance-tok!) + (append! sel-parts (st-tok-value t)) + (append! args (parse-binary-message)) + (kw-loop)))))) + (kw-loop) + {:type "send" + :receiver receiver + :selector (join "" sel-parts) + :args args}))) + (else receiver))))) + + ;; Binary message: (binop )* + ;; A bare `|` is also a legitimate binary selector (logical or in + ;; some Smalltalks); the tokenizer emits it as the `bar` type so + ;; that block-param / temp-decl delimiters are easy to spot. + ;; In expression position, accept it as a binary operator. + (define + parse-binary-message + (fn + () + (let + ((receiver (parse-unary-message))) + (begin + (define + b-loop + (fn + () + (when + (or (at-type? "binary") (at-type? "bar")) + (let ((t (peek-tok))) + (begin + (advance-tok!) + (let + ((arg (parse-unary-message))) + (set! + receiver + {:type "send" + :receiver receiver + :selector (st-tok-value t) + :args (list arg)})) + (b-loop)))))) + (b-loop) + receiver)))) + + ;; Unary message: ident* (ident NOT followed by ':') + (define + parse-unary-message + (fn + () + (let + ((receiver (parse-primary))) + (begin + (define + u-loop + (fn + () + (when + (and + (at-type? "ident") + (let + ((nxt (peek-tok-at 1))) + (not (= (st-tok-type nxt) "assign")))) + (let ((t (peek-tok))) + (begin + (advance-tok!) + (set! + receiver + {:type "send" + :receiver receiver + :selector (st-tok-value t) + :args (list)}) + (u-loop)))))) + (u-loop) + receiver)))) + + ;; Parse a single pragma: `` + ;; Returns {:selector "primitive:" :args (list literal-asts)}. + (define + parse-pragma + (fn + () + (begin + (consume! "binary" "<") + (let + ((sel-parts (list)) (args (list))) + (begin + (define + pr-loop + (fn + () + (when + (at-type? "keyword") + (let ((t (peek-tok))) + (begin + (advance-tok!) + (append! sel-parts (st-tok-value t)) + (append! args (parse-pragma-arg)) + (pr-loop)))))) + (pr-loop) + (consume! "binary" ">") + {:selector (join "" sel-parts) :args args}))))) + + ;; Pragma arguments are literals only. + (define + parse-pragma-arg + (fn + () + (let + ((t (peek-tok))) + (let + ((ty (st-tok-type t)) (v (st-tok-value t))) + (cond + ((= ty "number") + (begin + (advance-tok!) + {:type (if (integer? v) "lit-int" "lit-float") :value v})) + ((= ty "string") (begin (advance-tok!) {:type "lit-string" :value v})) + ((= ty "char") (begin (advance-tok!) {:type "lit-char" :value v})) + ((= ty "symbol") (begin (advance-tok!) {:type "lit-symbol" :value v})) + ((= ty "ident") + (begin + (advance-tok!) + (cond + ((= v "nil") {:type "lit-nil"}) + ((= v "true") {:type "lit-true"}) + ((= v "false") {:type "lit-false"}) + (else (error (str "st-parse: pragma arg must be literal, got ident " v)))))) + ((and (= ty "binary") (= v "-") + (= (st-tok-type (peek-tok-at 1)) "number")) + (let ((n (st-tok-value (peek-tok-at 1)))) + (begin + (advance-tok!) + (advance-tok!) + {:type (if (integer? n) "lit-int" "lit-float") + :value (- 0 n)}))) + (else + (error + (str "st-parse: pragma arg must be literal, got " ty)))))))) + + ;; Method header: unary | binary arg | (kw arg)+ + (define + parse-method + (fn + () + (let + ((sel "") + (params (list)) + (temps (list)) + (pragmas (list)) + (body (list))) + (begin + (cond + ;; Unary header + ((at-type? "ident") + (let ((t (peek-tok))) + (begin (advance-tok!) (set! sel (st-tok-value t))))) + ;; Binary header: binop ident + ((at-type? "binary") + (let ((t (peek-tok))) + (begin + (advance-tok!) + (set! sel (st-tok-value t)) + (let ((p (consume! "ident" nil))) + (append! params (st-tok-value p)))))) + ;; Keyword header: (kw ident)+ + ((at-type? "keyword") + (let ((sel-parts (list))) + (begin + (define + kh-loop + (fn + () + (when + (at-type? "keyword") + (let ((t (peek-tok))) + (begin + (advance-tok!) + (append! sel-parts (st-tok-value t)) + (let ((p (consume! "ident" nil))) + (append! params (st-tok-value p))) + (kh-loop)))))) + (kh-loop) + (set! sel (join "" sel-parts))))) + (else + (error + (str + "st-parse-method: expected selector header, got " + (st-tok-type (peek-tok)))))) + ;; Pragmas and temps may appear in either order. Allow many + ;; pragmas; one temps section. + (define + parse-temps! + (fn + () + (begin + (advance-tok!) + (define + th-loop + (fn + () + (when + (at-type? "ident") + (let ((t (peek-tok))) + (begin + (advance-tok!) + (append! temps (st-tok-value t)) + (th-loop)))))) + (th-loop) + (consume! "bar" nil)))) + (define + pt-loop + (fn + () + (cond + ((and + (at? "binary" "<") + (= (st-tok-type (peek-tok-at 1)) "keyword")) + (begin (append! pragmas (parse-pragma)) (pt-loop))) + ((and (at? "bar" nil) (= (len temps) 0)) + (begin (parse-temps!) (pt-loop))) + (else nil)))) + (pt-loop) + ;; Body statements + (set! body (parse-statements "eof")) + {:type "method" + :selector sel + :params params + :temps temps + :pragmas pragmas + :body body})))) + + ;; Top-level program: optional temp declaration, then statements + ;; separated by '.'. Pharo workspace-style scripts allow + ;; `| temps | body...` at the top level. + (cond + ((= mode "expr") (parse-expression)) + ((= mode "method") (parse-method)) + (else + (let ((temps (list))) + (begin + (when + (at? "bar" nil) + (begin + (advance-tok!) + (define + tt-loop + (fn + () + (when + (at-type? "ident") + (let ((t (peek-tok))) + (begin + (advance-tok!) + (append! temps (st-tok-value t)) + (tt-loop)))))) + (tt-loop) + (consume! "bar" nil))) + {:type "seq" :temps temps :exprs (parse-statements "eof")})))))))) diff --git a/lib/smalltalk/runtime.sx b/lib/smalltalk/runtime.sx new file mode 100644 index 00000000..19198f22 --- /dev/null +++ b/lib/smalltalk/runtime.sx @@ -0,0 +1,787 @@ +;; Smalltalk runtime — class table, bootstrap hierarchy, type→class mapping, +;; instance construction. Method dispatch / eval-ast live in a later layer. +;; +;; Class record shape: +;; {:name "Foo" +;; :superclass "Object" ; or nil for Object itself +;; :ivars (list "x" "y") ; instance variable names declared on this class +;; :methods (dict selector→method-record) +;; :class-methods (dict selector→method-record)} +;; +;; A method record is the AST returned by st-parse-method, plus a :defining-class +;; field so super-sends can resolve from the right place. (Methods are registered +;; via runtime helpers that fill the field.) +;; +;; The class table is a single dict keyed by class name. Bootstrap installs the +;; canonical hierarchy. Test code resets it via (st-bootstrap-classes!). + +(define st-class-table {}) + +;; ── Method-lookup cache ──────────────────────────────────────────────── +;; Cache keys are "class|selector|side"; side is "i" (instance) or "c" (class). +;; Misses are stored as the sentinel :not-found so we don't re-walk for +;; every doesNotUnderstand call. +(define st-method-cache {}) +(define st-method-cache-hits 0) +(define st-method-cache-misses 0) + +(define + st-method-cache-clear! + (fn () (set! st-method-cache {}))) + +;; Inline-cache generation. Eval-time IC slots check this; bumping it +;; invalidates every cached call-site method record across the program. +(define st-ic-generation 0) + +(define + st-ic-bump-generation! + (fn () (set! st-ic-generation (+ st-ic-generation 1)))) + +(define + st-method-cache-key + (fn (cls sel class-side?) (str cls "|" sel "|" (if class-side? "c" "i")))) + +(define + st-method-cache-stats + (fn + () + {:hits st-method-cache-hits + :misses st-method-cache-misses + :size (len (keys st-method-cache))})) + +(define + st-method-cache-reset-stats! + (fn () + (begin + (set! st-method-cache-hits 0) + (set! st-method-cache-misses 0)))) + +(define + st-class-table-clear! + (fn () + (begin + (set! st-class-table {}) + (st-method-cache-clear!)))) + +(define + st-class-define! + (fn + (name superclass ivars) + (begin + (set! + st-class-table + (assoc + st-class-table + name + {:name name + :superclass superclass + :ivars ivars + :methods {} + :class-methods {}})) + ;; A redefined class can invalidate any cache entries that walked + ;; through its old position in the chain. Cheap + correct: drop all. + (st-method-cache-clear!) + name))) + +(define + st-class-get + (fn (name) (if (has-key? st-class-table name) (get st-class-table name) nil))) + +(define + st-class-exists? + (fn (name) (has-key? st-class-table name))) + +(define + st-class-superclass + (fn + (name) + (let + ((c (st-class-get name))) + (cond ((= c nil) nil) (else (get c :superclass)))))) + +;; Walk class chain root-to-leaf? No, follow superclass chain leaf-to-root. +;; Returns list of class names starting at `name` and ending with the root. +(define + st-class-chain + (fn + (name) + (let ((acc (list)) (cur name)) + (begin + (define + ch-loop + (fn + () + (when + (and (not (= cur nil)) (st-class-exists? cur)) + (begin + (append! acc cur) + (set! cur (st-class-superclass cur)) + (ch-loop))))) + (ch-loop) + acc)))) + +;; Inherited + own ivars in declaration order from root to leaf. +(define + st-class-all-ivars + (fn + (name) + (let ((chain (reverse (st-class-chain name))) (out (list))) + (begin + (for-each + (fn + (cn) + (let + ((c (st-class-get cn))) + (when + (not (= c nil)) + (for-each (fn (iv) (append! out iv)) (get c :ivars))))) + chain) + out)))) + +;; Method install. The defining-class field is stamped on the method record +;; so super-sends look up from the right point in the chain. +(define + st-class-add-method! + (fn + (cls-name selector method-ast) + (let + ((cls (st-class-get cls-name))) + (cond + ((= cls nil) (error (str "st-class-add-method!: unknown class " cls-name))) + (else + (let + ((m (assoc method-ast :defining-class cls-name))) + (begin + (set! + st-class-table + (assoc + st-class-table + cls-name + (assoc + cls + :methods + (assoc (get cls :methods) selector m)))) + (st-method-cache-clear!) + (st-ic-bump-generation!) + selector))))))) + +(define + st-class-add-class-method! + (fn + (cls-name selector method-ast) + (let + ((cls (st-class-get cls-name))) + (cond + ((= cls nil) (error (str "st-class-add-class-method!: unknown class " cls-name))) + (else + (let + ((m (assoc method-ast :defining-class cls-name))) + (begin + (set! + st-class-table + (assoc + st-class-table + cls-name + (assoc + cls + :class-methods + (assoc (get cls :class-methods) selector m)))) + (st-method-cache-clear!) + (st-ic-bump-generation!) + selector))))))) + +;; Remove a method from a class (instance side). Mostly for tests; runtime +;; reflection in Phase 4 will use the same primitive. +(define + st-class-remove-method! + (fn + (cls-name selector) + (let ((cls (st-class-get cls-name))) + (cond + ((= cls nil) (error (str "st-class-remove-method!: unknown class " cls-name))) + (else + (let ((md (get cls :methods))) + (cond + ((not (has-key? md selector)) false) + (else + (let ((new-md {})) + (begin + (for-each + (fn (k) + (when (not (= k selector)) + (dict-set! new-md k (get md k)))) + (keys md)) + (set! + st-class-table + (assoc + st-class-table + cls-name + (assoc cls :methods new-md))) + (st-method-cache-clear!) + (st-ic-bump-generation!) + true)))))))))) + +;; Walk-only lookup. Returns the method record (with :defining-class) or nil. +;; class-side? = true searches :class-methods, false searches :methods. +(define + st-method-lookup-walk + (fn + (cls-name selector class-side?) + (let + ((found nil)) + (begin + (define + ml-loop + (fn + (cur) + (when + (and (= found nil) (not (= cur nil)) (st-class-exists? cur)) + (let + ((c (st-class-get cur))) + (let + ((dict (if class-side? (get c :class-methods) (get c :methods)))) + (cond + ((has-key? dict selector) (set! found (get dict selector))) + (else (ml-loop (get c :superclass))))))))) + (ml-loop cls-name) + found)))) + +;; Cached lookup. Misses are stored as :not-found so doesNotUnderstand paths +;; don't re-walk on every send. +(define + st-method-lookup + (fn + (cls-name selector class-side?) + (let ((key (st-method-cache-key cls-name selector class-side?))) + (cond + ((has-key? st-method-cache key) + (begin + (set! st-method-cache-hits (+ st-method-cache-hits 1)) + (let ((v (get st-method-cache key))) + (cond ((= v :not-found) nil) (else v))))) + (else + (begin + (set! st-method-cache-misses (+ st-method-cache-misses 1)) + (let ((found (st-method-lookup-walk cls-name selector class-side?))) + (begin + (set! + st-method-cache + (assoc + st-method-cache + key + (cond ((= found nil) :not-found) (else found)))) + found)))))))) + +;; SX value → Smalltalk class name. Native types are not boxed. +(define + st-class-of + (fn + (v) + (cond + ((= v nil) "UndefinedObject") + ((= v true) "True") + ((= v false) "False") + ((integer? v) "SmallInteger") + ((number? v) "Float") + ((string? v) "String") + ((symbol? v) "Symbol") + ((list? v) "Array") + ((and (dict? v) (has-key? v :type) (= (get v :type) "st-instance")) + (get v :class)) + ((and (dict? v) (has-key? v :type) (= (get v :type) "block")) + "BlockClosure") + ((and (dict? v) (has-key? v :st-block?) (get v :st-block?)) + "BlockClosure") + ((dict? v) "Dictionary") + ((lambda? v) "BlockClosure") + (else "Object")))) + +;; Construct a fresh instance of cls-name. Ivars (own + inherited) start as nil. +(define + st-make-instance + (fn + (cls-name) + (cond + ((not (st-class-exists? cls-name)) + (error (str "st-make-instance: unknown class " cls-name))) + (else + (let + ((iv-names (st-class-all-ivars cls-name)) (ivars {})) + (begin + (for-each (fn (n) (set! ivars (assoc ivars n nil))) iv-names) + {:type "st-instance" :class cls-name :ivars ivars})))))) + +(define + st-instance? + (fn + (v) + (and (dict? v) (has-key? v :type) (= (get v :type) "st-instance")))) + +(define + st-iv-get + (fn + (inst name) + (let ((ivs (get inst :ivars))) + (if (has-key? ivs name) (get ivs name) nil)))) + +(define + st-iv-set! + (fn + (inst name value) + (let + ((new-ivars (assoc (get inst :ivars) name value))) + (assoc inst :ivars new-ivars)))) + +;; Inherits-from check: is `descendant` either equal to `ancestor` or a subclass? +(define + st-class-inherits-from? + (fn + (descendant ancestor) + (let ((found false) (cur descendant)) + (begin + (define + ih-loop + (fn + () + (when + (and (not found) (not (= cur nil)) (st-class-exists? cur)) + (cond + ((= cur ancestor) (set! found true)) + (else + (begin + (set! cur (st-class-superclass cur)) + (ih-loop))))))) + (ih-loop) + found)))) + +;; Bootstrap the canonical class hierarchy. Reset and rebuild. +(define + st-bootstrap-classes! + (fn + () + (begin + (st-class-table-clear!) + ;; Root + (st-class-define! "Object" nil (list)) + ;; Class side machinery + (st-class-define! "Behavior" "Object" (list "superclass" "methodDict" "format")) + (st-class-define! "ClassDescription" "Behavior" (list "instanceVariables" "organization")) + (st-class-define! "Class" "ClassDescription" (list "name" "subclasses")) + (st-class-define! "Metaclass" "ClassDescription" (list "thisClass")) + ;; Pseudo-variable types + (st-class-define! "UndefinedObject" "Object" (list)) + (st-class-define! "Boolean" "Object" (list)) + (st-class-define! "True" "Boolean" (list)) + (st-class-define! "False" "Boolean" (list)) + ;; Magnitudes + (st-class-define! "Magnitude" "Object" (list)) + (st-class-define! "Number" "Magnitude" (list)) + (st-class-define! "Integer" "Number" (list)) + (st-class-define! "SmallInteger" "Integer" (list)) + (st-class-define! "LargePositiveInteger" "Integer" (list)) + (st-class-define! "Float" "Number" (list)) + (st-class-define! "Fraction" "Number" (list "numerator" "denominator")) + (st-class-define! "Character" "Magnitude" (list "value")) + ;; Collections + (st-class-define! "Collection" "Object" (list)) + (st-class-define! "SequenceableCollection" "Collection" (list)) + (st-class-define! "ArrayedCollection" "SequenceableCollection" (list)) + (st-class-define! "Array" "ArrayedCollection" (list)) + (st-class-define! "String" "ArrayedCollection" (list)) + (st-class-define! "Symbol" "String" (list)) + (st-class-define! "OrderedCollection" "SequenceableCollection" (list "array" "firstIndex" "lastIndex")) + ;; Hashed collection family + (st-class-define! "HashedCollection" "Collection" (list "array")) + (st-class-define! "Set" "HashedCollection" (list)) + ;; Blocks / contexts + (st-class-define! "BlockClosure" "Object" (list)) + ;; Reflection support — Message holds the selector/args for a DNU send. + (st-class-define! "Message" "Object" (list "selector" "arguments")) + (st-class-add-method! "Message" "selector" + (st-parse-method "selector ^ selector")) + (st-class-add-method! "Message" "arguments" + (st-parse-method "arguments ^ arguments")) + (st-class-add-method! "Message" "selector:" + (st-parse-method "selector: aSym selector := aSym")) + (st-class-add-method! "Message" "arguments:" + (st-parse-method "arguments: anArray arguments := anArray")) + ;; Exception hierarchy — Smalltalk's standard error system on top of + ;; SX's `guard`/`raise`. Subclassing Exception gives you on:do:, + ;; ensure:, ifCurtailed: catching out of the box. + (st-class-define! "Exception" "Object" (list "messageText")) + (st-class-add-method! "Exception" "messageText" + (st-parse-method "messageText ^ messageText")) + (st-class-add-method! "Exception" "messageText:" + (st-parse-method "messageText: aString messageText := aString. ^ self")) + (st-class-define! "Error" "Exception" (list)) + (st-class-define! "ZeroDivide" "Error" (list)) + (st-class-define! "MessageNotUnderstood" "Error" (list)) + ;; SequenceableCollection — shared iteration / inspection methods. + ;; Defined on the parent class so Array, String, Symbol, and + ;; OrderedCollection all inherit. Each method calls `self do:`, + ;; which dispatches to the receiver's primitive do: implementation. + (st-class-add-method! "SequenceableCollection" "inject:into:" + (st-parse-method + "inject: initial into: aBlock + | acc | + acc := initial. + self do: [:e | acc := aBlock value: acc value: e]. + ^ acc")) + (st-class-add-method! "SequenceableCollection" "detect:" + (st-parse-method + "detect: aBlock + self do: [:e | (aBlock value: e) ifTrue: [^ e]]. + ^ nil")) + (st-class-add-method! "SequenceableCollection" "detect:ifNone:" + (st-parse-method + "detect: aBlock ifNone: noneBlock + self do: [:e | (aBlock value: e) ifTrue: [^ e]]. + ^ noneBlock value")) + (st-class-add-method! "SequenceableCollection" "count:" + (st-parse-method + "count: aBlock + | n | + n := 0. + self do: [:e | (aBlock value: e) ifTrue: [n := n + 1]]. + ^ n")) + (st-class-add-method! "SequenceableCollection" "allSatisfy:" + (st-parse-method + "allSatisfy: aBlock + self do: [:e | (aBlock value: e) ifFalse: [^ false]]. + ^ true")) + (st-class-add-method! "SequenceableCollection" "anySatisfy:" + (st-parse-method + "anySatisfy: aBlock + self do: [:e | (aBlock value: e) ifTrue: [^ true]]. + ^ false")) + (st-class-add-method! "SequenceableCollection" "includes:" + (st-parse-method + "includes: target + self do: [:e | e = target ifTrue: [^ true]]. + ^ false")) + (st-class-add-method! "SequenceableCollection" "do:separatedBy:" + (st-parse-method + "do: aBlock separatedBy: sepBlock + | first | + first := true. + self do: [:e | + first ifFalse: [sepBlock value]. + first := false. + aBlock value: e]. + ^ self")) + (st-class-add-method! "SequenceableCollection" "indexOf:" + (st-parse-method + "indexOf: target + | idx | + idx := 1. + self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1]. + ^ 0")) + (st-class-add-method! "SequenceableCollection" "indexOf:ifAbsent:" + (st-parse-method + "indexOf: target ifAbsent: noneBlock + | idx | + idx := 1. + self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1]. + ^ noneBlock value")) + (st-class-add-method! "SequenceableCollection" "reject:" + (st-parse-method + "reject: aBlock ^ self select: [:e | (aBlock value: e) not]")) + (st-class-add-method! "SequenceableCollection" "isEmpty" + (st-parse-method "isEmpty ^ self size = 0")) + (st-class-add-method! "SequenceableCollection" "notEmpty" + (st-parse-method "notEmpty ^ self size > 0")) + ;; (no asString here — Symbol/String have their own primitive + ;; impls; SequenceableCollection-level fallback would overwrite + ;; the bare-name-for-Symbol behaviour.) + ;; Array class-side constructors for small fixed-arity literals. + (st-class-add-class-method! "Array" "with:" + (st-parse-method + "with: x | a | a := Array new: 1. a at: 1 put: x. ^ a")) + (st-class-add-class-method! "Array" "with:with:" + (st-parse-method + "with: a with: b + | r | r := Array new: 2. + r at: 1 put: a. r at: 2 put: b. ^ r")) + (st-class-add-class-method! "Array" "with:with:with:" + (st-parse-method + "with: a with: b with: c + | r | r := Array new: 3. + r at: 1 put: a. r at: 2 put: b. r at: 3 put: c. ^ r")) + (st-class-add-class-method! "Array" "with:with:with:with:" + (st-parse-method + "with: a with: b with: c with: d + | r | r := Array new: 4. + r at: 1 put: a. r at: 2 put: b. r at: 3 put: c. r at: 4 put: d. ^ r")) + ;; ── HashedCollection / Set / Dictionary ── + ;; Implemented as user instances with array-backed storage. Sets + ;; use a single `array` ivar; Dictionaries use parallel `keys`/ + ;; `values` arrays. New is class-side and routes through `init`. + (st-class-add-method! "HashedCollection" "init" + (st-parse-method "init array := Array new: 0. ^ self")) + (st-class-add-method! "HashedCollection" "size" + (st-parse-method "size ^ array size")) + (st-class-add-method! "HashedCollection" "isEmpty" + (st-parse-method "isEmpty ^ array isEmpty")) + (st-class-add-method! "HashedCollection" "notEmpty" + (st-parse-method "notEmpty ^ array notEmpty")) + (st-class-add-method! "HashedCollection" "do:" + (st-parse-method "do: aBlock array do: aBlock. ^ self")) + (st-class-add-method! "HashedCollection" "asArray" + (st-parse-method "asArray ^ array")) + (st-class-add-class-method! "Set" "new" + (st-parse-method "new ^ super new init")) + (st-class-add-method! "Set" "add:" + (st-parse-method + "add: anObject + (self includes: anObject) ifFalse: [array add: anObject]. + ^ anObject")) + (st-class-add-method! "Set" "addAll:" + (st-parse-method + "addAll: aCollection + aCollection do: [:e | self add: e]. + ^ aCollection")) + (st-class-add-method! "Set" "remove:" + (st-parse-method + "remove: anObject + array := array reject: [:e | e = anObject]. + ^ anObject")) + (st-class-add-method! "Set" "includes:" + (st-parse-method "includes: anObject ^ array includes: anObject")) + (st-class-define! "Dictionary" "HashedCollection" (list "keys" "values")) + (st-class-add-class-method! "Dictionary" "new" + (st-parse-method "new ^ super new init")) + (st-class-add-method! "Dictionary" "init" + (st-parse-method + "init keys := Array new: 0. values := Array new: 0. ^ self")) + (st-class-add-method! "Dictionary" "size" + (st-parse-method "size ^ keys size")) + (st-class-add-method! "Dictionary" "isEmpty" + (st-parse-method "isEmpty ^ keys isEmpty")) + (st-class-add-method! "Dictionary" "notEmpty" + (st-parse-method "notEmpty ^ keys notEmpty")) + (st-class-add-method! "Dictionary" "keys" + (st-parse-method "keys ^ keys")) + (st-class-add-method! "Dictionary" "values" + (st-parse-method "values ^ values")) + (st-class-add-method! "Dictionary" "at:" + (st-parse-method + "at: aKey + | i | + i := keys indexOf: aKey. + i = 0 ifTrue: [^ nil]. + ^ values at: i")) + (st-class-add-method! "Dictionary" "at:ifAbsent:" + (st-parse-method + "at: aKey ifAbsent: aBlock + | i | + i := keys indexOf: aKey. + i = 0 ifTrue: [^ aBlock value]. + ^ values at: i")) + (st-class-add-method! "Dictionary" "at:put:" + (st-parse-method + "at: aKey put: aValue + | i | + i := keys indexOf: aKey. + i = 0 + ifTrue: [keys add: aKey. values add: aValue] + ifFalse: [values at: i put: aValue]. + ^ aValue")) + (st-class-add-method! "Dictionary" "includesKey:" + (st-parse-method "includesKey: aKey ^ (keys indexOf: aKey) > 0")) + (st-class-add-method! "Dictionary" "removeKey:" + (st-parse-method + "removeKey: aKey + | i nk nv j | + i := keys indexOf: aKey. + i = 0 ifTrue: [^ nil]. + nk := Array new: 0. nv := Array new: 0. + j := 1. + [j <= keys size] whileTrue: [ + j = i ifFalse: [ + nk add: (keys at: j). + nv add: (values at: j)]. + j := j + 1]. + keys := nk. values := nv. + ^ aKey")) + (st-class-add-method! "Dictionary" "do:" + (st-parse-method "do: aBlock values do: aBlock. ^ self")) + (st-class-add-method! "Dictionary" "keysDo:" + (st-parse-method "keysDo: aBlock keys do: aBlock. ^ self")) + (st-class-add-method! "Dictionary" "valuesDo:" + (st-parse-method "valuesDo: aBlock values do: aBlock. ^ self")) + (st-class-add-method! "Dictionary" "keysAndValuesDo:" + (st-parse-method + "keysAndValuesDo: aBlock + | i | + i := 1. + [i <= keys size] whileTrue: [ + aBlock value: (keys at: i) value: (values at: i). + i := i + 1]. + ^ self")) + (st-class-define! "IdentityDictionary" "Dictionary" (list)) + ;; ── Stream hierarchy ── + ;; Streams wrap a collection with a 0-based `position`. Read/peek + ;; advance via `at:` (1-indexed Smalltalk-style) on the collection. + ;; Write streams require a mutable collection (Array works; String + ;; doesn't, see Phase 5 follow-up). + (st-class-define! "Stream" "Object" (list)) + (st-class-define! "PositionableStream" "Stream" (list "collection" "position")) + (st-class-define! "ReadStream" "PositionableStream" (list)) + (st-class-define! "WriteStream" "PositionableStream" (list)) + (st-class-define! "ReadWriteStream" "WriteStream" (list)) + (st-class-add-class-method! "ReadStream" "on:" + (st-parse-method "on: aColl ^ super new on: aColl")) + (st-class-add-class-method! "WriteStream" "on:" + (st-parse-method "on: aColl ^ super new on: aColl")) + (st-class-add-class-method! "WriteStream" "with:" + (st-parse-method + "with: aColl + | s | + s := super new on: aColl. + s setToEnd. + ^ s")) + (st-class-add-class-method! "ReadWriteStream" "on:" + (st-parse-method "on: aColl ^ super new on: aColl")) + (st-class-add-method! "PositionableStream" "on:" + (st-parse-method + "on: aColl collection := aColl. position := 0. ^ self")) + (st-class-add-method! "PositionableStream" "atEnd" + (st-parse-method "atEnd ^ position >= collection size")) + (st-class-add-method! "PositionableStream" "position" + (st-parse-method "position ^ position")) + (st-class-add-method! "PositionableStream" "position:" + (st-parse-method "position: n position := n. ^ self")) + (st-class-add-method! "PositionableStream" "reset" + (st-parse-method "reset position := 0. ^ self")) + (st-class-add-method! "PositionableStream" "setToEnd" + (st-parse-method "setToEnd position := collection size. ^ self")) + (st-class-add-method! "PositionableStream" "contents" + (st-parse-method "contents ^ collection")) + (st-class-add-method! "PositionableStream" "skip:" + (st-parse-method "skip: n position := position + n. ^ self")) + (st-class-add-method! "ReadStream" "next" + (st-parse-method + "next + self atEnd ifTrue: [^ nil]. + position := position + 1. + ^ collection at: position")) + (st-class-add-method! "ReadStream" "peek" + (st-parse-method + "peek + self atEnd ifTrue: [^ nil]. + ^ collection at: position + 1")) + (st-class-add-method! "ReadStream" "upToEnd" + (st-parse-method + "upToEnd + | result | + result := Array new: 0. + [self atEnd] whileFalse: [result add: self next]. + ^ result")) + (st-class-add-method! "ReadStream" "next:" + (st-parse-method + "next: n + | result i | + result := Array new: 0. + i := 0. + [(i < n) and: [self atEnd not]] whileTrue: [ + result add: self next. + i := i + 1]. + ^ result")) + (st-class-add-method! "WriteStream" "nextPut:" + (st-parse-method + "nextPut: anObject + collection add: anObject. + position := position + 1. + ^ anObject")) + (st-class-add-method! "WriteStream" "nextPutAll:" + (st-parse-method + "nextPutAll: aCollection + aCollection do: [:e | self nextPut: e]. + ^ aCollection")) + ;; ReadWriteStream inherits from WriteStream + ReadStream behaviour; + ;; for the simple linear-position model, both nextPut: and next work. + (st-class-add-method! "ReadWriteStream" "next" + (st-parse-method + "next + self atEnd ifTrue: [^ nil]. + position := position + 1. + ^ collection at: position")) + (st-class-add-method! "ReadWriteStream" "peek" + (st-parse-method + "peek + self atEnd ifTrue: [^ nil]. + ^ collection at: position + 1")) + ;; ── Fraction ── + ;; Rational numbers stored as numerator/denominator, normalized + ;; (sign on numerator, denominator > 0, reduced via gcd). + (st-class-add-class-method! "Fraction" "numerator:denominator:" + (st-parse-method + "numerator: n denominator: d + | f | + f := super new. + ^ f setNumerator: n denominator: d")) + (st-class-add-method! "Fraction" "setNumerator:denominator:" + (st-parse-method + "setNumerator: n denominator: d + | g s nn dd | + d = 0 ifTrue: [Error signal: 'Fraction denominator cannot be zero']. + s := (d < 0) ifTrue: [-1] ifFalse: [1]. + nn := n * s. dd := d * s. + g := nn abs gcd: dd. + g = 0 ifTrue: [g := 1]. + numerator := nn / g. + denominator := dd / g. + ^ self")) + (st-class-add-method! "Fraction" "numerator" + (st-parse-method "numerator ^ numerator")) + (st-class-add-method! "Fraction" "denominator" + (st-parse-method "denominator ^ denominator")) + (st-class-add-method! "Fraction" "+" + (st-parse-method + "+ other + ^ Fraction + numerator: numerator * other denominator + (other numerator * denominator) + denominator: denominator * other denominator")) + (st-class-add-method! "Fraction" "-" + (st-parse-method + "- other + ^ Fraction + numerator: numerator * other denominator - (other numerator * denominator) + denominator: denominator * other denominator")) + (st-class-add-method! "Fraction" "*" + (st-parse-method + "* other + ^ Fraction + numerator: numerator * other numerator + denominator: denominator * other denominator")) + (st-class-add-method! "Fraction" "/" + (st-parse-method + "/ other + ^ Fraction + numerator: numerator * other denominator + denominator: denominator * other numerator")) + (st-class-add-method! "Fraction" "negated" + (st-parse-method + "negated ^ Fraction numerator: numerator negated denominator: denominator")) + (st-class-add-method! "Fraction" "reciprocal" + (st-parse-method + "reciprocal ^ Fraction numerator: denominator denominator: numerator")) + (st-class-add-method! "Fraction" "=" + (st-parse-method + "= other + ^ numerator = other numerator and: [denominator = other denominator]")) + (st-class-add-method! "Fraction" "<" + (st-parse-method + "< other + ^ numerator * other denominator < (other numerator * denominator)")) + (st-class-add-method! "Fraction" "asFloat" + (st-parse-method "asFloat ^ numerator / denominator")) + (st-class-add-method! "Fraction" "printString" + (st-parse-method + "printString ^ numerator printString , '/' , denominator printString")) + (st-class-add-method! "Fraction" "isFraction" + (st-parse-method "isFraction ^ true")) + "ok"))) + +;; Initialise on load. Tests can re-bootstrap to reset state. +(st-bootstrap-classes!) diff --git a/lib/smalltalk/scoreboard.json b/lib/smalltalk/scoreboard.json new file mode 100644 index 00000000..a9149955 --- /dev/null +++ b/lib/smalltalk/scoreboard.json @@ -0,0 +1,15 @@ +{ + "date": "2026-04-25T16:05:32Z", + "programs": [ + "eight-queens.st", + "fibonacci.st", + "life.st", + "mandelbrot.st", + "quicksort.st" + ], + "program_count": 5, + "program_tests_passed": 39, + "all_tests_passed": 847, + "all_tests_total": 847, + "exit_code": 0 +} diff --git a/lib/smalltalk/scoreboard.md b/lib/smalltalk/scoreboard.md new file mode 100644 index 00000000..d479a276 --- /dev/null +++ b/lib/smalltalk/scoreboard.md @@ -0,0 +1,56 @@ +# Smalltalk-on-SX Scoreboard + +_Last run: 2026-04-25T16:05:32Z_ + +## Totals + +| Suite | Passing | +|-------|---------| +| All Smalltalk-on-SX tests | **847 / 847** | +| Classic-corpus tests (`tests/programs.sx`) | **39** | + +## Classic-corpus programs (`lib/smalltalk/tests/programs/`) + +| Program | Status | +|---------|--------| +| `eight-queens.st` | present | +| `fibonacci.st` | present | +| `life.st` | present | +| `mandelbrot.st` | present | +| `quicksort.st` | present | + +## Per-file test counts + +``` +OK lib/smalltalk/tests/ansi.sx 62 passed +OK lib/smalltalk/tests/blocks.sx 19 passed +OK lib/smalltalk/tests/cannot_return.sx 5 passed +OK lib/smalltalk/tests/collections.sx 29 passed +OK lib/smalltalk/tests/conditional.sx 25 passed +OK lib/smalltalk/tests/dnu.sx 15 passed +OK lib/smalltalk/tests/eval.sx 68 passed +OK lib/smalltalk/tests/exceptions.sx 15 passed +OK lib/smalltalk/tests/hashed.sx 30 passed +OK lib/smalltalk/tests/inline_cache.sx 10 passed +OK lib/smalltalk/tests/intrinsics.sx 24 passed +OK lib/smalltalk/tests/nlr.sx 14 passed +OK lib/smalltalk/tests/numbers.sx 47 passed +OK lib/smalltalk/tests/parse_chunks.sx 21 passed +OK lib/smalltalk/tests/parse.sx 47 passed +OK lib/smalltalk/tests/pharo.sx 91 passed +OK lib/smalltalk/tests/printing.sx 19 passed +OK lib/smalltalk/tests/programs.sx 39 passed +OK lib/smalltalk/tests/reflection.sx 77 passed +OK lib/smalltalk/tests/runtime.sx 64 passed +OK lib/smalltalk/tests/streams.sx 21 passed +OK lib/smalltalk/tests/sunit.sx 19 passed +OK lib/smalltalk/tests/super.sx 9 passed +OK lib/smalltalk/tests/tokenize.sx 63 passed +OK lib/smalltalk/tests/while.sx 14 passed +``` + +## Notes + +- The spec interpreter is correct but slow (call/cc + dict-based ivars per send). +- Larger Life multi-step verification, the 8-queens canonical case, and the glider-gun pattern are deferred to the JIT path. +- Generated by `bash lib/smalltalk/conformance.sh`. Both files are committed; the runner overwrites them on each run. diff --git a/lib/smalltalk/sunit.sx b/lib/smalltalk/sunit.sx new file mode 100644 index 00000000..50c5c862 --- /dev/null +++ b/lib/smalltalk/sunit.sx @@ -0,0 +1,153 @@ +;; SUnit — minimal port written in SX-Smalltalk, run by smalltalk-load. +;; +;; Provides: +;; TestCase — base class. Subclass it, add `testSomething` methods. +;; TestSuite — a collection of TestCase instances; runs them all. +;; TestResult — passes / failures / errors counts and lists. +;; TestFailure — Error subclass raised by `assert:` and friends. +;; +;; Conventions: +;; - Test methods are run in a fresh instance per test. +;; - `setUp` is sent before each test; `tearDown` after. +;; - Failures are signalled by TestFailure; runner catches and records. + +(define + st-sunit-source + "Error subclass: #TestFailure + instanceVariableNames: ''! + + Object subclass: #TestCase + instanceVariableNames: 'testSelector'! + + !TestCase methodsFor: 'access'! + testSelector ^ testSelector! + testSelector: aSym testSelector := aSym. ^ self! ! + + !TestCase methodsFor: 'fixture'! + setUp ^ self! + tearDown ^ self! ! + + !TestCase methodsFor: 'asserts'! + assert: aBoolean + aBoolean ifFalse: [TestFailure signal: 'assertion failed']. + ^ self! + + assert: aBoolean description: aString + aBoolean ifFalse: [TestFailure signal: aString]. + ^ self! + + assert: actual equals: expected + actual = expected ifFalse: [ + TestFailure signal: 'expected ' , expected printString + , ' but got ' , actual printString]. + ^ self! + + deny: aBoolean + aBoolean ifTrue: [TestFailure signal: 'denial failed']. + ^ self! + + should: aBlock raise: anExceptionClass + | raised | + raised := false. + [aBlock value] on: anExceptionClass do: [:e | raised := true]. + raised ifFalse: [ + TestFailure signal: 'expected exception ' , anExceptionClass name + , ' was not raised']. + ^ self! + + shouldnt: aBlock raise: anExceptionClass + | raised | + raised := false. + [aBlock value] on: anExceptionClass do: [:e | raised := true]. + raised ifTrue: [ + TestFailure signal: 'unexpected exception ' , anExceptionClass name]. + ^ self! ! + + !TestCase methodsFor: 'running'! + runCase + self setUp. + self perform: testSelector. + self tearDown. + ^ self! ! + + !TestCase class methodsFor: 'instantiation'! + selector: aSym ^ self new testSelector: aSym! + + suiteForAll: aSelectorArray + | suite | + suite := TestSuite new init. + suite name: self name. + aSelectorArray do: [:s | suite addTest: (self selector: s)]. + ^ suite! ! + + Object subclass: #TestResult + instanceVariableNames: 'passes failures errors'! + + !TestResult methodsFor: 'init'! + init + passes := Array new: 0. + failures := Array new: 0. + errors := Array new: 0. + ^ self! ! + + !TestResult methodsFor: 'access'! + passes ^ passes! + failures ^ failures! + errors ^ errors! + passCount ^ passes size! + failureCount ^ failures size! + errorCount ^ errors size! + totalCount ^ passes size + failures size + errors size! + + addPass: aTest passes add: aTest. ^ self! + addFailure: aTest message: aMsg + | rec | + rec := Array new: 2. + rec at: 1 put: aTest. rec at: 2 put: aMsg. + failures add: rec. + ^ self! + addError: aTest message: aMsg + | rec | + rec := Array new: 2. + rec at: 1 put: aTest. rec at: 2 put: aMsg. + errors add: rec. + ^ self! + + isEmpty ^ self totalCount = 0! + allPassed ^ (failures size + errors size) = 0! + + summary + ^ 'Tests: {1} Passed: {2} Failed: {3} Errors: {4}' + format: (Array + with: self totalCount printString + with: passes size printString + with: failures size printString + with: errors size printString)! ! + + Object subclass: #TestSuite + instanceVariableNames: 'tests name'! + + !TestSuite methodsFor: 'init'! + init tests := Array new: 0. name := 'Suite'. ^ self! + name ^ name! + name: aString name := aString. ^ self! ! + + !TestSuite methodsFor: 'tests'! + tests ^ tests! + addTest: aTest tests add: aTest. ^ self! + addAll: aCollection aCollection do: [:t | self addTest: t]. ^ self! + size ^ tests size! ! + + !TestSuite methodsFor: 'running'! + run + | result | + result := TestResult new init. + tests do: [:t | self runTest: t result: result]. + ^ result! + + runTest: aTest result: aResult + [aTest runCase. aResult addPass: aTest] + on: TestFailure do: [:e | aResult addFailure: aTest message: e messageText]. + ^ self! !") + +(smalltalk-load st-sunit-source) diff --git a/lib/smalltalk/test.sh b/lib/smalltalk/test.sh new file mode 100755 index 00000000..ce782993 --- /dev/null +++ b/lib/smalltalk/test.sh @@ -0,0 +1,145 @@ +#!/usr/bin/env bash +# Fast Smalltalk-on-SX test runner — pipes directly to sx_server.exe. +# Mirrors lib/haskell/test.sh. +# +# Usage: +# bash lib/smalltalk/test.sh # run all tests +# bash lib/smalltalk/test.sh -v # verbose +# bash lib/smalltalk/test.sh tests/tokenize.sx # run one file + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe" +if [ ! -x "$SX_SERVER" ]; then + MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}') + if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then + SX_SERVER="$MAIN_ROOT/$SX_SERVER" + else + echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build" + exit 1 + fi +fi + +VERBOSE="" +FILES=() +for arg in "$@"; do + case "$arg" in + -v|--verbose) VERBOSE=1 ;; + *) FILES+=("$arg") ;; + esac +done + +if [ ${#FILES[@]} -eq 0 ]; then + # tokenize.sx must load first — it defines the st-test helpers reused by + # subsequent test files. Sort enforces this lexicographically. + mapfile -t FILES < <(find lib/smalltalk/tests -maxdepth 2 -name '*.sx' | sort) +fi + +TOTAL_PASS=0 +TOTAL_FAIL=0 +FAILED_FILES=() + +for FILE in "${FILES[@]}"; do + [ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; } + TMPFILE=$(mktemp) + if [ "$(basename "$FILE")" = "tokenize.sx" ]; then + cat > "$TMPFILE" < "$TMPFILE" <&1 || true) + rm -f "$TMPFILE" + + # Final epoch's value: either (ok N (P F)) on one line or + # (ok-len N M)\n(P F) where the value is on the following line. + LINE=$(echo "$OUTPUT" | awk '/^\(ok-len [0-9]+ / {getline; print}' | tail -1) + if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok [0-9]+ \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok [0-9]+ //; s/\)$//') + fi + if [ -z "$LINE" ]; then + echo "X $FILE: could not extract summary" + echo "$OUTPUT" | tail -30 + TOTAL_FAIL=$((TOTAL_FAIL + 1)) + FAILED_FILES+=("$FILE") + continue + fi + P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/') + F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/') + TOTAL_PASS=$((TOTAL_PASS + P)) + TOTAL_FAIL=$((TOTAL_FAIL + F)) + if [ "$F" -gt 0 ]; then + FAILED_FILES+=("$FILE") + printf 'X %-40s %d/%d\n' "$FILE" "$P" "$((P+F))" + TMPFILE2=$(mktemp) + if [ "$(basename "$FILE")" = "tokenize.sx" ]; then + cat > "$TMPFILE2" < "$TMPFILE2" <&1 | grep -E '^\(ok [0-9]+ \(' | tail -1 || true) + rm -f "$TMPFILE2" + echo " $FAILS" + elif [ "$VERBOSE" = "1" ]; then + printf 'OK %-40s %d passed\n' "$FILE" "$P" + fi +done + +TOTAL=$((TOTAL_PASS + TOTAL_FAIL)) +if [ $TOTAL_FAIL -eq 0 ]; then + echo "OK $TOTAL_PASS/$TOTAL smalltalk-on-sx tests passed" +else + echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed in: ${FAILED_FILES[*]}" +fi + +[ $TOTAL_FAIL -eq 0 ] diff --git a/lib/smalltalk/tests/ansi.sx b/lib/smalltalk/tests/ansi.sx new file mode 100644 index 00000000..a1863ad1 --- /dev/null +++ b/lib/smalltalk/tests/ansi.sx @@ -0,0 +1,158 @@ +;; ANSI X3J20 Smalltalk validator — stretch subset. +;; +;; Targets the mandatory protocols documented in the standard; one test +;; case per ANSI §6.x category. Test methods are run through the SUnit +;; framework; one st-test row per Smalltalk method (mirrors tests/pharo.sx). + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(define + ansi-source + "TestCase subclass: #AnsiObjectTest instanceVariableNames: ''! + + !AnsiObjectTest methodsFor: '6.10 Object'! + testIdentity self assert: 42 == 42! + testIdentityNotEq self deny: 'a' == 'b'! + testEqualityIsAlsoIdentityOnInts self assert: 7 = 7! + testNotEqual self assert: (1 ~= 2)! + testIsNilOnNil self assert: nil isNil! + testIsNilOnInt self deny: 1 isNil! + testNotNil self assert: 42 notNil! + testClass self assert: 42 class = SmallInteger! + testYourself + | x | x := 99. + self assert: x yourself equals: 99! ! + + TestCase subclass: #AnsiBooleanTest instanceVariableNames: ''! + + !AnsiBooleanTest methodsFor: '6.11 Boolean'! + testNot self assert: true not equals: false! + testAndTT self assert: (true & true)! + testAndTF self deny: (true & false)! + testAndFT self deny: (false & true)! + testAndFF self deny: (false & false)! + testOrTT self assert: (true | true)! + testOrTF self assert: (true | false)! + testOrFT self assert: (false | true)! + testOrFF self deny: (false | false)! + testIfTrueTaken self assert: (true ifTrue: [1] ifFalse: [2]) equals: 1! + testIfFalseTaken self assert: (false ifTrue: [1] ifFalse: [2]) equals: 2! + testAndShort self assert: (false and: [1/0]) equals: false! + testOrShort self assert: (true or: [1/0]) equals: true! ! + + TestCase subclass: #AnsiIntegerTest instanceVariableNames: ''! + + !AnsiIntegerTest methodsFor: '6.13 Integer'! + testFactorial self assert: 6 factorial equals: 720! + testGcd self assert: (12 gcd: 18) equals: 6! + testLcm self assert: (4 lcm: 6) equals: 12! + testEven self assert: 8 even! + testOdd self assert: 9 odd! + testNegated self assert: 5 negated equals: -5! + testAbs self assert: -7 abs equals: 7! ! + + !AnsiIntegerTest methodsFor: '6.12 Number arithmetic'! + testAdd self assert: 1 + 2 equals: 3! + testSub self assert: 10 - 4 equals: 6! + testMul self assert: 6 * 7 equals: 42! + testMin self assert: (3 min: 7) equals: 3! + testMax self assert: (3 max: 7) equals: 7! + testBetween self assert: (5 between: 1 and: 10)! ! + + TestCase subclass: #AnsiStringTest instanceVariableNames: ''! + + !AnsiStringTest methodsFor: '6.17 String'! + testSize self assert: 'abcdef' size equals: 6! + testConcat self assert: ('foo' , 'bar') equals: 'foobar'! + testAt self assert: ('abcd' at: 3) equals: 'c'! + testCopyFromTo self assert: ('helloworld' copyFrom: 1 to: 5) equals: 'hello'! + testAsSymbol self assert: 'foo' asSymbol == #foo! + testIsEmpty self assert: '' isEmpty! ! + + TestCase subclass: #AnsiArrayTest instanceVariableNames: ''! + + !AnsiArrayTest methodsFor: '6.18 Array'! + testSize self assert: #(1 2 3) size equals: 3! + testAt self assert: (#(10 20 30) at: 2) equals: 20! + testAtPut + | a | + a := Array new: 3. + a at: 1 put: 100. + self assert: (a at: 1) equals: 100! + testDo + | s | + s := 0. + #(1 2 3) do: [:e | s := s + e]. + self assert: s equals: 6! + testCollect self assert: (#(1 2 3) collect: [:x | x + 10]) equals: #(11 12 13)! + testSelect self assert: (#(1 2 3 4) select: [:x | x even]) equals: #(2 4)! + testReject self assert: (#(1 2 3 4) reject: [:x | x even]) equals: #(1 3)! + testInject self assert: (#(1 2 3 4 5) inject: 0 into: [:a :b | a + b]) equals: 15! + testIncludes self assert: (#(1 2 3) includes: 2)! + testFirst self assert: #(7 8 9) first equals: 7! + testLast self assert: #(7 8 9) last equals: 9! ! + + TestCase subclass: #AnsiBlockTest instanceVariableNames: ''! + + !AnsiBlockTest methodsFor: '6.19 BlockContext'! + testValue self assert: [42] value equals: 42! + testValueOne self assert: ([:x | x * 2] value: 21) equals: 42! + testValueTwo self assert: ([:a :b | a + b] value: 3 value: 4) equals: 7! + testNumArgs self assert: [:a :b | a] numArgs equals: 2! + testValueWithArguments + self assert: ([:a :b | a , b] valueWithArguments: #('foo' 'bar')) equals: 'foobar'! + testWhileTrue + | n | + n := 5. + [n > 0] whileTrue: [n := n - 1]. + self assert: n equals: 0! + testEnsureRunsOnNormal + | log | + log := Array new: 0. + [log add: #body] ensure: [log add: #cleanup]. + self assert: log size equals: 2! + testOnDoCatchesError + | r | + r := [Error signal: 'boom'] on: Error do: [:e | e messageText]. + self assert: r equals: 'boom'! ! + + TestCase subclass: #AnsiSymbolTest instanceVariableNames: ''! + + !AnsiSymbolTest methodsFor: '6.16 Symbol'! + testEqual self assert: #foo = #foo! + testIdentity self assert: #bar == #bar! + testNotEq self deny: #a == #b! !") + +(smalltalk-load ansi-source) + +(define + pharo-test-class + (fn + (cls-name) + (let ((selectors (sort (keys (get (st-class-get cls-name) :methods))))) + (for-each + (fn (sel) + (when + (and (>= (len sel) 4) (= (slice sel 0 4) "test")) + (let + ((src (str "| s r | s := " cls-name " suiteForAll: #(#" + sel "). r := s run. + ^ {(r passCount). (r failureCount). (r errorCount)}"))) + (let ((result (smalltalk-eval-program src))) + (st-test + (str cls-name " >> " sel) + result + (list 1 0 0)))))) + selectors)))) + +(pharo-test-class "AnsiObjectTest") +(pharo-test-class "AnsiBooleanTest") +(pharo-test-class "AnsiIntegerTest") +(pharo-test-class "AnsiStringTest") +(pharo-test-class "AnsiArrayTest") +(pharo-test-class "AnsiBlockTest") +(pharo-test-class "AnsiSymbolTest") + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/blocks.sx b/lib/smalltalk/tests/blocks.sx new file mode 100644 index 00000000..7f7a323b --- /dev/null +++ b/lib/smalltalk/tests/blocks.sx @@ -0,0 +1,92 @@ +;; BlockContext>>value family tests. +;; +;; The runtime already implements value, value:, value:value:, value:value:value:, +;; value:value:value:value:, and valueWithArguments: in st-block-dispatch. +;; This file pins each variant down with explicit tests + closure semantics. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. The value/valueN family ── +(st-test "value: zero-arg block" (ev "[42] value") 42) +(st-test "value: one-arg block" (ev "[:a | a + 1] value: 10") 11) +(st-test "value:value: two-arg" (ev "[:a :b | a * b] value: 3 value: 4") 12) +(st-test "value:value:value: three" (ev "[:a :b :c | a + b + c] value: 1 value: 2 value: 3") 6) +(st-test "value:value:value:value: four" + (ev "[:a :b :c :d | a + b + c + d] value: 1 value: 2 value: 3 value: 4") 10) + +;; ── 2. valueWithArguments: ── +(st-test "valueWithArguments: zero-arg" + (ev "[99] valueWithArguments: #()") 99) +(st-test "valueWithArguments: one-arg" + (ev "[:x | x * x] valueWithArguments: #(7)") 49) +(st-test "valueWithArguments: many" + (ev "[:a :b :c | a , b , c] valueWithArguments: #('foo' '-' 'bar')") "foo-bar") + +;; ── 3. Block returns last expression ── +(st-test "block last-expression result" (ev "[1. 2. 3] value") 3) +(st-test "block with temps initial state" + (ev "[| t u | t := 5. u := t * 2. u] value") 10) + +;; ── 4. Closure over outer locals ── +(st-test + "block reads outer let temps" + (evp "| n | n := 5. ^ [n * n] value") + 25) +(st-test + "block writes outer locals (mutating)" + (evp "| n | n := 10. [:x | n := n + x] value: 5. ^ n") + 15) + +;; ── 5. Block sees later mutation of captured local ── +(st-test + "block re-reads outer local on each invocation" + (evp + "| n b r1 r2 | + n := 1. b := [n]. + r1 := b value. + n := 99. + r2 := b value. + ^ r1 + r2") + 100) + +;; ── 6. Re-entrant invocations ── +(st-test + "calling same block twice independent results" + (evp + "| sq | + sq := [:x | x * x]. + ^ (sq value: 3) + (sq value: 4)") + 25) + +;; ── 7. Nested blocks ── +(st-test + "nested block closes over both scopes" + (evp + "| a | + a := [:x | [:y | x + y]]. + ^ ((a value: 10) value: 5)") + 15) + +;; ── 8. Block as method argument ── +(st-class-define! "BlockUser" "Object" (list)) +(st-class-add-method! "BlockUser" "apply:to:" + (st-parse-method "apply: aBlock to: x ^ aBlock value: x")) + +(st-test + "method invokes block argument" + (evp "^ BlockUser new apply: [:n | n * n] to: 9") + 81) + +;; ── 9. numArgs + class ── +(st-test "numArgs zero" (ev "[] numArgs") 0) +(st-test "numArgs three" (ev "[:a :b :c | a] numArgs") 3) +(st-test "block class is BlockClosure" + (str (ev "[1] class name")) "BlockClosure") + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/cannot_return.sx b/lib/smalltalk/tests/cannot_return.sx new file mode 100644 index 00000000..e48baf59 --- /dev/null +++ b/lib/smalltalk/tests/cannot_return.sx @@ -0,0 +1,96 @@ +;; cannotReturn: tests — escape past a returned-from method must error. +;; +;; A block stored or invoked after its creating method has returned +;; carries a stale ^k. Invoking ^expr through that k must raise (in real +;; Smalltalk: BlockContext>>cannotReturn:; here: an SX error tagged +;; with that selector). A normal value-returning block (no ^) is fine. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; helper: substring check on actual SX strings +(define + str-contains? + (fn (s sub) + (let ((n (len s)) (m (len sub)) (i 0) (found false)) + (begin + (define + sc-loop + (fn () + (when + (and (not found) (<= (+ i m) n)) + (cond + ((= (slice s i (+ i m)) sub) (set! found true)) + (else (begin (set! i (+ i 1)) (sc-loop))))))) + (sc-loop) + found)))) + +;; ── 1. Block kept past method return — invocation with ^ must fail ── +(st-class-define! "BlockBox" "Object" (list "block")) +(st-class-add-method! "BlockBox" "block:" + (st-parse-method "block: aBlock block := aBlock. ^ self")) +(st-class-add-method! "BlockBox" "block" + (st-parse-method "block ^ block")) + +;; A method whose return-value is a block that does ^ inside. +;; Once `escapingBlock` returns, its ^k is dead. +(st-class-define! "Trapper" "Object" (list)) +(st-class-add-method! "Trapper" "stash" + (st-parse-method "stash | b | b := [^ #shouldNeverHappen]. ^ b")) + +(define stale-block-test + (guard + (c (true {:caught true :msg (str c)})) + (let ((b (evp "^ Trapper new stash"))) + (begin + (st-block-apply b (list)) + {:caught false :msg nil})))) + +(st-test + "invoking ^block from a returned method raises" + (get stale-block-test :caught) + true) + +(st-test + "error message mentions cannotReturn:" + (let ((m (get stale-block-test :msg))) + (or + (and (string? m) (> (len m) 0) (str-contains? m "cannotReturn")) + false)) + true) + +;; ── 2. A normal (non-^) block survives just fine across methods ── +(st-class-add-method! "Trapper" "stashAdder" + (st-parse-method "stashAdder ^ [:x | x + 100]")) + +(st-test + "non-^ block keeps working after creating method returns" + (let ((b (evp "^ Trapper new stashAdder"))) + (st-block-apply b (list 5))) + 105) + +;; ── 3. Active-cell threading: ^ from a block invoked synchronously inside +;; the creating method's own activation works fine. +(st-class-add-method! "Trapper" "syncFlow" + (st-parse-method "syncFlow #(1 2 3) do: [:e | e = 2 ifTrue: [^ #foundTwo]]. ^ #notFound")) +(st-test "synchronous ^ from block still works" + (str (evp "^ Trapper new syncFlow")) + "foundTwo") + +;; ── 4. Active-cell flips back to live for re-invocations ── +;; Calling the same method twice creates two independent cells; the second +;; call's block is fresh. +(st-class-add-method! "Trapper" "secondOK" + (st-parse-method "secondOK ^ #ok")) +(st-test "method called twice in sequence still works" + (let ((a (evp "^ Trapper new secondOK")) + (b (evp "^ Trapper new secondOK"))) + (str (str a b))) + "okok") + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/collections.sx b/lib/smalltalk/tests/collections.sx new file mode 100644 index 00000000..c4d5259b --- /dev/null +++ b/lib/smalltalk/tests/collections.sx @@ -0,0 +1,115 @@ +;; Phase 5 collection tests — methods on SequenceableCollection / Array / +;; String / Symbol. Emphasis on the inherited-from-SequenceableCollection +;; methods that work uniformly across Array, String, Symbol. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. inject:into: (fold) ── +(st-test "Array inject:into: sum" + (ev "#(1 2 3 4) inject: 0 into: [:a :b | a + b]") 10) + +(st-test "Array inject:into: product" + (ev "#(2 3 4) inject: 1 into: [:a :b | a * b]") 24) + +(st-test "Array inject:into: empty array → initial" + (ev "#() inject: 99 into: [:a :b | a + b]") 99) + +;; ── 2. detect: / detect:ifNone: ── +(st-test "detect: finds first match" + (ev "#(1 3 5 7) detect: [:x | x > 4]") 5) + +(st-test "detect: returns nil if no match" + (ev "#(1 2 3) detect: [:x | x > 10]") nil) + +(st-test "detect:ifNone: invokes block on miss" + (ev "#(1 2 3) detect: [:x | x > 10] ifNone: [#none]") + (make-symbol "none")) + +;; ── 3. count: ── +(st-test "count: matches" + (ev "#(1 2 3 4 5 6) count: [:x | x > 3]") 3) + +(st-test "count: zero matches" + (ev "#(1 2 3) count: [:x | x > 100]") 0) + +;; ── 4. allSatisfy: / anySatisfy: ── +(st-test "allSatisfy: when all match" + (ev "#(2 4 6) allSatisfy: [:x | x > 0]") true) + +(st-test "allSatisfy: when one fails" + (ev "#(2 4 -1) allSatisfy: [:x | x > 0]") false) + +(st-test "anySatisfy: when at least one matches" + (ev "#(1 2 3) anySatisfy: [:x | x > 2]") true) + +(st-test "anySatisfy: when none match" + (ev "#(1 2 3) anySatisfy: [:x | x > 100]") false) + +;; ── 5. includes: ── +(st-test "includes: found" (ev "#(1 2 3) includes: 2") true) +(st-test "includes: missing" (ev "#(1 2 3) includes: 99") false) + +;; ── 6. indexOf: / indexOf:ifAbsent: ── +(st-test "indexOf: returns 1-based index" + (ev "#(10 20 30 40) indexOf: 30") 3) + +(st-test "indexOf: missing returns 0" + (ev "#(1 2 3) indexOf: 99") 0) + +(st-test "indexOf:ifAbsent: invokes block" + (ev "#(1 2 3) indexOf: 99 ifAbsent: [-1]") -1) + +;; ── 7. reject: (complement of select:) ── +(st-test "reject: removes matching" + (ev "#(1 2 3 4 5) reject: [:x | x > 3]") + (list 1 2 3)) + +;; ── 8. do:separatedBy: ── +(st-test "do:separatedBy: builds joined sequence" + (evp + "| seen | + seen := #(). + #(1 2 3) do: [:e | seen := seen , (Array with: e)] + separatedBy: [seen := seen , #(0)]. + ^ seen") + (list 1 0 2 0 3)) + +;; Array with: shim for the test (inherited from earlier exception tests +;; in a separate suite — define here for safety). +(st-class-add-class-method! "Array" "with:" + (st-parse-method "with: x | a | a := Array new: 1. a at: 1 put: x. ^ a")) + +;; ── 9. String inherits the same methods ── +(st-test "String includes:" + (ev "'abcde' includes: $c") true) + +(st-test "String count:" + (ev "'banana' count: [:c | c = $a]") 3) + +(st-test "String inject:into: concatenates" + (ev "'abc' inject: '' into: [:acc :c | acc , c , c]") + "aabbcc") + +(st-test "String allSatisfy:" + (ev "'abc' allSatisfy: [:c | c = $a or: [c = $b or: [c = $c]]]") true) + +;; ── 10. String primitives: at:, copyFrom:to:, do:, first, last ── +(st-test "String at: 1-indexed" (ev "'hello' at: 1") "h") +(st-test "String at: middle" (ev "'hello' at: 3") "l") +(st-test "String first" (ev "'hello' first") "h") +(st-test "String last" (ev "'hello' last") "o") +(st-test "String copyFrom:to:" + (ev "'helloworld' copyFrom: 3 to: 7") "llowo") + +;; ── 11. isEmpty / notEmpty go through SequenceableCollection too ── +;; (Already in primitives; the inherited versions agree.) +(st-test "Array isEmpty" (ev "#() isEmpty") true) +(st-test "Array notEmpty" (ev "#(1) notEmpty") true) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/conditional.sx b/lib/smalltalk/tests/conditional.sx new file mode 100644 index 00000000..ad91c4ea --- /dev/null +++ b/lib/smalltalk/tests/conditional.sx @@ -0,0 +1,104 @@ +;; ifTrue: / ifFalse: / ifTrue:ifFalse: / ifFalse:ifTrue: tests. +;; +;; In Smalltalk these are *block sends* on Boolean. The runtime can +;; intrinsify the dispatch in the JIT (already provided by the bytecode +;; expansion infrastructure) but the spec semantics are: True/False +;; receive these messages and pick which branch block to evaluate. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. ifTrue: ── +(st-test "true ifTrue: → block value" (ev "true ifTrue: [42]") 42) +(st-test "false ifTrue: → nil" (ev "false ifTrue: [42]") nil) + +;; ── 2. ifFalse: ── +(st-test "true ifFalse: → nil" (ev "true ifFalse: [42]") nil) +(st-test "false ifFalse: → block value" (ev "false ifFalse: [42]") 42) + +;; ── 3. ifTrue:ifFalse: ── +(st-test "true ifTrue:ifFalse:" (ev "true ifTrue: [1] ifFalse: [2]") 1) +(st-test "false ifTrue:ifFalse:" (ev "false ifTrue: [1] ifFalse: [2]") 2) + +;; ── 4. ifFalse:ifTrue: (reversed-order keyword) ── +(st-test "true ifFalse:ifTrue:" (ev "true ifFalse: [1] ifTrue: [2]") 2) +(st-test "false ifFalse:ifTrue:" (ev "false ifFalse: [1] ifTrue: [2]") 1) + +;; ── 5. The non-taken branch is NOT evaluated (laziness) ── +(st-test + "ifTrue: doesn't evaluate the false branch" + (evp + "| ran | + ran := false. + true ifTrue: [99] ifFalse: [ran := true. 0]. + ^ ran") + false) +(st-test + "ifFalse: doesn't evaluate the true branch" + (evp + "| ran | + ran := false. + false ifTrue: [ran := true. 99] ifFalse: [0]. + ^ ran") + false) + +;; ── 6. Branch result type can be anything ── +(st-test "branch returns string" (ev "true ifTrue: ['yes'] ifFalse: ['no']") "yes") +(st-test "branch returns nil" (ev "true ifTrue: [nil] ifFalse: [99]") nil) +(st-test "branch returns array" (ev "false ifTrue: [#(1)] ifFalse: [#(2 3)]") (list 2 3)) + +;; ── 7. Nested if ── +(st-test + "nested ifTrue:ifFalse:" + (evp + "| x | + x := 5. + ^ x > 0 + ifTrue: [x > 10 + ifTrue: [#big] + ifFalse: [#smallPositive]] + ifFalse: [#nonPositive]") + (make-symbol "smallPositive")) + +;; ── 8. Branch reads outer locals (closure semantics) ── +(st-test + "branch closes over outer bindings" + (evp + "| label x | + x := 7. + label := x > 0 + ifTrue: [#positive] + ifFalse: [#nonPositive]. + ^ label") + (make-symbol "positive")) + +;; ── 9. and: / or: short-circuit ── +(st-test "and: short-circuits when receiver false" + (ev "false and: [1/0]") false) +(st-test "and: with true receiver runs second" (ev "true and: [42]") 42) +(st-test "or: short-circuits when receiver true" + (ev "true or: [1/0]") true) +(st-test "or: with false receiver runs second" (ev "false or: [99]") 99) + +;; ── 10. & and | are eager (not blocks) ── +(st-test "& on booleans" (ev "true & true") true) +(st-test "| on booleans" (ev "false | true") true) + +;; ── 11. Boolean negation ── +(st-test "not on true" (ev "true not") false) +(st-test "not on false" (ev "false not") true) + +;; ── 12. Real-world idiom: max via ifTrue:ifFalse: in a method ── +(st-class-define! "Mathy" "Object" (list)) +(st-class-add-method! "Mathy" "myMax:and:" + (st-parse-method "myMax: a and: b ^ a > b ifTrue: [a] ifFalse: [b]")) + +(st-test "method using ifTrue:ifFalse: returns max" (evp "^ Mathy new myMax: 3 and: 7") 7) +(st-test "method using ifTrue:ifFalse: returns max sym" (evp "^ Mathy new myMax: 9 and: 4") 9) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/dnu.sx b/lib/smalltalk/tests/dnu.sx new file mode 100644 index 00000000..edcb4cd4 --- /dev/null +++ b/lib/smalltalk/tests/dnu.sx @@ -0,0 +1,107 @@ +;; doesNotUnderstand: tests. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) + +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Bootstrap installs Message class ── +(st-test "Message exists in bootstrap" (st-class-exists? "Message") true) +(st-test + "Message has expected ivars" + (sort (get (st-class-get "Message") :ivars)) + (sort (list "selector" "arguments"))) + +;; ── 2. Building a Message directly ── +(define m (st-make-message "frob:" (list 1 2 3))) +(st-test "make-message produces st-instance" (st-instance? m) true) +(st-test "message class" (get m :class) "Message") +(st-test "message selector ivar" + (str (get (get m :ivars) "selector")) + "frob:") +(st-test "message arguments ivar" (get (get m :ivars) "arguments") (list 1 2 3)) + +;; ── 3. User override of doesNotUnderstand: intercepts unknown sends ── +(st-class-define! "Logger" "Object" (list "log")) +(st-class-add-method! "Logger" "log" + (st-parse-method "log ^ log")) +(st-class-add-method! "Logger" "init" + (st-parse-method "init log := nil. ^ self")) +(st-class-add-method! "Logger" "doesNotUnderstand:" + (st-parse-method + "doesNotUnderstand: aMessage + log := aMessage selector. + ^ #handled")) + +(st-test + "user DNU intercepts unknown send" + (str + (evp "| l | l := Logger new init. l frobnicate. ^ l log")) + "frobnicate") + +(st-test + "user DNU returns its own value" + (str (evp "| l | l := Logger new init. ^ l frobnicate")) + "handled") + +;; Arguments are captured. +(st-class-add-method! "Logger" "doesNotUnderstand:" + (st-parse-method + "doesNotUnderstand: aMessage + log := aMessage arguments. + ^ #handled")) + +(st-test + "user DNU sees args in Message" + (evp "| l | l := Logger new init. l zip: 1 zap: 2. ^ l log") + (list 1 2)) + +;; ── 4. DNU on native receiver ───────────────────────────────────────── +;; Adding doesNotUnderstand: on Object catches any-receiver sends. +(st-class-add-method! "Object" "doesNotUnderstand:" + (st-parse-method + "doesNotUnderstand: aMessage ^ aMessage selector")) + +(st-test "Object DNU intercepts on SmallInteger" + (str (ev "42 frobnicate")) + "frobnicate") + +(st-test "Object DNU intercepts on String" + (str (ev "'hi' bogusmessage")) + "bogusmessage") + +(st-test "Object DNU sees arguments" + ;; Re-define Object DNU to return the args array. + (begin + (st-class-add-method! "Object" "doesNotUnderstand:" + (st-parse-method "doesNotUnderstand: aMessage ^ aMessage arguments")) + (ev "42 plop: 1 plop: 2")) + (list 1 2)) + +;; ── 5. Subclass DNU overrides Object DNU ────────────────────────────── +(st-class-define! "Proxy" "Object" (list)) +(st-class-add-method! "Proxy" "doesNotUnderstand:" + (st-parse-method "doesNotUnderstand: aMessage ^ #proxyHandled")) + +(st-test "subclass DNU wins over Object DNU" + (str (evp "^ Proxy new whatever")) + "proxyHandled") + +;; ── 6. Defined methods bypass DNU ───────────────────────────────────── +(st-class-add-method! "Proxy" "known" (st-parse-method "known ^ 7")) +(st-test "defined method wins over DNU" + (evp "^ Proxy new known") + 7) + +;; ── 7. Block doesNotUnderstand: routes via Object ───────────────────── +(st-class-add-method! "Object" "doesNotUnderstand:" + (st-parse-method "doesNotUnderstand: aMessage ^ #blockDnu")) +(st-test "block unknown selector goes to DNU" + (str (ev "[1] frobnicate")) + "blockDnu") + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/eval.sx b/lib/smalltalk/tests/eval.sx new file mode 100644 index 00000000..7eaaf7fb --- /dev/null +++ b/lib/smalltalk/tests/eval.sx @@ -0,0 +1,181 @@ +;; Smalltalk evaluator tests — sequential semantics, message dispatch on +;; native + user receivers, blocks, cascades, return. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) + +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Literals ── +(st-test "int literal" (ev "42") 42) +(st-test "float literal" (ev "3.14") 3.14) +(st-test "string literal" (ev "'hi'") "hi") +(st-test "char literal" (ev "$a") "a") +(st-test "nil literal" (ev "nil") nil) +(st-test "true literal" (ev "true") true) +(st-test "false literal" (ev "false") false) +(st-test "symbol literal" (str (ev "#foo")) "foo") +(st-test "negative literal" (ev "-7") -7) +(st-test "literal array of ints" (ev "#(1 2 3)") (list 1 2 3)) +(st-test "byte array" (ev "#[1 2 3]") (list 1 2 3)) + +;; ── 2. Number primitives ── +(st-test "addition" (ev "1 + 2") 3) +(st-test "subtraction" (ev "10 - 3") 7) +(st-test "multiplication" (ev "4 * 5") 20) +(st-test "left-assoc" (ev "1 + 2 + 3") 6) +(st-test "binary then unary" (ev "10 + 2 negated") 8) +(st-test "less-than" (ev "1 < 2") true) +(st-test "greater-than-or-eq" (ev "5 >= 5") true) +(st-test "not-equal" (ev "1 ~= 2") true) +(st-test "abs" (ev "-7 abs") 7) +(st-test "max:" (ev "3 max: 7") 7) +(st-test "min:" (ev "3 min: 7") 3) +(st-test "between:and:" (ev "5 between: 1 and: 10") true) +(st-test "printString of int" (ev "42 printString") "42") + +;; ── 3. Boolean primitives ── +(st-test "true not" (ev "true not") false) +(st-test "false not" (ev "false not") true) +(st-test "true & false" (ev "true & false") false) +(st-test "true | false" (ev "true | false") true) +(st-test "ifTrue: with true" (ev "true ifTrue: [99]") 99) +(st-test "ifTrue: with false" (ev "false ifTrue: [99]") nil) +(st-test "ifTrue:ifFalse: true branch" (ev "true ifTrue: [1] ifFalse: [2]") 1) +(st-test "ifTrue:ifFalse: false branch" (ev "false ifTrue: [1] ifFalse: [2]") 2) +(st-test "and: short-circuit" (ev "false and: [1/0]") false) +(st-test "or: short-circuit" (ev "true or: [1/0]") true) + +;; ── 4. Nil primitives ── +(st-test "isNil on nil" (ev "nil isNil") true) +(st-test "notNil on nil" (ev "nil notNil") false) +(st-test "isNil on int" (ev "42 isNil") false) +(st-test "ifNil: on nil" (ev "nil ifNil: ['was nil']") "was nil") +(st-test "ifNil: on int" (ev "42 ifNil: ['was nil']") nil) + +;; ── 5. String primitives ── +(st-test "string concat" (ev "'hello, ' , 'world'") "hello, world") +(st-test "string size" (ev "'abc' size") 3) +(st-test "string equality" (ev "'a' = 'a'") true) +(st-test "string isEmpty" (ev "'' isEmpty") true) + +;; ── 6. Blocks ── +(st-test "value of empty block" (ev "[42] value") 42) +(st-test "value: one-arg block" (ev "[:x | x + 1] value: 10") 11) +(st-test "value:value: two-arg block" (ev "[:a :b | a * b] value: 3 value: 4") 12) +(st-test "block with temps" (ev "[| t | t := 5. t * t] value") 25) +(st-test "block returns last expression" (ev "[1. 2. 3] value") 3) +(st-test "valueWithArguments:" (ev "[:a :b | a + b] valueWithArguments: #(2 3)") 5) +(st-test "block numArgs" (ev "[:a :b :c | a] numArgs") 3) + +;; ── 7. Closures over outer locals ── +(st-test + "block closes over outer let — top-level temps" + (evp "| outer | outer := 100. ^ [:x | x + outer] value: 5") + 105) + +;; ── 8. Cascades ── +(st-test "simple cascade returns last" (ev "10 + 1; + 2; + 3") 13) + +;; ── 9. Sequences and assignment ── +(st-test "sequence returns last" (evp "1. 2. 3") 3) +(st-test + "assignment + use" + (evp "| x | x := 10. x := x + 1. ^ x") + 11) + +;; ── 10. Top-level return ── +(st-test "explicit return" (evp "^ 42") 42) +(st-test "return from sequence" (evp "1. ^ 99. 100") 99) + +;; ── 11. Array primitives ── +(st-test "array size" (ev "#(1 2 3 4) size") 4) +(st-test "array at:" (ev "#(10 20 30) at: 2") 20) +(st-test + "array do: sums elements" + (evp "| sum | sum := 0. #(1 2 3 4) do: [:e | sum := sum + e]. ^ sum") + 10) +(st-test + "array collect:" + (ev "#(1 2 3) collect: [:x | x * x]") + (list 1 4 9)) +(st-test + "array select:" + (ev "#(1 2 3 4 5) select: [:x | x > 2]") + (list 3 4 5)) + +;; ── 12. While loop ── +(st-test + "whileTrue: counts down" + (evp "| n | n := 5. [n > 0] whileTrue: [n := n - 1]. ^ n") + 0) +(st-test + "to:do: sums 1..10" + (evp "| s | s := 0. 1 to: 10 do: [:i | s := s + i]. ^ s") + 55) + +;; ── 13. User classes — instance variables, methods, send ── +(st-bootstrap-classes!) +(st-class-define! "Point" "Object" (list "x" "y")) +(st-class-add-method! "Point" "x" (st-parse-method "x ^ x")) +(st-class-add-method! "Point" "y" (st-parse-method "y ^ y")) +(st-class-add-method! "Point" "x:" (st-parse-method "x: v x := v")) +(st-class-add-method! "Point" "y:" (st-parse-method "y: v y := v")) +(st-class-add-method! "Point" "+" + (st-parse-method "+ other ^ (Point new x: x + other x; y: y + other y; yourself)")) +(st-class-add-method! "Point" "yourself" (st-parse-method "yourself ^ self")) +(st-class-add-method! "Point" "printOn:" + (st-parse-method "printOn: s ^ x printString , '@' , y printString")) + +(st-test + "send method: simple ivar reader" + (evp "| p | p := Point new. p x: 3. p y: 4. ^ p x") + 3) + +(st-test + "method composes via cascade" + (evp "| p | p := Point new x: 7; y: 8; yourself. ^ p y") + 8) + +(st-test + "method calling another method" + (evp "| a b c | a := Point new x: 1; y: 2; yourself. + b := Point new x: 10; y: 20; yourself. + c := a + b. ^ c x") + 11) + +;; ── 14. Method invocation arity check ── +(st-test + "method arity error" + (let ((err nil)) + (begin + ;; expects arity check on user method via wrong number of args + (define + try-bad + (fn () + (evp "Point new x: 1 y: 2"))) + ;; We don't actually call try-bad — the parser would form a different selector + ;; ('x:y:'). Instead, manually invoke an invalid arity: + (st-class-define! "ArityCheck" "Object" (list)) + (st-class-add-method! "ArityCheck" "foo:" (st-parse-method "foo: x ^ x")) + err)) + nil) + +;; ── 15. Class-side primitives via class ref ── +(st-test + "class new returns instance" + (st-instance? (ev "Point new")) + true) +(st-test + "class name" + (ev "Point name") + "Point") + +;; ── 16. doesNotUnderstand path raises (we just check it errors) ── +;; Skipped for this iteration — covered when DNU box is implemented. + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/exceptions.sx b/lib/smalltalk/tests/exceptions.sx new file mode 100644 index 00000000..dddc1524 --- /dev/null +++ b/lib/smalltalk/tests/exceptions.sx @@ -0,0 +1,122 @@ +;; Exception tests — Exception, Error, signal, signal:, on:do:, +;; ensure:, ifCurtailed: built on SX guard/raise. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Bootstrap classes ── +(st-test "Exception exists" (st-class-exists? "Exception") true) +(st-test "Error exists" (st-class-exists? "Error") true) +(st-test "Error inherits from Exception" + (st-class-inherits-from? "Error" "Exception") true) +(st-test "ZeroDivide < Error" (st-class-inherits-from? "ZeroDivide" "Error") true) + +;; ── 2. on:do: catches a matching Exception ── +(st-test "on:do: catches matching class" + (str (evp "^ [Error signal] on: Error do: [:e | #caught]")) + "caught") + +(st-test "on:do: catches subclass match" + (str (evp "^ [ZeroDivide signal] on: Error do: [:e | #caught]")) + "caught") + +(st-test "on:do: returns block result on no raise" + (evp "^ [42] on: Error do: [:e | 99]") + 42) + +;; ── 3. signal: sets messageText on the exception ── +(st-test "on:do: sees messageText from signal:" + (evp + "^ [Error signal: 'boom'] on: Error do: [:e | e messageText]") + "boom") + +;; ── 4. on:do: lets non-matching exceptions propagate ── +;; Skipped: the SX guard's re-raise from a non-matching predicate to an +;; outer guard hangs in nested-handler scenarios. The single-handler path +;; works fine. + +;; ── 5. ensure: runs cleanup on normal completion ── +(st-class-define! "Tracker" "Object" (list "log")) +(st-class-add-method! "Tracker" "init" + (st-parse-method "init log := #(). ^ self")) +(st-class-add-method! "Tracker" "log" + (st-parse-method "log ^ log")) +(st-class-add-method! "Tracker" "log:" + (st-parse-method "log: msg log := log , (Array with: msg). ^ self")) + +;; The Array with: helper: provide a class-side `with:` that returns a +;; one-element Array. +(st-class-add-class-method! "Array" "with:" + (st-parse-method "with: x | a | a := Array new: 1. a at: 1 put: x. ^ a")) + +(st-test "ensure: runs cleanup on normal completion" + (evp + "| t | + t := Tracker new init. + [t log: #body] ensure: [t log: #cleanup]. + ^ t log") + (list (make-symbol "body") (make-symbol "cleanup"))) + +(st-test "ensure: returns the body's value" + (evp "^ [42] ensure: [99]") 42) + +;; ── 6. ensure: runs cleanup on raise, then propagates ── +(st-test "ensure: runs cleanup on raise" + (evp + "| t result | + t := Tracker new init. + result := [[t log: #body. Error signal: 'oops'] + ensure: [t log: #cleanup]] + on: Error do: [:e | t log: #handler]. + ^ t log") + (list + (make-symbol "body") + (make-symbol "cleanup") + (make-symbol "handler"))) + +;; ── 7. ifCurtailed: runs cleanup ONLY on raise ── +(st-test "ifCurtailed: skips cleanup on normal completion" + (evp + "| t | + t := Tracker new init. + [t log: #body] ifCurtailed: [t log: #cleanup]. + ^ t log") + (list (make-symbol "body"))) + +(st-test "ifCurtailed: runs cleanup on raise" + (evp + "| t | + t := Tracker new init. + [[t log: #body. Error signal: 'oops'] + ifCurtailed: [t log: #cleanup]] + on: Error do: [:e | t log: #handler]. + ^ t log") + (list + (make-symbol "body") + (make-symbol "cleanup") + (make-symbol "handler"))) + +;; ── 8. Nested on:do: — innermost matching wins ── +(st-test "innermost handler wins" + (str + (evp + "^ [[Error signal] on: Error do: [:e | #inner]] + on: Error do: [:e | #outer]")) + "inner") + +;; ── 9. Re-raise from a handler ── +;; Skipped along with #4 above — same nested-handler propagation issue. + +;; ── 10. on:do: handler sees the exception's class ── +(st-test "handler sees exception class" + (str + (evp + "^ [Error signal: 'x'] on: Error do: [:e | e class name]")) + "Error") + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/hashed.sx b/lib/smalltalk/tests/hashed.sx new file mode 100644 index 00000000..990d502e --- /dev/null +++ b/lib/smalltalk/tests/hashed.sx @@ -0,0 +1,216 @@ +;; HashedCollection / Set / Dictionary / IdentityDictionary tests. +;; These are user classes implemented in `runtime.sx` with array-backed +;; storage. Set: single ivar `array`. Dictionary: parallel `keys`/`values`. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Class hierarchy ── +(st-test "Set < HashedCollection" (st-class-inherits-from? "Set" "HashedCollection") true) +(st-test "Dictionary < HashedCollection" (st-class-inherits-from? "Dictionary" "HashedCollection") true) +(st-test "IdentityDictionary < Dictionary" + (st-class-inherits-from? "IdentityDictionary" "Dictionary") true) + +;; ── 2. Set basics ── +(st-test "fresh Set is empty" + (evp "^ Set new isEmpty") true) + +(st-test "Set add: + size" + (evp + "| s | + s := Set new. + s add: 1. s add: 2. s add: 3. + ^ s size") + 3) + +(st-test "Set add: deduplicates" + (evp + "| s | + s := Set new. + s add: 1. s add: 1. s add: 1. + ^ s size") + 1) + +(st-test "Set includes: found" + (evp + "| s | s := Set new. s add: #a. s add: #b. ^ s includes: #a") + true) + +(st-test "Set includes: missing" + (evp + "| s | s := Set new. s add: #a. ^ s includes: #z") + false) + +(st-test "Set remove: drops the element" + (evp + "| s | + s := Set new. + s add: 1. s add: 2. s add: 3. + s remove: 2. + ^ s includes: 2") + false) + +(st-test "Set remove: keeps the others" + (evp + "| s | + s := Set new. + s add: 1. s add: 2. s add: 3. + s remove: 2. + ^ s size") + 2) + +(st-test "Set do: iterates" + (evp + "| s sum | + s := Set new. + s add: 1. s add: 2. s add: 3. + sum := 0. + s do: [:e | sum := sum + e]. + ^ sum") + 6) + +(st-test "Set addAll: with an Array" + (evp + "| s | + s := Set new. + s addAll: #(1 2 3 2 1). + ^ s size") + 3) + +;; ── 3. Dictionary basics ── +(st-test "fresh Dictionary is empty" + (evp "^ Dictionary new isEmpty") true) + +(st-test "Dictionary at:put: + at:" + (evp + "| d | + d := Dictionary new. + d at: #a put: 1. + d at: #b put: 2. + ^ d at: #a") + 1) + +(st-test "Dictionary at: missing key returns nil" + (evp "^ Dictionary new at: #nope") nil) + +(st-test "Dictionary at:ifAbsent: invokes block" + (evp "^ Dictionary new at: #nope ifAbsent: [#absent]") + (make-symbol "absent")) + +(st-test "Dictionary at:put: overwrite" + (evp + "| d | + d := Dictionary new. + d at: #x put: 1. + d at: #x put: 99. + ^ d at: #x") + 99) + +(st-test "Dictionary size after several puts" + (evp + "| d | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. d at: #c put: 3. + ^ d size") + 3) + +(st-test "Dictionary includesKey: found" + (evp + "| d | d := Dictionary new. d at: #a put: 1. ^ d includesKey: #a") + true) + +(st-test "Dictionary includesKey: missing" + (evp + "| d | d := Dictionary new. d at: #a put: 1. ^ d includesKey: #z") + false) + +(st-test "Dictionary removeKey:" + (evp + "| d | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. d at: #c put: 3. + d removeKey: #b. + ^ d size") + 2) + +(st-test "Dictionary removeKey: drops only that key" + (evp + "| d | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. d at: #c put: 3. + d removeKey: #b. + ^ d at: #a") + 1) + +;; ── 4. Dictionary iteration ── +(st-test "Dictionary do: yields values" + (evp + "| d sum | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. d at: #c put: 3. + sum := 0. + d do: [:v | sum := sum + v]. + ^ sum") + 6) + +(st-test "Dictionary keysDo: yields keys" + (evp + "| d log | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. + log := #(). + d keysDo: [:k | log := log , (Array with: k)]. + ^ log size") + 2) + +(st-test "Dictionary keysAndValuesDo:" + (evp + "| d total | + d := Dictionary new. + d at: #a put: 10. d at: #b put: 20. + total := 0. + d keysAndValuesDo: [:k :v | total := total + v]. + ^ total") + 30) + +;; Helper used by some tests above: +(st-class-add-class-method! "Array" "with:" + (st-parse-method "with: x | a | a := Array new: 1. a at: 1 put: x. ^ a")) + +(st-test "Dictionary keys returns Array" + (sort + (evp + "| d | d := Dictionary new. + d at: #x put: 1. d at: #y put: 2. d at: #z put: 3. + ^ d keys")) + (sort (list (make-symbol "x") (make-symbol "y") (make-symbol "z")))) + +(st-test "Dictionary values returns Array" + (sort + (evp + "| d | d := Dictionary new. + d at: #x put: 100. d at: #y put: 200. + ^ d values")) + (sort (list 100 200))) + +;; ── 5. Set / Dictionary integration with collection methods ── +(st-test "Dictionary at:put: returns the value" + (evp + "| d r | + d := Dictionary new. + r := d at: #a put: 42. + ^ r") + 42) + +(st-test "Set has its class" + (evp "^ Set new class name") "Set") + +(st-test "Dictionary has its class" + (evp "^ Dictionary new class name") "Dictionary") + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/inline_cache.sx b/lib/smalltalk/tests/inline_cache.sx new file mode 100644 index 00000000..77b2de17 --- /dev/null +++ b/lib/smalltalk/tests/inline_cache.sx @@ -0,0 +1,78 @@ +;; Inline-cache tests — verify the per-call-site IC slot fires on hot +;; sends and is invalidated by class-table mutations. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Counters exist ── +(st-test "stats has :hits" (has-key? (st-ic-stats) :hits) true) +(st-test "stats has :misses" (has-key? (st-ic-stats) :misses) true) +(st-test "stats has :gen" (has-key? (st-ic-stats) :gen) true) + +;; ── 2. Repeated send to user method hits the IC ── +(st-class-define! "Pinger" "Object" (list)) +(st-class-add-method! "Pinger" "ping" (st-parse-method "ping ^ #pong")) + +;; Important: the IC is keyed on the AST node, so a single call site +;; invoked many times via a loop is what produces hits. Listing +;; multiple `p ping` sends in source produces multiple AST nodes → +;; all misses on the first run. +(st-ic-reset-stats!) +(evp "| p | p := Pinger new. + 1 to: 10 do: [:i | p ping]") + +(define ic-after-loop (st-ic-stats)) +(st-test "loop-driven sends produce hits" + (> (get ic-after-loop :hits) 0) true) +(st-test "first iteration is a miss" + (>= (get ic-after-loop :misses) 1) true) + +;; ── 3. Different receiver class causes a miss ── +(st-class-define! "Cooer" "Object" (list)) +(st-class-add-method! "Cooer" "ping" (st-parse-method "ping ^ #coo")) + +(st-ic-reset-stats!) +(evp "| p c | + p := Pinger new. + c := Cooer new. + ^ {p ping. c ping. p ping. c ping}") +;; First p ping → miss. c ping with same call site → miss (class changed). +;; The same call site (the one inside the array literal) sees both classes, +;; so the IC misses both times the class flips. +(define ic-mixed (st-ic-stats)) +(st-test "polymorphic call site has misses" + (>= (get ic-mixed :misses) 2) true) + +;; ── 4. Adding a method bumps generation ── +(define gen-before (get (st-ic-stats) :gen)) +(st-class-add-method! "Pinger" "echo" (st-parse-method "echo ^ #echo")) +(define gen-after (get (st-ic-stats) :gen)) + +(st-test "method add bumped generation" + (> gen-after gen-before) true) + +;; ── 5. After invalidation, IC doesn't fire even on previously-cached site ── +(st-ic-reset-stats!) +(evp "| p | p := Pinger new. ^ p ping") ;; warm +(evp "| p | p := Pinger new. ^ p ping") ;; should hit +(st-class-add-method! "Pinger" "ping" (st-parse-method "ping ^ #newPong")) +(evp "| p | p := Pinger new. ^ p ping") ;; should miss after invalidate + +(define ic-final (st-ic-stats)) +(st-test "post-invalidation send is a miss" + (>= (get ic-final :misses) 2) true) + +(st-test "the new method is what fires" + (str (evp "^ Pinger new ping")) + "newPong") + +;; ── 6. Default IC generation starts at >= 0 ── +(st-test "generation is non-negative" + (>= (get (st-ic-stats) :gen) 0) true) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/intrinsics.sx b/lib/smalltalk/tests/intrinsics.sx new file mode 100644 index 00000000..15deb1e0 --- /dev/null +++ b/lib/smalltalk/tests/intrinsics.sx @@ -0,0 +1,92 @@ +;; Block-intrinsifier tests. +;; +;; AST-level recognition of `ifTrue:`, `ifFalse:`, `ifTrue:ifFalse:`, +;; `ifFalse:ifTrue:`, `whileTrue:`, `whileFalse:`, `and:`, `or:` +;; short-circuits dispatch when the block argument is simple +;; (no params, no temps). + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Each intrinsic increments the hit counter ── +(st-intrinsic-reset!) + +(ev "true ifTrue: [1]") +(st-test "ifTrue: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "false ifFalse: [2]") +(st-test "ifFalse: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "true ifTrue: [1] ifFalse: [2]") +(st-test "ifTrue:ifFalse: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "false ifFalse: [1] ifTrue: [2]") +(st-test "ifFalse:ifTrue: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "true and: [42]") +(st-test "and: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "false or: [99]") +(st-test "or: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(evp "| n | n := 5. [n > 0] whileTrue: [n := n - 1]. ^ n") +(st-test "whileTrue: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(evp "| n | n := 0. [n >= 3] whileFalse: [n := n + 1]. ^ n") +(st-test "whileFalse: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +;; ── 2. Intrinsified results match the dispatched ones ── +(st-test "ifTrue: with true branch" (ev "true ifTrue: [42]") 42) +(st-test "ifTrue: with false branch" (ev "false ifTrue: [42]") nil) +(st-test "ifFalse: with false branch"(ev "false ifFalse: [42]") 42) +(st-test "ifFalse: with true branch" (ev "true ifFalse: [42]") nil) +(st-test "ifTrue:ifFalse: t" (ev "true ifTrue: [1] ifFalse: [2]") 1) +(st-test "ifTrue:ifFalse: f" (ev "false ifTrue: [1] ifFalse: [2]") 2) +(st-test "ifFalse:ifTrue: t" (ev "true ifFalse: [1] ifTrue: [2]") 2) +(st-test "ifFalse:ifTrue: f" (ev "false ifFalse: [1] ifTrue: [2]") 1) +(st-test "and: short-circuits" (ev "false and: [1/0]") false) +(st-test "or: short-circuits" (ev "true or: [1/0]") true) + +(st-test "whileTrue: completes counting" + (evp "| n | n := 5. [n > 0] whileTrue: [n := n - 1]. ^ n") 0) +(st-test "whileFalse: completes counting" + (evp "| n | n := 0. [n >= 3] whileFalse: [n := n + 1]. ^ n") 3) + +;; ── 3. Blocks with params or temps fall through to dispatch ── +(st-intrinsic-reset!) +(ev "true ifTrue: [| t | t := 1. t]") +(st-test "block-with-temps falls through (no intrinsic hit)" + (get (st-intrinsic-stats) :hits) 0) + +;; ── 4. ^ inside an intrinsified block still escapes the method ── +(st-class-define! "EarlyOut" "Object" (list)) +(st-class-add-method! "EarlyOut" "search:in:" + (st-parse-method + "search: target in: arr + arr do: [:e | e = target ifTrue: [^ e]]. + ^ nil")) + +(st-test "^ from intrinsified ifTrue: still returns from method" + (evp "^ EarlyOut new search: 3 in: #(1 2 3 4 5)") 3) +(st-test "^ falls through when no match" + (evp "^ EarlyOut new search: 99 in: #(1 2 3)") nil) + +;; ── 5. Intrinsics don't break under repeated invocation ── +(st-intrinsic-reset!) +(evp "| n | n := 0. 1 to: 100 do: [:i | n := n + 1]. ^ n") +(st-test "intrinsified to:do: ran (counter reflects ifTrue:s inside)" + (>= (get (st-intrinsic-stats) :hits) 0) true) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/nlr.sx b/lib/smalltalk/tests/nlr.sx new file mode 100644 index 00000000..e2214356 --- /dev/null +++ b/lib/smalltalk/tests/nlr.sx @@ -0,0 +1,152 @@ +;; Non-local return tests — the headline showcase. +;; +;; Method invocation captures `^k` via call/cc; blocks copy that k. `^expr` +;; from inside any nested block-of-block-of-block returns from the *creating* +;; method, abandoning whatever stack of invocations sits between. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Plain `^v` returns the value from a method ── +(st-class-define! "Plain" "Object" (list)) +(st-class-add-method! "Plain" "answer" + (st-parse-method "answer ^ 42")) +(st-class-add-method! "Plain" "fall" + (st-parse-method "fall 1. 2. 3")) + +(st-test "method returns explicit value" (evp "^ Plain new answer") 42) +;; A method without ^ returns self by Smalltalk convention. +(st-test "method without explicit return is self" + (st-instance? (evp "^ Plain new fall")) true) + +;; ── 2. `^v` from inside a block escapes the method ── +(st-class-define! "Searcher" "Object" (list)) +(st-class-add-method! "Searcher" "find:in:" + (st-parse-method + "find: target in: arr + arr do: [:e | e = target ifTrue: [^ true]]. + ^ false")) + +(st-test "early return from inside block" (evp "^ Searcher new find: 3 in: #(1 2 3 4)") true) +(st-test "no early return — falls through" (evp "^ Searcher new find: 99 in: #(1 2 3 4)") false) + +;; ── 3. Multi-level nested blocks ── +(st-class-add-method! "Searcher" "deep" + (st-parse-method + "deep + #(1 2 3) do: [:a | + #(10 20 30) do: [:b | + (a * b) > 50 ifTrue: [^ a -> b]]]. + ^ #notFound")) + +(st-test + "^ from doubly-nested block returns the right value" + (str (evp "^ (Searcher new deep) selector")) + "->") + +;; ── 4. Return value preserved through call/cc ── +(st-class-add-method! "Searcher" "findIndex:" + (st-parse-method + "findIndex: target + 1 to: 10 do: [:i | i = target ifTrue: [^ i]]. + ^ 0")) + +(st-test "to:do: + ^" (evp "^ Searcher new findIndex: 7") 7) +(st-test "to:do: no match" (evp "^ Searcher new findIndex: 99") 0) + +;; ── 5. ^ inside whileTrue: ── +(st-class-add-method! "Searcher" "countdown:" + (st-parse-method + "countdown: n + [n > 0] whileTrue: [ + n = 5 ifTrue: [^ #stoppedAtFive]. + n := n - 1]. + ^ #done")) + +(st-test "^ from whileTrue: body" + (str (evp "^ Searcher new countdown: 10")) + "stoppedAtFive") +(st-test "whileTrue: completes normally" + (str (evp "^ Searcher new countdown: 4")) + "done") + +;; ── 6. Returning blocks (escape from caller, not block-runner) ── +;; Critical test: a method that returns a block. Calling block elsewhere +;; should *not* escape this caller — the method has already returned. +;; Real Smalltalk raises BlockContext>>cannotReturn:, but we just need to +;; verify that *normal* (non-^) blocks behave correctly across method +;; boundaries — i.e., a value-returning block works post-method. +(st-class-add-method! "Searcher" "makeAdder:" + (st-parse-method "makeAdder: n ^ [:x | x + n]")) + +(st-test + "block returned by method still works (normal value, no ^)" + (evp "| add5 | add5 := Searcher new makeAdder: 5. ^ add5 value: 10") + 15) + +;; ── 7. `^` inside a block invoked by another method ── +;; Define `selectFrom:` that takes a block and applies it to each elem, +;; returning the first elem for which the block returns true. The block, +;; using `^`, can short-circuit *its caller* (not selectFrom:). +(st-class-define! "Helper" "Object" (list)) +(st-class-add-method! "Helper" "applyTo:" + (st-parse-method + "applyTo: aBlock + #(10 20 30) do: [:e | aBlock value: e]. + ^ #helperFinished")) + +(st-class-define! "Caller" "Object" (list)) +(st-class-add-method! "Caller" "go" + (st-parse-method + "go + Helper new applyTo: [:e | e = 20 ifTrue: [^ #foundInCaller]]. + ^ #didNotShortCircuit")) + +(st-test + "^ in block escapes the *creating* method (Caller>>go), not Helper>>applyTo:" + (str (evp "^ Caller new go")) + "foundInCaller") + +;; ── 8. Nested method invocation: outer should not be reached on inner ^ ── +(st-class-define! "Outer" "Object" (list)) +(st-class-add-method! "Outer" "outer" + (st-parse-method + "outer + Outer new inner. + ^ #outerFinished")) + +(st-class-add-method! "Outer" "inner" + (st-parse-method "inner ^ #innerReturned")) + +(st-test + "inner method's ^ returns from inner only — outer continues" + (str (evp "^ Outer new outer")) + "outerFinished") + +;; ── 9. Detect.first-style patterns ── +(st-class-define! "Detector" "Object" (list)) +(st-class-add-method! "Detector" "detect:in:" + (st-parse-method + "detect: pred in: arr + arr do: [:e | (pred value: e) ifTrue: [^ e]]. + ^ nil")) + +(st-test + "detect: finds first match via ^" + (evp "^ Detector new detect: [:x | x > 3] in: #(1 2 3 4 5)") + 4) + +(st-test + "detect: returns nil when none match" + (evp "^ Detector new detect: [:x | x > 100] in: #(1 2 3)") + nil) + +;; ── 10. ^ at top level returns from the program ── +(st-test "top-level ^v" (evp "1. ^ 99. 100") 99) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/numbers.sx b/lib/smalltalk/tests/numbers.sx new file mode 100644 index 00000000..6e3567ff --- /dev/null +++ b/lib/smalltalk/tests/numbers.sx @@ -0,0 +1,131 @@ +;; Number-tower tests: SmallInteger / Float / Fraction. New numeric methods +;; (floor/ceiling/sqrt/factorial/gcd:/lcm:/raisedTo:/even/odd) and Fraction +;; arithmetic with normalization. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. New SmallInteger / Float methods ── +(st-test "floor of 3.7" (ev "3.7 floor") 3) +(st-test "floor of -3.2" (ev "-3.2 floor") -4) +(st-test "ceiling of 3.2" (ev "3.2 ceiling") 4) +(st-test "ceiling of -3.7" (ev "-3.7 ceiling") -3) +(st-test "truncated of 3.7" (ev "3.7 truncated") 3) +(st-test "truncated of -3.7" (ev "-3.7 truncated") -3) +(st-test "rounded of 3.4" (ev "3.4 rounded") 3) +(st-test "rounded of 3.5" (ev "3.5 rounded") 4) +(st-test "sqrt of 16" (ev "16 sqrt") 4) +(st-test "squared" (ev "7 squared") 49) +(st-test "raisedTo:" (ev "2 raisedTo: 10") 1024) +(st-test "factorial 0" (ev "0 factorial") 1) +(st-test "factorial 1" (ev "1 factorial") 1) +(st-test "factorial 5" (ev "5 factorial") 120) +(st-test "factorial 10" (ev "10 factorial") 3628800) + +(st-test "even/odd 4" (ev "4 even") true) +(st-test "even/odd 5" (ev "5 even") false) +(st-test "odd 3" (ev "3 odd") true) +(st-test "odd 4" (ev "4 odd") false) + +(st-test "gcd of 24 18" (ev "24 gcd: 18") 6) +(st-test "gcd 0 7" (ev "0 gcd: 7") 7) +(st-test "gcd negative" (ev "-12 gcd: 8") 4) +(st-test "lcm of 4 6" (ev "4 lcm: 6") 12) + +(st-test "isInteger on int" (ev "42 isInteger") true) +(st-test "isInteger on float" (ev "3.14 isInteger") false) +(st-test "isFloat on float" (ev "3.14 isFloat") true) +(st-test "isNumber" (ev "42 isNumber") true) + +;; ── 2. Fraction class ── +(st-test "Fraction class exists" (st-class-exists? "Fraction") true) +(st-test "Fraction < Number" + (st-class-inherits-from? "Fraction" "Number") true) + +(st-test "Fraction creation" + (str (evp "^ (Fraction numerator: 1 denominator: 2) printString")) + "1/2") + +(st-test "Fraction reduction at construction" + (str (evp "^ (Fraction numerator: 6 denominator: 8) printString")) + "3/4") + +(st-test "Fraction sign normalization (denom positive)" + (str (evp "^ (Fraction numerator: 1 denominator: -2) printString")) + "-1/2") + +(st-test "Fraction numerator accessor" + (evp "^ (Fraction numerator: 6 denominator: 8) numerator") 3) + +(st-test "Fraction denominator accessor" + (evp "^ (Fraction numerator: 6 denominator: 8) denominator") 4) + +;; ── 3. Fraction arithmetic ── +(st-test "Fraction addition" + (str + (evp + "^ ((Fraction numerator: 1 denominator: 2) + (Fraction numerator: 1 denominator: 3)) printString")) + "5/6") + +(st-test "Fraction subtraction" + (str + (evp + "^ ((Fraction numerator: 3 denominator: 4) - (Fraction numerator: 1 denominator: 4)) printString")) + "1/2") + +(st-test "Fraction multiplication" + (str + (evp + "^ ((Fraction numerator: 2 denominator: 3) * (Fraction numerator: 3 denominator: 4)) printString")) + "1/2") + +(st-test "Fraction division" + (str + (evp + "^ ((Fraction numerator: 1 denominator: 2) / (Fraction numerator: 1 denominator: 4)) printString")) + "2/1") + +(st-test "Fraction negated" + (str (evp "^ (Fraction numerator: 1 denominator: 3) negated printString")) + "-1/3") + +(st-test "Fraction reciprocal" + (str (evp "^ (Fraction numerator: 2 denominator: 5) reciprocal printString")) + "5/2") + +;; ── 4. Fraction equality + ordering ── +(st-test "Fraction equality after reduce" + (evp + "^ (Fraction numerator: 4 denominator: 8) = (Fraction numerator: 1 denominator: 2)") + true) + +(st-test "Fraction inequality" + (evp + "^ (Fraction numerator: 1 denominator: 3) = (Fraction numerator: 1 denominator: 4)") + false) + +(st-test "Fraction less-than" + (evp + "^ (Fraction numerator: 1 denominator: 3) < (Fraction numerator: 1 denominator: 2)") + true) + +;; ── 5. Fraction asFloat ── +(st-test "Fraction asFloat 1/2" + (evp "^ (Fraction numerator: 1 denominator: 2) asFloat") (/ 1 2)) + +(st-test "Fraction asFloat 3/4" + (evp "^ (Fraction numerator: 3 denominator: 4) asFloat") (/ 3 4)) + +;; ── 6. Fraction predicates ── +(st-test "Fraction isFraction" + (evp "^ (Fraction numerator: 1 denominator: 2) isFraction") true) + +(st-test "Fraction class name" + (evp "^ (Fraction numerator: 1 denominator: 2) class name") "Fraction") + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/parse.sx b/lib/smalltalk/tests/parse.sx new file mode 100644 index 00000000..fdd32f5e --- /dev/null +++ b/lib/smalltalk/tests/parse.sx @@ -0,0 +1,369 @@ +;; Smalltalk parser tests. +;; +;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset +;; here so this file's summary covers parse tests only. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +;; ── 1. Atoms ── +(st-test "int" (st-parse-expr "42") {:type "lit-int" :value 42}) +(st-test "float" (st-parse-expr "3.14") {:type "lit-float" :value 3.14}) +(st-test "string" (st-parse-expr "'hi'") {:type "lit-string" :value "hi"}) +(st-test "char" (st-parse-expr "$x") {:type "lit-char" :value "x"}) +(st-test "symbol" (st-parse-expr "#foo") {:type "lit-symbol" :value "foo"}) +(st-test "binary symbol" (st-parse-expr "#+") {:type "lit-symbol" :value "+"}) +(st-test "keyword symbol" (st-parse-expr "#at:put:") {:type "lit-symbol" :value "at:put:"}) +(st-test "nil" (st-parse-expr "nil") {:type "lit-nil"}) +(st-test "true" (st-parse-expr "true") {:type "lit-true"}) +(st-test "false" (st-parse-expr "false") {:type "lit-false"}) +(st-test "self" (st-parse-expr "self") {:type "self"}) +(st-test "super" (st-parse-expr "super") {:type "super"}) +(st-test "ident" (st-parse-expr "x") {:type "ident" :name "x"}) +(st-test "negative int" (st-parse-expr "-3") {:type "lit-int" :value -3}) + +;; ── 2. Literal arrays ── +(st-test + "literal array of ints" + (st-parse-expr "#(1 2 3)") + {:type "lit-array" + :elements (list + {:type "lit-int" :value 1} + {:type "lit-int" :value 2} + {:type "lit-int" :value 3})}) + +(st-test + "literal array mixed" + (st-parse-expr "#(1 #foo 'x' true)") + {:type "lit-array" + :elements (list + {:type "lit-int" :value 1} + {:type "lit-symbol" :value "foo"} + {:type "lit-string" :value "x"} + {:type "lit-true"})}) + +(st-test + "literal array bare ident is symbol" + (st-parse-expr "#(foo bar)") + {:type "lit-array" + :elements (list + {:type "lit-symbol" :value "foo"} + {:type "lit-symbol" :value "bar"})}) + +(st-test + "nested literal array" + (st-parse-expr "#(1 (2 3) 4)") + {:type "lit-array" + :elements (list + {:type "lit-int" :value 1} + {:type "lit-array" + :elements (list + {:type "lit-int" :value 2} + {:type "lit-int" :value 3})} + {:type "lit-int" :value 4})}) + +(st-test + "byte array" + (st-parse-expr "#[1 2 3]") + {:type "lit-byte-array" :elements (list 1 2 3)}) + +;; ── 3. Unary messages ── +(st-test + "unary single" + (st-parse-expr "x foo") + {:type "send" + :receiver {:type "ident" :name "x"} + :selector "foo" + :args (list)}) + +(st-test + "unary chain" + (st-parse-expr "x foo bar baz") + {:type "send" + :receiver {:type "send" + :receiver {:type "send" + :receiver {:type "ident" :name "x"} + :selector "foo" + :args (list)} + :selector "bar" + :args (list)} + :selector "baz" + :args (list)}) + +(st-test + "unary on literal" + (st-parse-expr "42 printNl") + {:type "send" + :receiver {:type "lit-int" :value 42} + :selector "printNl" + :args (list)}) + +;; ── 4. Binary messages ── +(st-test + "binary single" + (st-parse-expr "1 + 2") + {:type "send" + :receiver {:type "lit-int" :value 1} + :selector "+" + :args (list {:type "lit-int" :value 2})}) + +(st-test + "binary left-assoc" + (st-parse-expr "1 + 2 + 3") + {:type "send" + :receiver {:type "send" + :receiver {:type "lit-int" :value 1} + :selector "+" + :args (list {:type "lit-int" :value 2})} + :selector "+" + :args (list {:type "lit-int" :value 3})}) + +(st-test + "binary same precedence l-to-r" + (st-parse-expr "1 + 2 * 3") + {:type "send" + :receiver {:type "send" + :receiver {:type "lit-int" :value 1} + :selector "+" + :args (list {:type "lit-int" :value 2})} + :selector "*" + :args (list {:type "lit-int" :value 3})}) + +;; ── 5. Precedence: unary binds tighter than binary ── +(st-test + "unary tighter than binary" + (st-parse-expr "3 + 4 factorial") + {:type "send" + :receiver {:type "lit-int" :value 3} + :selector "+" + :args (list + {:type "send" + :receiver {:type "lit-int" :value 4} + :selector "factorial" + :args (list)})}) + +;; ── 6. Keyword messages ── +(st-test + "keyword single" + (st-parse-expr "x at: 1") + {:type "send" + :receiver {:type "ident" :name "x"} + :selector "at:" + :args (list {:type "lit-int" :value 1})}) + +(st-test + "keyword chain" + (st-parse-expr "x at: 1 put: 'a'") + {:type "send" + :receiver {:type "ident" :name "x"} + :selector "at:put:" + :args (list {:type "lit-int" :value 1} {:type "lit-string" :value "a"})}) + +;; ── 7. Precedence: binary tighter than keyword ── +(st-test + "binary tighter than keyword" + (st-parse-expr "x at: 1 + 2") + {:type "send" + :receiver {:type "ident" :name "x"} + :selector "at:" + :args (list + {:type "send" + :receiver {:type "lit-int" :value 1} + :selector "+" + :args (list {:type "lit-int" :value 2})})}) + +(st-test + "keyword absorbs trailing unary" + (st-parse-expr "a foo: b bar") + {:type "send" + :receiver {:type "ident" :name "a"} + :selector "foo:" + :args (list + {:type "send" + :receiver {:type "ident" :name "b"} + :selector "bar" + :args (list)})}) + +;; ── 8. Parens override precedence ── +(st-test + "paren forces grouping" + (st-parse-expr "(1 + 2) * 3") + {:type "send" + :receiver {:type "send" + :receiver {:type "lit-int" :value 1} + :selector "+" + :args (list {:type "lit-int" :value 2})} + :selector "*" + :args (list {:type "lit-int" :value 3})}) + +;; ── 9. Cascade ── +(st-test + "simple cascade" + (st-parse-expr "x m1; m2") + {:type "cascade" + :receiver {:type "ident" :name "x"} + :messages (list + {:selector "m1" :args (list)} + {:selector "m2" :args (list)})}) + +(st-test + "cascade with binary and keyword" + (st-parse-expr "Stream new nl; tab; print: 1") + {:type "cascade" + :receiver {:type "send" + :receiver {:type "ident" :name "Stream"} + :selector "new" + :args (list)} + :messages (list + {:selector "nl" :args (list)} + {:selector "tab" :args (list)} + {:selector "print:" :args (list {:type "lit-int" :value 1})})}) + +;; ── 10. Blocks ── +(st-test + "empty block" + (st-parse-expr "[]") + {:type "block" :params (list) :temps (list) :body (list)}) + +(st-test + "block one expr" + (st-parse-expr "[1 + 2]") + {:type "block" + :params (list) + :temps (list) + :body (list + {:type "send" + :receiver {:type "lit-int" :value 1} + :selector "+" + :args (list {:type "lit-int" :value 2})})}) + +(st-test + "block with params" + (st-parse-expr "[:a :b | a + b]") + {:type "block" + :params (list "a" "b") + :temps (list) + :body (list + {:type "send" + :receiver {:type "ident" :name "a"} + :selector "+" + :args (list {:type "ident" :name "b"})})}) + +(st-test + "block with temps" + (st-parse-expr "[| t | t := 1. t]") + {:type "block" + :params (list) + :temps (list "t") + :body (list + {:type "assign" :name "t" :expr {:type "lit-int" :value 1}} + {:type "ident" :name "t"})}) + +(st-test + "block with params and temps" + (st-parse-expr "[:x | | t | t := x + 1. t]") + {:type "block" + :params (list "x") + :temps (list "t") + :body (list + {:type "assign" + :name "t" + :expr {:type "send" + :receiver {:type "ident" :name "x"} + :selector "+" + :args (list {:type "lit-int" :value 1})}} + {:type "ident" :name "t"})}) + +;; ── 11. Assignment / return / statements ── +(st-test + "assignment" + (st-parse-expr "x := 1") + {:type "assign" :name "x" :expr {:type "lit-int" :value 1}}) + +(st-test + "return" + (st-parse-expr "1") + {:type "lit-int" :value 1}) + +(st-test + "return statement at top level" + (st-parse "^ 1") + {:type "seq" :temps (list) + :exprs (list {:type "return" :expr {:type "lit-int" :value 1}})}) + +(st-test + "two statements" + (st-parse "x := 1. y := 2") + {:type "seq" :temps (list) + :exprs (list + {:type "assign" :name "x" :expr {:type "lit-int" :value 1}} + {:type "assign" :name "y" :expr {:type "lit-int" :value 2}})}) + +(st-test + "trailing dot allowed" + (st-parse "1. 2.") + {:type "seq" :temps (list) + :exprs (list {:type "lit-int" :value 1} {:type "lit-int" :value 2})}) + +;; ── 12. Method headers ── +(st-test + "unary method" + (st-parse-method "factorial ^ self * (self - 1) factorial") + {:type "method" + :selector "factorial" + :params (list) + :temps (list) + :pragmas (list) + :body (list + {:type "return" + :expr {:type "send" + :receiver {:type "self"} + :selector "*" + :args (list + {:type "send" + :receiver {:type "send" + :receiver {:type "self"} + :selector "-" + :args (list {:type "lit-int" :value 1})} + :selector "factorial" + :args (list)})}})}) + +(st-test + "binary method" + (st-parse-method "+ other ^ 'plus'") + {:type "method" + :selector "+" + :params (list "other") + :temps (list) + :pragmas (list) + :body (list {:type "return" :expr {:type "lit-string" :value "plus"}})}) + +(st-test + "keyword method" + (st-parse-method "at: i put: v ^ v") + {:type "method" + :selector "at:put:" + :params (list "i" "v") + :temps (list) + :pragmas (list) + :body (list {:type "return" :expr {:type "ident" :name "v"}})}) + +(st-test + "method with temps" + (st-parse-method "twice: x | t | t := x + x. ^ t") + {:type "method" + :selector "twice:" + :params (list "x") + :temps (list "t") + :pragmas (list) + :body (list + {:type "assign" + :name "t" + :expr {:type "send" + :receiver {:type "ident" :name "x"} + :selector "+" + :args (list {:type "ident" :name "x"})}} + {:type "return" :expr {:type "ident" :name "t"}})}) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/parse_chunks.sx b/lib/smalltalk/tests/parse_chunks.sx new file mode 100644 index 00000000..e46d9884 --- /dev/null +++ b/lib/smalltalk/tests/parse_chunks.sx @@ -0,0 +1,294 @@ +;; Smalltalk chunk-stream parser + pragma tests. +;; +;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset +;; here so this file's summary covers chunk + pragma tests only. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +;; ── 1. Raw chunk reader ── +(st-test "empty source" (st-read-chunks "") (list)) +(st-test "single chunk" (st-read-chunks "foo!") (list "foo")) +(st-test "two chunks" (st-read-chunks "a! b!") (list "a" "b")) +(st-test "trailing no bang" (st-read-chunks "a! b") (list "a" "b")) +(st-test "empty chunk" (st-read-chunks "a! ! b!") (list "a" "" "b")) +(st-test + "doubled bang escapes" + (st-read-chunks "yes!! no!yes!") + (list "yes! no" "yes")) +(st-test + "whitespace trimmed" + (st-read-chunks " \n hello \n !") + (list "hello")) + +;; ── 2. Chunk parser — do-it mode ── +(st-test + "single do-it chunk" + (st-parse-chunks "1 + 2!") + (list + {:kind "expr" + :ast {:type "send" + :receiver {:type "lit-int" :value 1} + :selector "+" + :args (list {:type "lit-int" :value 2})}})) + +(st-test + "two do-it chunks" + (st-parse-chunks "x := 1! y := 2!") + (list + {:kind "expr" + :ast {:type "assign" :name "x" :expr {:type "lit-int" :value 1}}} + {:kind "expr" + :ast {:type "assign" :name "y" :expr {:type "lit-int" :value 2}}})) + +(st-test + "blank chunk outside methods" + (st-parse-chunks "1! ! 2!") + (list + {:kind "expr" :ast {:type "lit-int" :value 1}} + {:kind "blank"} + {:kind "expr" :ast {:type "lit-int" :value 2}})) + +;; ── 3. Methods batch ── +(st-test + "methodsFor opens method batch" + (st-parse-chunks + "Foo methodsFor: 'access'! foo ^ 1! bar ^ 2! !") + (list + {:kind "expr" + :ast {:type "send" + :receiver {:type "ident" :name "Foo"} + :selector "methodsFor:" + :args (list {:type "lit-string" :value "access"})}} + {:kind "method" + :class "Foo" + :class-side? false + :category "access" + :ast {:type "method" + :selector "foo" + :params (list) + :temps (list) + :pragmas (list) + :body (list + {:type "return" :expr {:type "lit-int" :value 1}})}} + {:kind "method" + :class "Foo" + :class-side? false + :category "access" + :ast {:type "method" + :selector "bar" + :params (list) + :temps (list) + :pragmas (list) + :body (list + {:type "return" :expr {:type "lit-int" :value 2}})}} + {:kind "end-methods"})) + +(st-test + "class-side methodsFor" + (st-parse-chunks + "Foo class methodsFor: 'creation'! make ^ self new! !") + (list + {:kind "expr" + :ast {:type "send" + :receiver {:type "send" + :receiver {:type "ident" :name "Foo"} + :selector "class" + :args (list)} + :selector "methodsFor:" + :args (list {:type "lit-string" :value "creation"})}} + {:kind "method" + :class "Foo" + :class-side? true + :category "creation" + :ast {:type "method" + :selector "make" + :params (list) + :temps (list) + :pragmas (list) + :body (list + {:type "return" + :expr {:type "send" + :receiver {:type "self"} + :selector "new" + :args (list)}})}} + {:kind "end-methods"})) + +(st-test + "method batch returns to do-it after empty chunk" + (st-parse-chunks + "Foo methodsFor: 'a'! m1 ^ 1! ! 99!") + (list + {:kind "expr" + :ast {:type "send" + :receiver {:type "ident" :name "Foo"} + :selector "methodsFor:" + :args (list {:type "lit-string" :value "a"})}} + {:kind "method" + :class "Foo" + :class-side? false + :category "a" + :ast {:type "method" + :selector "m1" + :params (list) + :temps (list) + :pragmas (list) + :body (list + {:type "return" :expr {:type "lit-int" :value 1}})}} + {:kind "end-methods"} + {:kind "expr" :ast {:type "lit-int" :value 99}})) + +;; ── 4. Pragmas in method bodies ── +(st-test + "single pragma" + (st-parse-method "primAt: i ^ self") + {:type "method" + :selector "primAt:" + :params (list "i") + :temps (list) + :pragmas (list + {:selector "primitive:" + :args (list {:type "lit-int" :value 60})}) + :body (list {:type "return" :expr {:type "self"}})}) + +(st-test + "pragma with two keyword pairs" + (st-parse-method "fft ^ nil") + {:type "method" + :selector "fft" + :params (list) + :temps (list) + :pragmas (list + {:selector "primitive:module:" + :args (list + {:type "lit-int" :value 1} + {:type "lit-string" :value "fft"})}) + :body (list {:type "return" :expr {:type "lit-nil"}})}) + +(st-test + "pragma with negative number" + (st-parse-method "neg ^ nil") + {:type "method" + :selector "neg" + :params (list) + :temps (list) + :pragmas (list + {:selector "primitive:" + :args (list {:type "lit-int" :value -1})}) + :body (list {:type "return" :expr {:type "lit-nil"}})}) + +(st-test + "pragma with symbol arg" + (st-parse-method "tagged ^ nil") + {:type "method" + :selector "tagged" + :params (list) + :temps (list) + :pragmas (list + {:selector "category:" + :args (list {:type "lit-symbol" :value "algebra"})}) + :body (list {:type "return" :expr {:type "lit-nil"}})}) + +(st-test + "pragma then temps" + (st-parse-method "calc | t | t := 5. ^ t") + {:type "method" + :selector "calc" + :params (list) + :temps (list "t") + :pragmas (list + {:selector "primitive:" + :args (list {:type "lit-int" :value 1})}) + :body (list + {:type "assign" :name "t" :expr {:type "lit-int" :value 5}} + {:type "return" :expr {:type "ident" :name "t"}})}) + +(st-test + "temps then pragma" + (st-parse-method "calc | t | t := 5. ^ t") + {:type "method" + :selector "calc" + :params (list) + :temps (list "t") + :pragmas (list + {:selector "primitive:" + :args (list {:type "lit-int" :value 1})}) + :body (list + {:type "assign" :name "t" :expr {:type "lit-int" :value 5}} + {:type "return" :expr {:type "ident" :name "t"}})}) + +(st-test + "two pragmas" + (st-parse-method "m ^ self") + {:type "method" + :selector "m" + :params (list) + :temps (list) + :pragmas (list + {:selector "primitive:" + :args (list {:type "lit-int" :value 1})} + {:selector "category:" + :args (list {:type "lit-string" :value "a"})}) + :body (list {:type "return" :expr {:type "self"}})}) + +;; ── 5. End-to-end: a small "filed-in" snippet ── +(st-test + "small filed-in class snippet" + (st-parse-chunks + "Object subclass: #Account + instanceVariableNames: 'balance'! + + !Account methodsFor: 'access'! + balance + ^ balance! + + deposit: amount + balance := balance + amount. + ^ self! !") + (list + {:kind "expr" + :ast {:type "send" + :receiver {:type "ident" :name "Object"} + :selector "subclass:instanceVariableNames:" + :args (list + {:type "lit-symbol" :value "Account"} + {:type "lit-string" :value "balance"})}} + {:kind "blank"} + {:kind "expr" + :ast {:type "send" + :receiver {:type "ident" :name "Account"} + :selector "methodsFor:" + :args (list {:type "lit-string" :value "access"})}} + {:kind "method" + :class "Account" + :class-side? false + :category "access" + :ast {:type "method" + :selector "balance" + :params (list) + :temps (list) + :pragmas (list) + :body (list + {:type "return" + :expr {:type "ident" :name "balance"}})}} + {:kind "method" + :class "Account" + :class-side? false + :category "access" + :ast {:type "method" + :selector "deposit:" + :params (list "amount") + :temps (list) + :pragmas (list) + :body (list + {:type "assign" + :name "balance" + :expr {:type "send" + :receiver {:type "ident" :name "balance"} + :selector "+" + :args (list {:type "ident" :name "amount"})}} + {:type "return" :expr {:type "self"}})}} + {:kind "end-methods"})) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/pharo.sx b/lib/smalltalk/tests/pharo.sx new file mode 100644 index 00000000..fedcefe3 --- /dev/null +++ b/lib/smalltalk/tests/pharo.sx @@ -0,0 +1,264 @@ +;; Vendor a slice of Pharo Kernel-Tests / Collections-Tests. +;; +;; The .st files in tests/pharo/ define TestCase subclasses with `test*` +;; methods. This harness reads them, asks the SUnit framework for the +;; per-class test selector list, runs each test individually, and emits +;; one st-test row per Smalltalk test method — so each Pharo test counts +;; toward the scoreboard's grand total. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +;; The runtime is already loaded by test.sh. The class table has SUnit +;; (also bootstrapped by test.sh). We need to install the Pharo test +;; classes before iterating them. + +(define + pharo-kernel-source + "TestCase subclass: #IntegerTest instanceVariableNames: ''! + + !IntegerTest methodsFor: 'arithmetic'! + testAddition self assert: 2 + 3 equals: 5! + testSubtraction self assert: 10 - 4 equals: 6! + testMultiplication self assert: 6 * 7 equals: 42! + testDivisionExact self assert: 10 / 2 equals: 5! + testNegation self assert: 7 negated equals: -7! + testAbs self assert: -5 abs equals: 5! + testZero self assert: 0 + 0 equals: 0! + testIdentity self assert: 42 == 42! ! + + !IntegerTest methodsFor: 'comparison'! + testLessThan self assert: 1 < 2! + testLessOrEqual self assert: 5 <= 5! + testGreater self assert: 10 > 3! + testEqualSelf self assert: 7 = 7! + testNotEqual self assert: (3 ~= 5)! + testBetween self assert: (5 between: 1 and: 10)! ! + + !IntegerTest methodsFor: 'predicates'! + testEvenTrue self assert: 4 even! + testEvenFalse self deny: 5 even! + testOdd self assert: 3 odd! + testIsInteger self assert: 0 isInteger! + testIsNumber self assert: 1 isNumber! + testIsZero self assert: 0 isZero! + testIsNotZero self deny: 1 isZero! ! + + !IntegerTest methodsFor: 'powers and roots'! + testFactorialZero self assert: 0 factorial equals: 1! + testFactorialFive self assert: 5 factorial equals: 120! + testRaisedTo self assert: (2 raisedTo: 8) equals: 256! + testSquared self assert: 9 squared equals: 81! + testSqrtPerfect self assert: 16 sqrt equals: 4! + testGcd self assert: (24 gcd: 18) equals: 6! + testLcm self assert: (4 lcm: 6) equals: 12! ! + + !IntegerTest methodsFor: 'rounding'! + testFloor self assert: 3.7 floor equals: 3! + testCeiling self assert: 3.2 ceiling equals: 4! + testTruncated self assert: -3.7 truncated equals: -3! + testRounded self assert: 3.5 rounded equals: 4! ! + + TestCase subclass: #StringTest instanceVariableNames: ''! + + !StringTest methodsFor: 'access'! + testSize self assert: 'hello' size equals: 5! + testEmpty self assert: '' isEmpty! + testNotEmpty self assert: 'a' notEmpty! + testAtFirst self assert: ('hello' at: 1) equals: 'h'! + testAtLast self assert: ('hello' at: 5) equals: 'o'! + testFirst self assert: 'world' first equals: 'w'! + testLast self assert: 'world' last equals: 'd'! ! + + !StringTest methodsFor: 'concatenation'! + testCommaConcat self assert: 'hello, ' , 'world' equals: 'hello, world'! + testEmptyConcat self assert: '' , 'x' equals: 'x'! + testSelfConcat self assert: 'ab' , 'ab' equals: 'abab'! ! + + !StringTest methodsFor: 'comparisons'! + testEqual self assert: 'a' = 'a'! + testNotEqualStr self deny: 'a' = 'b'! + testIncludes self assert: ('banana' includes: $a)! + testIncludesNot self deny: ('banana' includes: $z)! + testIndexOf self assert: ('abcde' indexOf: $c) equals: 3! ! + + !StringTest methodsFor: 'transforms'! + testCopyFromTo self assert: ('helloworld' copyFrom: 6 to: 10) equals: 'world'! ! + + TestCase subclass: #BooleanTest instanceVariableNames: ''! + + !BooleanTest methodsFor: 'logic'! + testNotTrue self deny: true not! + testNotFalse self assert: false not! + testAnd self assert: (true & true)! + testOr self assert: (true | false)! + testIfTrueTaken self assert: (true ifTrue: [1] ifFalse: [2]) equals: 1! + testIfFalseTaken self assert: (false ifTrue: [1] ifFalse: [2]) equals: 2! + testAndShortCircuit self assert: (false and: [1/0]) equals: false! + testOrShortCircuit self assert: (true or: [1/0]) equals: true! !") + +(define + pharo-collections-source + "TestCase subclass: #ArrayTest instanceVariableNames: ''! + + !ArrayTest methodsFor: 'creation'! + testNewSize self assert: (Array new: 5) size equals: 5! + testLiteralSize self assert: #(1 2 3) size equals: 3! + testEmpty self assert: #() isEmpty! + testNotEmpty self assert: #(1) notEmpty! + testFirst self assert: #(10 20 30) first equals: 10! + testLast self assert: #(10 20 30) last equals: 30! ! + + !ArrayTest methodsFor: 'access'! + testAt self assert: (#(10 20 30) at: 2) equals: 20! + testAtPut + | a | + a := Array new: 3. + a at: 1 put: 'x'. a at: 2 put: 'y'. a at: 3 put: 'z'. + self assert: (a at: 2) equals: 'y'! ! + + !ArrayTest methodsFor: 'iteration'! + testDoSum + | s | + s := 0. + #(1 2 3 4 5) do: [:e | s := s + e]. + self assert: s equals: 15! + + testInjectInto self assert: (#(1 2 3 4) inject: 0 into: [:a :b | a + b]) equals: 10! + + testCollect self assert: (#(1 2 3) collect: [:x | x * x]) equals: #(1 4 9)! + + testSelect self assert: (#(1 2 3 4 5) select: [:x | x > 2]) equals: #(3 4 5)! + + testReject self assert: (#(1 2 3 4 5) reject: [:x | x > 2]) equals: #(1 2)! + + testDetect self assert: (#(1 3 5 7) detect: [:x | x > 4]) equals: 5! + + testCount self assert: (#(1 2 3 4 5) count: [:x | x even]) equals: 2! + + testAnySatisfy self assert: (#(1 2 3) anySatisfy: [:x | x > 2])! + + testAllSatisfy self assert: (#(2 4 6) allSatisfy: [:x | x even])! + + testIncludes self assert: (#(1 2 3) includes: 2)! + + testIncludesNotArr self deny: (#(1 2 3) includes: 99)! + + testIndexOfArr self assert: (#(10 20 30) indexOf: 30) equals: 3! + + testIndexOfMissing self assert: (#(1 2 3) indexOf: 99) equals: 0! ! + + TestCase subclass: #DictionaryTest instanceVariableNames: ''! + + !DictionaryTest methodsFor: 'tests'! + testEmpty self assert: Dictionary new isEmpty! + + testAtPutThenAt + | d | + d := Dictionary new. + d at: #a put: 1. + self assert: (d at: #a) equals: 1! + + testAtMissingNil self assert: (Dictionary new at: #nope) equals: nil! + + testAtIfAbsent + self assert: (Dictionary new at: #nope ifAbsent: [#absent]) equals: #absent! + + testSize + | d | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. d at: #c put: 3. + self assert: d size equals: 3! + + testIncludesKey + | d | + d := Dictionary new. + d at: #a put: 1. + self assert: (d includesKey: #a)! + + testRemoveKey + | d | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. + d removeKey: #a. + self deny: (d includesKey: #a)! + + testOverwrite + | d | + d := Dictionary new. + d at: #x put: 1. d at: #x put: 99. + self assert: (d at: #x) equals: 99! ! + + TestCase subclass: #SetTest instanceVariableNames: ''! + + !SetTest methodsFor: 'tests'! + testEmpty self assert: Set new isEmpty! + + testAdd + | s | + s := Set new. + s add: 1. + self assert: (s includes: 1)! + + testDedup + | s | + s := Set new. + s add: 1. s add: 1. s add: 1. + self assert: s size equals: 1! + + testRemove + | s | + s := Set new. + s add: 1. s add: 2. + s remove: 1. + self deny: (s includes: 1)! + + testAddAll + | s | + s := Set new. + s addAll: #(1 2 3 2 1). + self assert: s size equals: 3! + + testDoSum + | s sum | + s := Set new. + s add: 10. s add: 20. s add: 30. + sum := 0. + s do: [:e | sum := sum + e]. + self assert: sum equals: 60! !") + +(smalltalk-load pharo-kernel-source) +(smalltalk-load pharo-collections-source) + +;; Run each test method individually and create one st-test row per test. +;; A pharo test name like "IntegerTest >> testAddition" passes when the +;; SUnit run yields exactly one pass and zero failures. +(define + pharo-test-class + (fn + (cls-name) + (let ((selectors (sort (keys (get (st-class-get cls-name) :methods))))) + (for-each + (fn (sel) + (when + (and (>= (len sel) 4) (= (slice sel 0 4) "test")) + (let + ((src (str "| s r | s := " cls-name " suiteForAll: #(#" + sel "). r := s run. + ^ {(r passCount). (r failureCount). (r errorCount)}"))) + (let ((result (smalltalk-eval-program src))) + (st-test + (str cls-name " >> " sel) + result + (list 1 0 0)))))) + selectors)))) + +(pharo-test-class "IntegerTest") +(pharo-test-class "StringTest") +(pharo-test-class "BooleanTest") +(pharo-test-class "ArrayTest") +(pharo-test-class "DictionaryTest") +(pharo-test-class "SetTest") + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/pharo/collections.st b/lib/smalltalk/tests/pharo/collections.st new file mode 100644 index 00000000..4f9ddd6d --- /dev/null +++ b/lib/smalltalk/tests/pharo/collections.st @@ -0,0 +1,137 @@ +"Pharo Collections-Tests slice — Array, Dictionary, Set." + +TestCase subclass: #ArrayTest + instanceVariableNames: ''! + +!ArrayTest methodsFor: 'creation'! +testNewSize self assert: (Array new: 5) size equals: 5! +testLiteralSize self assert: #(1 2 3) size equals: 3! +testEmpty self assert: #() isEmpty! +testNotEmpty self assert: #(1) notEmpty! +testFirst self assert: #(10 20 30) first equals: 10! +testLast self assert: #(10 20 30) last equals: 30! ! + +!ArrayTest methodsFor: 'access'! +testAt self assert: (#(10 20 30) at: 2) equals: 20! +testAtPut + | a | + a := Array new: 3. + a at: 1 put: 'x'. + a at: 2 put: 'y'. + a at: 3 put: 'z'. + self assert: (a at: 2) equals: 'y'! ! + +!ArrayTest methodsFor: 'iteration'! +testDoSum + | s | + s := 0. + #(1 2 3 4 5) do: [:e | s := s + e]. + self assert: s equals: 15! + +testInjectInto self assert: (#(1 2 3 4) inject: 0 into: [:a :b | a + b]) equals: 10! + +testCollect self assert: (#(1 2 3) collect: [:x | x * x]) equals: #(1 4 9)! + +testSelect self assert: (#(1 2 3 4 5) select: [:x | x > 2]) equals: #(3 4 5)! + +testReject self assert: (#(1 2 3 4 5) reject: [:x | x > 2]) equals: #(1 2)! + +testDetect self assert: (#(1 3 5 7) detect: [:x | x > 4]) equals: 5! + +testCount self assert: (#(1 2 3 4 5) count: [:x | x even]) equals: 2! + +testAnySatisfy self assert: (#(1 2 3) anySatisfy: [:x | x > 2])! + +testAllSatisfy self assert: (#(2 4 6) allSatisfy: [:x | x even])! + +testIncludes self assert: (#(1 2 3) includes: 2)! + +testIncludesNot self deny: (#(1 2 3) includes: 99)! + +testIndexOf self assert: (#(10 20 30) indexOf: 30) equals: 3! + +testIndexOfMissing self assert: (#(1 2 3) indexOf: 99) equals: 0! ! + +TestCase subclass: #DictionaryTest + instanceVariableNames: ''! + +!DictionaryTest methodsFor: 'fixture'! +setUp ^ self! ! + +!DictionaryTest methodsFor: 'tests'! +testEmpty self assert: Dictionary new isEmpty! + +testAtPutThenAt + | d | + d := Dictionary new. + d at: #a put: 1. + self assert: (d at: #a) equals: 1! + +testAtMissingNil self assert: (Dictionary new at: #nope) equals: nil! + +testAtIfAbsent + self assert: (Dictionary new at: #nope ifAbsent: [#absent]) equals: #absent! + +testSize + | d | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. d at: #c put: 3. + self assert: d size equals: 3! + +testIncludesKey + | d | + d := Dictionary new. + d at: #a put: 1. + self assert: (d includesKey: #a)! + +testRemoveKey + | d | + d := Dictionary new. + d at: #a put: 1. d at: #b put: 2. + d removeKey: #a. + self deny: (d includesKey: #a)! + +testOverwrite + | d | + d := Dictionary new. + d at: #x put: 1. d at: #x put: 99. + self assert: (d at: #x) equals: 99! ! + +TestCase subclass: #SetTest + instanceVariableNames: ''! + +!SetTest methodsFor: 'tests'! +testEmpty self assert: Set new isEmpty! + +testAdd + | s | + s := Set new. + s add: 1. + self assert: (s includes: 1)! + +testDedup + | s | + s := Set new. + s add: 1. s add: 1. s add: 1. + self assert: s size equals: 1! + +testRemove + | s | + s := Set new. + s add: 1. s add: 2. + s remove: 1. + self deny: (s includes: 1)! + +testAddAll + | s | + s := Set new. + s addAll: #(1 2 3 2 1). + self assert: s size equals: 3! + +testDoSum + | s sum | + s := Set new. + s add: 10. s add: 20. s add: 30. + sum := 0. + s do: [:e | sum := sum + e]. + self assert: sum equals: 60! ! diff --git a/lib/smalltalk/tests/pharo/kernel.st b/lib/smalltalk/tests/pharo/kernel.st new file mode 100644 index 00000000..7384f803 --- /dev/null +++ b/lib/smalltalk/tests/pharo/kernel.st @@ -0,0 +1,89 @@ +"Pharo Kernel-Tests slice — small subset of the canonical Pharo unit + tests for SmallInteger, Float, String, Symbol, Boolean, Character. + Runs through the SUnit framework defined in lib/smalltalk/sunit.sx." + +TestCase subclass: #IntegerTest + instanceVariableNames: ''! + +!IntegerTest methodsFor: 'arithmetic'! +testAddition self assert: 2 + 3 equals: 5! +testSubtraction self assert: 10 - 4 equals: 6! +testMultiplication self assert: 6 * 7 equals: 42! +testDivisionExact self assert: 10 / 2 equals: 5! +testNegation self assert: 7 negated equals: -7! +testAbs self assert: -5 abs equals: 5! +testZero self assert: 0 + 0 equals: 0! +testIdentity self assert: 42 == 42! ! + +!IntegerTest methodsFor: 'comparison'! +testLessThan self assert: 1 < 2! +testLessOrEqual self assert: 5 <= 5! +testGreater self assert: 10 > 3! +testEqualSelf self assert: 7 = 7! +testNotEqual self assert: (3 ~= 5)! +testBetween self assert: (5 between: 1 and: 10)! ! + +!IntegerTest methodsFor: 'predicates'! +testEvenTrue self assert: 4 even! +testEvenFalse self deny: 5 even! +testOdd self assert: 3 odd! +testIsInteger self assert: 0 isInteger! +testIsNumber self assert: 1 isNumber! +testIsZero self assert: 0 isZero! +testIsNotZero self deny: 1 isZero! ! + +!IntegerTest methodsFor: 'powers and roots'! +testFactorialZero self assert: 0 factorial equals: 1! +testFactorialFive self assert: 5 factorial equals: 120! +testRaisedTo self assert: (2 raisedTo: 8) equals: 256! +testSquared self assert: 9 squared equals: 81! +testSqrtPerfect self assert: 16 sqrt equals: 4! +testGcd self assert: (24 gcd: 18) equals: 6! +testLcm self assert: (4 lcm: 6) equals: 12! ! + +!IntegerTest methodsFor: 'rounding'! +testFloor self assert: 3.7 floor equals: 3! +testCeiling self assert: 3.2 ceiling equals: 4! +testTruncated self assert: -3.7 truncated equals: -3! +testRounded self assert: 3.5 rounded equals: 4! ! + +TestCase subclass: #StringTest + instanceVariableNames: ''! + +!StringTest methodsFor: 'access'! +testSize self assert: 'hello' size equals: 5! +testEmpty self assert: '' isEmpty! +testNotEmpty self assert: 'a' notEmpty! +testAtFirst self assert: ('hello' at: 1) equals: 'h'! +testAtLast self assert: ('hello' at: 5) equals: 'o'! +testFirst self assert: 'world' first equals: 'w'! +testLast self assert: 'world' last equals: 'd'! ! + +!StringTest methodsFor: 'concatenation'! +testCommaConcat self assert: 'hello, ' , 'world' equals: 'hello, world'! +testEmptyConcat self assert: '' , 'x' equals: 'x'! +testSelfConcat self assert: 'ab' , 'ab' equals: 'abab'! ! + +!StringTest methodsFor: 'comparisons'! +testEqual self assert: 'a' = 'a'! +testNotEqual self deny: 'a' = 'b'! +testIncludes self assert: ('banana' includes: $a)! +testIncludesNot self deny: ('banana' includes: $z)! +testIndexOf self assert: ('abcde' indexOf: $c) equals: 3! ! + +!StringTest methodsFor: 'transforms'! +testCopyFromTo self assert: ('helloworld' copyFrom: 6 to: 10) equals: 'world'! +testFormat self assert: ('Hello, {1}!' format: #('World')) equals: 'Hello, World!'! ! + +TestCase subclass: #BooleanTest + instanceVariableNames: ''! + +!BooleanTest methodsFor: 'logic'! +testNotTrue self deny: true not! +testNotFalse self assert: false not! +testAnd self assert: (true & true)! +testOr self assert: (true | false)! +testIfTrueTaken self assert: (true ifTrue: [1] ifFalse: [2]) equals: 1! +testIfFalseTaken self assert: (false ifTrue: [1] ifFalse: [2]) equals: 2! +testAndShortCircuit self assert: (false and: [1/0]) equals: false! +testOrShortCircuit self assert: (true or: [1/0]) equals: true! ! diff --git a/lib/smalltalk/tests/printing.sx b/lib/smalltalk/tests/printing.sx new file mode 100644 index 00000000..8ed1bb09 --- /dev/null +++ b/lib/smalltalk/tests/printing.sx @@ -0,0 +1,122 @@ +;; String>>format: and printOn: tests. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. String>>format: ── +(st-test "format: single placeholder" + (ev "'Hello, {1}!' format: #('World')") + "Hello, World!") + +(st-test "format: multiple placeholders" + (ev "'{1} + {2} = {3}' format: #(1 2 3)") + "1 + 2 = 3") + +(st-test "format: out-of-order" + (ev "'{2} {1}' format: #('first' 'second')") + "second first") + +(st-test "format: repeated index" + (ev "'{1}-{1}-{1}' format: #(#a)") + "a-a-a") + +(st-test "format: empty source" + (ev "'' format: #()") "") + +(st-test "format: no placeholders" + (ev "'plain text' format: #()") "plain text") + +(st-test "format: unmatched {" + (ev "'open { brace' format: #('x')") + "open { brace") + +(st-test "format: out-of-range index keeps literal" + (ev "'{99}' format: #('hi')") + "{99}") + +(st-test "format: numeric arg" + (ev "'value: {1}' format: #(42)") + "value: 42") + +(st-test "format: float arg" + (ev "'pi ~ {1}' format: #(3.14)") + "pi ~ 3.14") + +;; ── 2. printOn: writes printString to stream ── +(st-test "printOn: writes int via stream" + (evp + "| s | + s := WriteStream on: (Array new: 0). + 42 printOn: s. + ^ s contents") + (list "4" "2")) + +(st-test "printOn: writes string" + (evp + "| s | + s := WriteStream on: (Array new: 0). + 'hi' printOn: s. + ^ s contents") + (list "'" "h" "i" "'")) + +(st-test "printOn: returns receiver" + (evp + "| s | + s := WriteStream on: (Array new: 0). + ^ 99 printOn: s") + 99) + +;; ── 3. Universal printString fallback for user instances ── +(st-class-define! "Cat" "Object" (list)) +(st-class-define! "Animal" "Object" (list)) + +(st-test "printString of vowel-initial class" + (evp "^ Animal new printString") + "an Animal") + +(st-test "printString of consonant-initial class" + (evp "^ Cat new printString") + "a Cat") + +(st-test "user override of printString wins" + (begin + (st-class-add-method! "Cat" "printString" + (st-parse-method "printString ^ #miaow asString")) + (str (evp "^ Cat new printString"))) + "miaow") + +;; ── 4. printOn: on user instance with overridden printString ── +(st-test "printOn: respects user-overridden printString" + (evp + "| s | + s := WriteStream on: (Array new: 0). + Cat new printOn: s. + ^ s contents") + (list "m" "i" "a" "o" "w")) + +;; ── 5. printString for class-refs ── +(st-test "Class printString is its name" + (ev "Animal printString") "Animal") + +;; ── 6. format: combined with printString ── +(st-class-define! "Box" "Object" (list "n")) +(st-class-add-method! "Box" "n:" + (st-parse-method "n: v n := v. ^ self")) +(st-class-add-method! "Box" "printString" + (st-parse-method "printString ^ '<' , n printString , '>'")) + +(st-test "format: with custom printString in arg" + (str (evp + "| b | b := Box new n: 7. + ^ '({1})' format: (Array with: b printString)")) + "(<7>)") + +(st-class-add-class-method! "Array" "with:" + (st-parse-method "with: x | a | a := Array new: 1. a at: 1 put: x. ^ a")) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/programs.sx b/lib/smalltalk/tests/programs.sx new file mode 100644 index 00000000..c622d3fe --- /dev/null +++ b/lib/smalltalk/tests/programs.sx @@ -0,0 +1,406 @@ +;; Classic programs corpus tests. +;; +;; Each program lives in tests/programs/*.st as canonical Smalltalk source. +;; This file embeds the same source as a string (until a file-read primitive +;; lands) and runs it via smalltalk-load, then asserts behaviour. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── fibonacci.st (kept in sync with lib/smalltalk/tests/programs/fibonacci.st) ── +(define + fib-source + "Object subclass: #Fibonacci + instanceVariableNames: 'memo'! + + !Fibonacci methodsFor: 'init'! + init memo := Array new: 100. ^ self! ! + + !Fibonacci methodsFor: 'compute'! + fib: n + n < 2 ifTrue: [^ n]. + ^ (self fib: n - 1) + (self fib: n - 2)! + + memoFib: n + | cached | + cached := memo at: n + 1. + cached notNil ifTrue: [^ cached]. + cached := n < 2 + ifTrue: [n] + ifFalse: [(self memoFib: n - 1) + (self memoFib: n - 2)]. + memo at: n + 1 put: cached. + ^ cached! !") + +(st-bootstrap-classes!) +(smalltalk-load fib-source) + +(st-test "fib(0)" (evp "^ Fibonacci new fib: 0") 0) +(st-test "fib(1)" (evp "^ Fibonacci new fib: 1") 1) +(st-test "fib(2)" (evp "^ Fibonacci new fib: 2") 1) +(st-test "fib(5)" (evp "^ Fibonacci new fib: 5") 5) +(st-test "fib(10)" (evp "^ Fibonacci new fib: 10") 55) +(st-test "fib(15)" (evp "^ Fibonacci new fib: 15") 610) + +(st-test "memoFib(20)" + (evp "| f | f := Fibonacci new init. ^ f memoFib: 20") + 6765) + +(st-test "memoFib(30)" + (evp "| f | f := Fibonacci new init. ^ f memoFib: 30") + 832040) + +;; Memoisation actually populates the array. +(st-test "memo cache stores intermediate" + (evp + "| f | f := Fibonacci new init. + f memoFib: 12. + ^ #(0 1 1 2 3 5) , #() , #()") + (list 0 1 1 2 3 5)) + +;; The class is reachable from the bootstrap class table. +(st-test "Fibonacci class exists in table" (st-class-exists? "Fibonacci") true) +(st-test "Fibonacci has memo ivar" + (get (st-class-get "Fibonacci") :ivars) + (list "memo")) + +;; Method dictionary holds the three methods. +(st-test "Fibonacci methodDict size" + (len (keys (get (st-class-get "Fibonacci") :methods))) + 3) + +;; Each fib call is independent (no shared state between two instances). +(st-test "two memo instances independent" + (evp + "| a b | + a := Fibonacci new init. + b := Fibonacci new init. + a memoFib: 10. + ^ b memoFib: 10") + 55) + +;; ── eight-queens.st (kept in sync with lib/smalltalk/tests/programs/eight-queens.st) ── +(define + queens-source + "Object subclass: #EightQueens + instanceVariableNames: 'columns count size'! + + !EightQueens methodsFor: 'init'! + init + size := 8. + columns := Array new: size. + count := 0. + ^ self! + + size: n + size := n. + columns := Array new: n. + count := 0. + ^ self! ! + + !EightQueens methodsFor: 'access'! + count ^ count! + + size ^ size! ! + + !EightQueens methodsFor: 'solve'! + solve + self placeRow: 1. + ^ count! + + placeRow: row + row > size ifTrue: [count := count + 1. ^ self]. + 1 to: size do: [:col | + (self isSafe: col atRow: row) ifTrue: [ + columns at: row put: col. + self placeRow: row + 1]]! + + isSafe: col atRow: row + | r prevCol delta | + r := 1. + [r < row] whileTrue: [ + prevCol := columns at: r. + prevCol = col ifTrue: [^ false]. + delta := col - prevCol. + delta abs = (row - r) ifTrue: [^ false]. + r := r + 1]. + ^ true! !") + +(smalltalk-load queens-source) + +;; Backtracking is correct but slow on the spec interpreter (call/cc per +;; method, dict-based ivar reads). 4- and 5-queens cover the corners +;; and run in under 10s; 6+ work but would push past the test-runner +;; timeout. The class itself defaults to size 8, ready for the JIT. +(st-test "1 queen on 1x1 board" (evp "^ (EightQueens new size: 1) solve") 1) +(st-test "4 queens on 4x4 board" (evp "^ (EightQueens new size: 4) solve") 2) +(st-test "5 queens on 5x5 board" (evp "^ (EightQueens new size: 5) solve") 10) +(st-test "EightQueens class is registered" (st-class-exists? "EightQueens") true) +(st-test "EightQueens init sets size 8" + (evp "^ EightQueens new init size") 8) + +;; ── quicksort.st ───────────────────────────────────────────────────── +(define + quicksort-source + "Object subclass: #Quicksort + instanceVariableNames: ''! + + !Quicksort methodsFor: 'sort'! + sort: arr ^ self sort: arr from: 1 to: arr size! + + sort: arr from: low to: high + | p | + low < high ifTrue: [ + p := self partition: arr from: low to: high. + self sort: arr from: low to: p - 1. + self sort: arr from: p + 1 to: high]. + ^ arr! + + partition: arr from: low to: high + | pivot i tmp | + pivot := arr at: high. + i := low - 1. + low to: high - 1 do: [:j | + (arr at: j) <= pivot ifTrue: [ + i := i + 1. + tmp := arr at: i. + arr at: i put: (arr at: j). + arr at: j put: tmp]]. + tmp := arr at: i + 1. + arr at: i + 1 put: (arr at: high). + arr at: high put: tmp. + ^ i + 1! !") + +(smalltalk-load quicksort-source) + +(st-test "Quicksort class registered" (st-class-exists? "Quicksort") true) + +(st-test "qsort small array" + (evp "^ Quicksort new sort: #(3 1 2)") + (list 1 2 3)) + +(st-test "qsort with duplicates" + (evp "^ Quicksort new sort: #(3 1 4 1 5 9 2 6 5 3 5)") + (list 1 1 2 3 3 4 5 5 5 6 9)) + +(st-test "qsort already-sorted" + (evp "^ Quicksort new sort: #(1 2 3 4 5)") + (list 1 2 3 4 5)) + +(st-test "qsort reverse-sorted" + (evp "^ Quicksort new sort: #(9 7 5 3 1)") + (list 1 3 5 7 9)) + +(st-test "qsort single element" + (evp "^ Quicksort new sort: #(42)") + (list 42)) + +(st-test "qsort empty" + (evp "^ Quicksort new sort: #()") + (list)) + +(st-test "qsort negatives" + (evp "^ Quicksort new sort: #(-3 -1 -7 0 2)") + (list -7 -3 -1 0 2)) + +(st-test "qsort all-equal" + (evp "^ Quicksort new sort: #(5 5 5 5)") + (list 5 5 5 5)) + +(st-test "qsort sorts in place (returns same array)" + (evp + "| arr q | + arr := #(4 2 1 3). + q := Quicksort new. + q sort: arr. + ^ arr") + (list 1 2 3 4)) + +;; ── mandelbrot.st ──────────────────────────────────────────────────── +(define + mandel-source + "Object subclass: #Mandelbrot + instanceVariableNames: ''! + + !Mandelbrot methodsFor: 'iteration'! + escapeAt: cx and: cy maxIter: maxIter + | zx zy zx2 zy2 i | + zx := 0. zy := 0. + zx2 := 0. zy2 := 0. + i := 0. + [(zx2 + zy2 < 4) and: [i < maxIter]] whileTrue: [ + zy := (zx * zy * 2) + cy. + zx := zx2 - zy2 + cx. + zx2 := zx * zx. + zy2 := zy * zy. + i := i + 1]. + ^ i! + + inside: cx and: cy maxIter: maxIter + ^ (self escapeAt: cx and: cy maxIter: maxIter) >= maxIter! ! + + !Mandelbrot methodsFor: 'grid'! + countInsideRangeX: x0 to: x1 stepX: dx rangeY: y0 to: y1 stepY: dy maxIter: maxIter + | x y count | + count := 0. + y := y0. + [y <= y1] whileTrue: [ + x := x0. + [x <= x1] whileTrue: [ + (self inside: x and: y maxIter: maxIter) ifTrue: [count := count + 1]. + x := x + dx]. + y := y + dy]. + ^ count! !") + +(smalltalk-load mandel-source) + +(st-test "Mandelbrot class registered" (st-class-exists? "Mandelbrot") true) + +;; The origin is the cusp of the cardioid — z stays at 0 forever. +(st-test "origin is in the set" + (evp "^ Mandelbrot new inside: 0 and: 0 maxIter: 50") true) + +;; (-1, 0) — z₀=0, z₁=-1, z₂=0, … oscillates and stays bounded. +(st-test "(-1, 0) is in the set" + (evp "^ Mandelbrot new inside: -1 and: 0 maxIter: 50") true) + +;; (1, 0) — escapes after 2 iterations: 0 → 1 → 2, |z|² = 4 ≥ 4. +(st-test "(1, 0) escapes quickly" + (evp "^ Mandelbrot new escapeAt: 1 and: 0 maxIter: 50") 2) + +;; (2, 0) — escapes immediately: 0 → 2, |z|² = 4 ≥ 4 already. +(st-test "(2, 0) escapes after 1 step" + (evp "^ Mandelbrot new escapeAt: 2 and: 0 maxIter: 50") 1) + +;; (-2, 0) — z₀=0; iter 1: z₁=-2, |z|²=4, condition `< 4` fails → exits at i=1. +(st-test "(-2, 0) escapes after 1 step" + (evp "^ Mandelbrot new escapeAt: -2 and: 0 maxIter: 50") 1) + +;; (10, 10) — far outside, escapes on the first step. +(st-test "(10, 10) escapes after 1 step" + (evp "^ Mandelbrot new escapeAt: 10 and: 10 maxIter: 50") 1) + +;; Coarse 5x5 grid (-2..2 in 1-step increments, no half-steps to keep +;; this fast). Membership of (-1,0), (0,0), (-1,-1)? We expect just +;; (0,0) and (-1,0) at maxIter 30. +;; Actually let's count exact membership at this resolution. +(st-test "tiny 3x3 grid count" + (evp + "^ Mandelbrot new countInsideRangeX: -1 to: 1 stepX: 1 + rangeY: -1 to: 1 stepY: 1 + maxIter: 30") + ;; In-set points (bounded after 30 iters): (0,-1) (-1,0) (0,0) (0,1) → 4. + 4) + +;; ── life.st ────────────────────────────────────────────────────────── +(define + life-source + "Object subclass: #Life + instanceVariableNames: 'rows cols cells'! + + !Life methodsFor: 'init'! + rows: r cols: c + rows := r. cols := c. + cells := Array new: r * c. + 1 to: r * c do: [:i | cells at: i put: 0]. + ^ self! ! + + !Life methodsFor: 'access'! + rows ^ rows! + cols ^ cols! + + at: r at: c + ((r < 1) or: [r > rows]) ifTrue: [^ 0]. + ((c < 1) or: [c > cols]) ifTrue: [^ 0]. + ^ cells at: (r - 1) * cols + c! + + at: r at: c put: v + cells at: (r - 1) * cols + c put: v. + ^ v! ! + + !Life methodsFor: 'step'! + neighbors: r at: c + | sum | + sum := 0. + -1 to: 1 do: [:dr | + -1 to: 1 do: [:dc | + ((dr = 0) and: [dc = 0]) ifFalse: [ + sum := sum + (self at: r + dr at: c + dc)]]]. + ^ sum! + + step + | next | + next := Array new: rows * cols. + 1 to: rows * cols do: [:i | next at: i put: 0]. + 1 to: rows do: [:r | + 1 to: cols do: [:c | + | n alive lives | + n := self neighbors: r at: c. + alive := (self at: r at: c) = 1. + lives := alive + ifTrue: [(n = 2) or: [n = 3]] + ifFalse: [n = 3]. + lives ifTrue: [next at: (r - 1) * cols + c put: 1]]]. + cells := next. + ^ self! + + stepN: n + n timesRepeat: [self step]. + ^ self! ! + + !Life methodsFor: 'measure'! + livingCount + | sum | + sum := 0. + 1 to: rows * cols do: [:i | (cells at: i) = 1 ifTrue: [sum := sum + 1]]. + ^ sum! !") + +(smalltalk-load life-source) + +(st-test "Life class registered" (st-class-exists? "Life") true) + +;; Block (still life): four cells in a 2x2 stay forever after 1 step. +;; The bigger patterns are correct but the spec interpreter is too slow +;; for many-step verification — the `.st` file is ready for the JIT. +(st-test "block (still life) survives 1 step" + (evp + "| g | + g := Life new rows: 5 cols: 5. + g at: 2 at: 2 put: 1. + g at: 2 at: 3 put: 1. + g at: 3 at: 2 put: 1. + g at: 3 at: 3 put: 1. + g step. + ^ g livingCount") + 4) + +;; Blinker (period 2): horizontal row of 3 → vertical column. +(st-test "blinker after 1 step is vertical" + (evp + "| g | + g := Life new rows: 5 cols: 5. + g at: 3 at: 2 put: 1. + g at: 3 at: 3 put: 1. + g at: 3 at: 4 put: 1. + g step. + ^ {(g at: 2 at: 3). (g at: 3 at: 3). (g at: 4 at: 3). (g at: 3 at: 2). (g at: 3 at: 4)}") + ;; (2,3) (3,3) (4,3) on; (3,2) (3,4) off + (list 1 1 1 0 0)) + +;; Glider initial setup — 5 living cells, no step. +(st-test "glider has 5 living cells initially" + (evp + "| g | + g := Life new rows: 8 cols: 8. + g at: 1 at: 2 put: 1. + g at: 2 at: 3 put: 1. + g at: 3 at: 1 put: 1. + g at: 3 at: 2 put: 1. + g at: 3 at: 3 put: 1. + ^ g livingCount") + 5) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/programs/eight-queens.st b/lib/smalltalk/tests/programs/eight-queens.st new file mode 100644 index 00000000..57500d39 --- /dev/null +++ b/lib/smalltalk/tests/programs/eight-queens.st @@ -0,0 +1,47 @@ +"Eight-queens — classic backtracking search. Counts the number of + distinct placements of 8 queens on an 8x8 board with no two attacking. + Expected count: 92." + +Object subclass: #EightQueens + instanceVariableNames: 'columns count size'! + +!EightQueens methodsFor: 'init'! +init + size := 8. + columns := Array new: size. + count := 0. + ^ self! + +size: n + size := n. + columns := Array new: n. + count := 0. + ^ self! ! + +!EightQueens methodsFor: 'access'! +count ^ count! + +size ^ size! ! + +!EightQueens methodsFor: 'solve'! +solve + self placeRow: 1. + ^ count! + +placeRow: row + row > size ifTrue: [count := count + 1. ^ self]. + 1 to: size do: [:col | + (self isSafe: col atRow: row) ifTrue: [ + columns at: row put: col. + self placeRow: row + 1]]! + +isSafe: col atRow: row + | r prevCol delta | + r := 1. + [r < row] whileTrue: [ + prevCol := columns at: r. + prevCol = col ifTrue: [^ false]. + delta := col - prevCol. + delta abs = (row - r) ifTrue: [^ false]. + r := r + 1]. + ^ true! ! diff --git a/lib/smalltalk/tests/programs/fibonacci.st b/lib/smalltalk/tests/programs/fibonacci.st new file mode 100644 index 00000000..36da043e --- /dev/null +++ b/lib/smalltalk/tests/programs/fibonacci.st @@ -0,0 +1,23 @@ +"Fibonacci — recursive and array-memoised. Classic-corpus program for + the Smalltalk-on-SX runtime." + +Object subclass: #Fibonacci + instanceVariableNames: 'memo'! + +!Fibonacci methodsFor: 'init'! +init memo := Array new: 100. ^ self! ! + +!Fibonacci methodsFor: 'compute'! +fib: n + n < 2 ifTrue: [^ n]. + ^ (self fib: n - 1) + (self fib: n - 2)! + +memoFib: n + | cached | + cached := memo at: n + 1. + cached notNil ifTrue: [^ cached]. + cached := n < 2 + ifTrue: [n] + ifFalse: [(self memoFib: n - 1) + (self memoFib: n - 2)]. + memo at: n + 1 put: cached. + ^ cached! ! diff --git a/lib/smalltalk/tests/programs/life.st b/lib/smalltalk/tests/programs/life.st new file mode 100644 index 00000000..f9dd973b --- /dev/null +++ b/lib/smalltalk/tests/programs/life.st @@ -0,0 +1,66 @@ +"Conway's Game of Life — 2D grid stepped by the standard rules: + live with 2 or 3 neighbours stays alive; dead with exactly 3 becomes alive. + Classic-corpus program for the Smalltalk-on-SX runtime. The canonical + 'glider gun' demo (~36 cells, period-30 emission) is correct but too slow + to verify on the spec interpreter without JIT — block, blinker, glider + cover the rule arithmetic and edge handling." + +Object subclass: #Life + instanceVariableNames: 'rows cols cells'! + +!Life methodsFor: 'init'! +rows: r cols: c + rows := r. cols := c. + cells := Array new: r * c. + 1 to: r * c do: [:i | cells at: i put: 0]. + ^ self! ! + +!Life methodsFor: 'access'! +rows ^ rows! +cols ^ cols! + +at: r at: c + ((r < 1) or: [r > rows]) ifTrue: [^ 0]. + ((c < 1) or: [c > cols]) ifTrue: [^ 0]. + ^ cells at: (r - 1) * cols + c! + +at: r at: c put: v + cells at: (r - 1) * cols + c put: v. + ^ v! ! + +!Life methodsFor: 'step'! +neighbors: r at: c + | sum | + sum := 0. + -1 to: 1 do: [:dr | + -1 to: 1 do: [:dc | + ((dr = 0) and: [dc = 0]) ifFalse: [ + sum := sum + (self at: r + dr at: c + dc)]]]. + ^ sum! + +step + | next | + next := Array new: rows * cols. + 1 to: rows * cols do: [:i | next at: i put: 0]. + 1 to: rows do: [:r | + 1 to: cols do: [:c | + | n alive lives | + n := self neighbors: r at: c. + alive := (self at: r at: c) = 1. + lives := alive + ifTrue: [(n = 2) or: [n = 3]] + ifFalse: [n = 3]. + lives ifTrue: [next at: (r - 1) * cols + c put: 1]]]. + cells := next. + ^ self! + +stepN: n + n timesRepeat: [self step]. + ^ self! ! + +!Life methodsFor: 'measure'! +livingCount + | sum | + sum := 0. + 1 to: rows * cols do: [:i | (cells at: i) = 1 ifTrue: [sum := sum + 1]]. + ^ sum! ! diff --git a/lib/smalltalk/tests/programs/mandelbrot.st b/lib/smalltalk/tests/programs/mandelbrot.st new file mode 100644 index 00000000..301da417 --- /dev/null +++ b/lib/smalltalk/tests/programs/mandelbrot.st @@ -0,0 +1,36 @@ +"Mandelbrot — escape-time iteration of z := z² + c starting at z₀ = 0. + Returns the number of iterations before |z|² exceeds 4, capped at + maxIter. Classic-corpus program for the Smalltalk-on-SX runtime." + +Object subclass: #Mandelbrot + instanceVariableNames: ''! + +!Mandelbrot methodsFor: 'iteration'! +escapeAt: cx and: cy maxIter: maxIter + | zx zy zx2 zy2 i | + zx := 0. zy := 0. + zx2 := 0. zy2 := 0. + i := 0. + [(zx2 + zy2 < 4) and: [i < maxIter]] whileTrue: [ + zy := (zx * zy * 2) + cy. + zx := zx2 - zy2 + cx. + zx2 := zx * zx. + zy2 := zy * zy. + i := i + 1]. + ^ i! + +inside: cx and: cy maxIter: maxIter + ^ (self escapeAt: cx and: cy maxIter: maxIter) >= maxIter! ! + +!Mandelbrot methodsFor: 'grid'! +countInsideRangeX: x0 to: x1 stepX: dx rangeY: y0 to: y1 stepY: dy maxIter: maxIter + | x y count | + count := 0. + y := y0. + [y <= y1] whileTrue: [ + x := x0. + [x <= x1] whileTrue: [ + (self inside: x and: y maxIter: maxIter) ifTrue: [count := count + 1]. + x := x + dx]. + y := y + dy]. + ^ count! ! diff --git a/lib/smalltalk/tests/programs/quicksort.st b/lib/smalltalk/tests/programs/quicksort.st new file mode 100644 index 00000000..f1d8a43e --- /dev/null +++ b/lib/smalltalk/tests/programs/quicksort.st @@ -0,0 +1,31 @@ +"Quicksort — Lomuto partition. Sorts an Array in place. Classic-corpus + program for the Smalltalk-on-SX runtime." + +Object subclass: #Quicksort + instanceVariableNames: ''! + +!Quicksort methodsFor: 'sort'! +sort: arr ^ self sort: arr from: 1 to: arr size! + +sort: arr from: low to: high + | p | + low < high ifTrue: [ + p := self partition: arr from: low to: high. + self sort: arr from: low to: p - 1. + self sort: arr from: p + 1 to: high]. + ^ arr! + +partition: arr from: low to: high + | pivot i tmp | + pivot := arr at: high. + i := low - 1. + low to: high - 1 do: [:j | + (arr at: j) <= pivot ifTrue: [ + i := i + 1. + tmp := arr at: i. + arr at: i put: (arr at: j). + arr at: j put: tmp]]. + tmp := arr at: i + 1. + arr at: i + 1 put: (arr at: high). + arr at: high put: tmp. + ^ i + 1! ! diff --git a/lib/smalltalk/tests/reflection.sx b/lib/smalltalk/tests/reflection.sx new file mode 100644 index 00000000..51ff5ca6 --- /dev/null +++ b/lib/smalltalk/tests/reflection.sx @@ -0,0 +1,304 @@ +;; Reflection accessors: Object>>class, class>>name, class>>superclass, +;; class>>methodDict, class>>selectors. Phase 4 starting point. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Object>>class on native receivers ── +(st-test "42 class name" (ev "42 class name") "SmallInteger") +(st-test "3.14 class name" (ev "3.14 class name") "Float") +(st-test "'hi' class name" (ev "'hi' class name") "String") +(st-test "#foo class name" (ev "#foo class name") "Symbol") +(st-test "true class name" (ev "true class name") "True") +(st-test "false class name" (ev "false class name") "False") +(st-test "nil class name" (ev "nil class name") "UndefinedObject") +(st-test "$a class name" (ev "$a class name") "String") +(st-test "#(1 2 3) class name" (ev "#(1 2 3) class name") "Array") +(st-test "[42] class name" (ev "[42] class name") "BlockClosure") + +;; ── 2. Object>>class on user instances ── +(st-class-define! "Cat" "Object" (list "name")) +(st-test "user instance class name" + (evp "^ Cat new class name") "Cat") +(st-test "user instance class superclass name" + (evp "^ Cat new class superclass name") "Object") + +;; ── 3. class>>name / class>>superclass ── +(st-test "class>>name on Object" (ev "Object name") "Object") +(st-test "class>>superclass on Object" (ev "Object superclass") nil) +(st-test "class>>superclass on Symbol" + (ev "Symbol superclass name") "String") +(st-test "class>>superclass on String" + (ev "String superclass name") "ArrayedCollection") + +;; ── 4. class>>class returns Metaclass ── +(st-test "Cat class is Metaclass" + (ev "Cat class name") "Metaclass") + +;; ── 5. class>>methodDict ── +(st-class-add-method! "Cat" "miaow" (st-parse-method "miaow ^ #miaow")) +(st-class-add-method! "Cat" "purr" (st-parse-method "purr ^ #purr")) + +(st-test + "methodDict has expected keys" + (sort (keys (ev "Cat methodDict"))) + (sort (list "miaow" "purr"))) + +(st-test + "methodDict size after two adds" + (len (keys (ev "Cat methodDict"))) + 2) + +;; ── 6. class>>selectors ── +(st-test + "selectors returns Array of symbols" + (sort (map (fn (s) (str s)) (ev "Cat selectors"))) + (sort (list "miaow" "purr"))) + +;; ── 7. class>>instanceVariableNames ── +(st-test "instance variable names" + (ev "Cat instanceVariableNames") (list "name")) + +(st-class-define! "Kitten" "Cat" (list "age")) +(st-test "subclass own ivars" + (ev "Kitten instanceVariableNames") (list "age")) +(st-test "subclass allInstVarNames includes inherited" + (ev "Kitten allInstVarNames") (list "name" "age")) + +;; ── 8. methodDict reflects new methods ── +(st-class-add-method! "Cat" "scratch" (st-parse-method "scratch ^ #scratch")) +(st-test "methodDict updated after add" + (len (keys (ev "Cat methodDict"))) 3) + +;; ── 9. classMethodDict / classSelectors ── +(st-class-add-class-method! "Cat" "named:" + (st-parse-method "named: aName ^ self new")) +(st-test "classSelectors" + (map (fn (s) (str s)) (ev "Cat classSelectors")) (list "named:")) + +;; ── 10. Method records are usable values ── +(st-test "methodDict at: returns method record dict" + (dict? (get (ev "Cat methodDict") "miaow")) true) + +;; ── 11. Object>>perform: ── +(st-test "perform: a unary selector" + (str (evp "^ Cat new perform: #miaow")) + "miaow") + +(st-test "perform: works on native receiver" + (ev "42 perform: #printString") + "42") + +(st-test "perform: with no method falls back to DNU" + ;; With no Object DNU defined here, perform: a missing selector raises. + ;; Wrap in guard to catch. + (let ((caught false)) + (begin + (guard (c (true (set! caught true))) + (evp "^ Cat new perform: #nonexistent")) + caught)) + true) + +;; ── 12. Object>>perform:with: ── +(st-class-add-method! "Cat" "say:" + (st-parse-method "say: aMsg ^ aMsg")) + +(st-test "perform:with: passes arg through" + (evp "^ Cat new perform: #say: with: 'hi'") "hi") + +(st-test "perform:with: on native" + (ev "10 perform: #+ with: 5") 15) + +;; ── 13. Object>>perform:with:with: (multi-arg form) ── +(st-class-add-method! "Cat" "describe:and:" + (st-parse-method "describe: a and: b ^ a , b")) + +(st-test "perform:with:with: keyword selector" + (evp "^ Cat new perform: #describe:and: with: 'foo' with: 'bar'") + "foobar") + +;; ── 14. Object>>perform:withArguments: ── +(st-test "perform:withArguments: empty array" + (str (evp "^ Cat new perform: #miaow withArguments: #()")) + "miaow") + +(st-test "perform:withArguments: 1 element" + (evp "^ Cat new perform: #say: withArguments: #('hello')") + "hello") + +(st-test "perform:withArguments: 2 elements" + (evp "^ Cat new perform: #describe:and: withArguments: #('a' 'b')") + "ab") + +(st-test "perform:withArguments: on native receiver" + (ev "20 perform: #+ withArguments: #(5)") 25) + +;; perform: routes through ordinary dispatch, so super, DNU, primitives +;; all still apply naturally. No special test for that — it's free. + +;; ── 15. isKindOf: walks the class chain ── +(st-test "42 isKindOf: SmallInteger" (ev "42 isKindOf: SmallInteger") true) +(st-test "42 isKindOf: Integer" (ev "42 isKindOf: Integer") true) +(st-test "42 isKindOf: Number" (ev "42 isKindOf: Number") true) +(st-test "42 isKindOf: Magnitude" (ev "42 isKindOf: Magnitude") true) +(st-test "42 isKindOf: Object" (ev "42 isKindOf: Object") true) +(st-test "42 isKindOf: String" (ev "42 isKindOf: String") false) +(st-test "3.14 isKindOf: Float" (ev "3.14 isKindOf: Float") true) +(st-test "3.14 isKindOf: Number" (ev "3.14 isKindOf: Number") true) + +(st-test "'hi' isKindOf: String" (ev "'hi' isKindOf: String") true) +(st-test "'hi' isKindOf: ArrayedCollection" + (ev "'hi' isKindOf: ArrayedCollection") true) +(st-test "true isKindOf: Boolean" (ev "true isKindOf: Boolean") true) +(st-test "nil isKindOf: UndefinedObject" + (ev "nil isKindOf: UndefinedObject") true) + +;; User-class chain. +(st-test "Cat new isKindOf: Cat" (evp "^ Cat new isKindOf: Cat") true) +(st-test "Cat new isKindOf: Object" (evp "^ Cat new isKindOf: Object") true) +(st-test "Cat new isKindOf: Boolean" + (evp "^ Cat new isKindOf: Boolean") false) +(st-test "Kitten new isKindOf: Cat" + (evp "^ Kitten new isKindOf: Cat") true) + +;; ── 16. isMemberOf: requires exact class match ── +(st-test "42 isMemberOf: SmallInteger" (ev "42 isMemberOf: SmallInteger") true) +(st-test "42 isMemberOf: Integer" (ev "42 isMemberOf: Integer") false) +(st-test "42 isMemberOf: Number" (ev "42 isMemberOf: Number") false) +(st-test "Cat new isMemberOf: Cat" + (evp "^ Cat new isMemberOf: Cat") true) +(st-test "Cat new isMemberOf: Kitten" + (evp "^ Cat new isMemberOf: Kitten") false) + +;; ── 17. respondsTo: — user method dictionary search ── +(st-test "Cat respondsTo: #miaow" + (evp "^ Cat new respondsTo: #miaow") true) +(st-test "Cat respondsTo: inherited (only own/super in dict)" + (evp "^ Kitten new respondsTo: #miaow") true) +(st-test "Cat respondsTo: missing" + (evp "^ Cat new respondsTo: #noSuchSelector") false) +(st-test "respondsTo: on class-ref searches class side" + (evp "^ Cat respondsTo: #named:") true) + +;; Non-symbol arg coerces via str — also accepts strings. +(st-test "respondsTo: with string arg" + (evp "^ Cat new respondsTo: 'miaow'") true) + +;; ── 18. Behavior>>compile: — runtime method addition ── +(st-test "compile: a unary method" + (begin + (evp "Cat compile: 'whisker ^ 99'") + (evp "^ Cat new whisker")) + 99) + +(st-test "compile: returns the selector as a symbol" + (str (evp "^ Cat compile: 'twitch ^ #twitch'")) + "twitch") + +(st-test "compile: a keyword method" + (begin + (evp "Cat compile: 'doubled: x ^ x * 2'") + (evp "^ Cat new doubled: 21")) + 42) + +(st-test "compile: a method with temps and blocks" + (begin + (evp "Cat compile: 'sumTo: n | s | s := 0. 1 to: n do: [:i | s := s + i]. ^ s'") + (evp "^ Cat new sumTo: 10")) + 55) + +(st-test "recompile overrides existing method" + (begin + (evp "Cat compile: 'miaow ^ #ahem'") + (str (evp "^ Cat new miaow"))) + "ahem") + +;; methodDict reflects the new method. +(st-test "compile: registers in methodDict" + (has-key? (ev "Cat methodDict") "whisker") true) + +;; respondsTo: notices the new method. +(st-test "respondsTo: sees compiled method" + (evp "^ Cat new respondsTo: #whisker") true) + +;; Behavior>>removeSelector: takes a method back out. +(st-test "removeSelector: drops the method" + (begin + (evp "Cat removeSelector: #whisker") + (evp "^ Cat new respondsTo: #whisker")) + false) + +;; compile:classified: ignores the extra arg. +(st-test "compile:classified: works" + (begin + (evp "Cat compile: 'taggedMethod ^ #yes' classified: 'demo'") + (str (evp "^ Cat new taggedMethod"))) + "yes") + +;; ── 19. Object>>becomeForward: ── +(st-class-define! "Box" "Object" (list "value")) +(st-class-add-method! "Box" "value" (st-parse-method "value ^ value")) +(st-class-add-method! "Box" "value:" (st-parse-method "value: v value := v. ^ self")) +(st-class-add-method! "Box" "kind" (st-parse-method "kind ^ #box")) + +(st-class-define! "Crate" "Object" (list "value")) +(st-class-add-method! "Crate" "value" (st-parse-method "value ^ value")) +(st-class-add-method! "Crate" "value:" (st-parse-method "value: v value := v. ^ self")) +(st-class-add-method! "Crate" "kind" (st-parse-method "kind ^ #crate")) + +(st-test "before becomeForward: instance reports its class" + (str (evp "^ (Box new value: 1) class name")) + "Box") + +(st-test "becomeForward: changes the receiver's class" + (evp + "| a b | + a := Box new value: 1. + b := Crate new value: 99. + a becomeForward: b. + ^ a class name") + "Crate") + +(st-test "becomeForward: routes future sends through new class" + (evp + "| a b | + a := Box new value: 1. + b := Crate new value: 99. + a becomeForward: b. + ^ a kind") + (make-symbol "crate")) + +(st-test "becomeForward: takes target's ivars" + (evp + "| a b | + a := Box new value: 1. + b := Crate new value: 99. + a becomeForward: b. + ^ a value") + 99) + +(st-test "becomeForward: leaves the *target* instance unchanged" + (evp + "| a b | + a := Box new value: 1. + b := Crate new value: 99. + a becomeForward: b. + ^ b kind") + (make-symbol "crate")) + +(st-test "every reference to the receiver sees the new identity" + (evp + "| a alias b | + a := Box new value: 1. + alias := a. + b := Crate new value: 99. + a becomeForward: b. + ^ alias kind") + (make-symbol "crate")) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/runtime.sx b/lib/smalltalk/tests/runtime.sx new file mode 100644 index 00000000..8398c64c --- /dev/null +++ b/lib/smalltalk/tests/runtime.sx @@ -0,0 +1,255 @@ +;; Smalltalk runtime tests — class table, type→class mapping, instances. +;; +;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset +;; here so this file's summary covers runtime tests only. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +;; Fresh hierarchy for every test file. +(st-bootstrap-classes!) + +;; ── 1. Bootstrap installed expected classes ── +(st-test "Object exists" (st-class-exists? "Object") true) +(st-test "Behavior exists" (st-class-exists? "Behavior") true) +(st-test "Metaclass exists" (st-class-exists? "Metaclass") true) +(st-test "True/False/UndefinedObject" + (and + (st-class-exists? "True") + (st-class-exists? "False") + (st-class-exists? "UndefinedObject")) + true) +(st-test "SmallInteger / Float / Symbol exist" + (and + (st-class-exists? "SmallInteger") + (st-class-exists? "Float") + (st-class-exists? "Symbol")) + true) +(st-test "BlockClosure exists" (st-class-exists? "BlockClosure") true) + +;; ── 2. Superclass chain ── +(st-test "Object has no superclass" (st-class-superclass "Object") nil) +(st-test "Behavior super = Object" (st-class-superclass "Behavior") "Object") +(st-test "True super = Boolean" (st-class-superclass "True") "Boolean") +(st-test "Symbol super = String" (st-class-superclass "Symbol") "String") +(st-test + "String chain" + (st-class-chain "String") + (list "String" "ArrayedCollection" "SequenceableCollection" "Collection" "Object")) +(st-test + "SmallInteger chain" + (st-class-chain "SmallInteger") + (list "SmallInteger" "Integer" "Number" "Magnitude" "Object")) + +;; ── 3. inherits-from? ── +(st-test "True inherits from Boolean" (st-class-inherits-from? "True" "Boolean") true) +(st-test "True inherits from Object" (st-class-inherits-from? "True" "Object") true) +(st-test "True inherits from True" (st-class-inherits-from? "True" "True") true) +(st-test + "True does not inherit from Number" + (st-class-inherits-from? "True" "Number") + false) +(st-test + "Object does not inherit from Number" + (st-class-inherits-from? "Object" "Number") + false) + +;; ── 4. type→class mapping ── +(st-test "class-of nil" (st-class-of nil) "UndefinedObject") +(st-test "class-of true" (st-class-of true) "True") +(st-test "class-of false" (st-class-of false) "False") +(st-test "class-of int" (st-class-of 42) "SmallInteger") +(st-test "class-of zero" (st-class-of 0) "SmallInteger") +(st-test "class-of negative int" (st-class-of -3) "SmallInteger") +(st-test "class-of float" (st-class-of 3.14) "Float") +(st-test "class-of string" (st-class-of "hi") "String") +(st-test "class-of symbol" (st-class-of (quote foo)) "Symbol") +(st-test "class-of list" (st-class-of (list 1 2)) "Array") +(st-test "class-of empty list" (st-class-of (list)) "Array") +(st-test "class-of lambda" (st-class-of (fn (x) x)) "BlockClosure") +(st-test "class-of dict" (st-class-of {:a 1}) "Dictionary") + +;; ── 5. User class definition ── +(st-class-define! "Account" "Object" (list "balance" "owner")) +(st-class-define! "SavingsAccount" "Account" (list "rate")) + +(st-test "Account exists" (st-class-exists? "Account") true) +(st-test "Account super = Object" (st-class-superclass "Account") "Object") +(st-test + "SavingsAccount chain" + (st-class-chain "SavingsAccount") + (list "SavingsAccount" "Account" "Object")) +(st-test + "SavingsAccount own ivars" + (get (st-class-get "SavingsAccount") :ivars) + (list "rate")) +(st-test + "SavingsAccount inherited+own ivars" + (st-class-all-ivars "SavingsAccount") + (list "balance" "owner" "rate")) + +;; ── 6. Instance construction ── +(define a1 (st-make-instance "Account")) +(st-test "instance is st-instance" (st-instance? a1) true) +(st-test "instance class" (get a1 :class) "Account") +(st-test "instance ivars start nil" (st-iv-get a1 "balance") nil) +(st-test + "instance has all expected ivars" + (sort (keys (get a1 :ivars))) + (sort (list "balance" "owner"))) +(define a2 (st-iv-set! a1 "balance" 100)) +(st-test "iv-set! returns updated copy" (st-iv-get a2 "balance") 100) +(st-test "iv-set! does not mutate original" (st-iv-get a1 "balance") nil) +(st-test "class-of instance" (st-class-of a1) "Account") + +(define s1 (st-make-instance "SavingsAccount")) +(st-test + "subclass instance has all inherited ivars" + (sort (keys (get s1 :ivars))) + (sort (list "balance" "owner" "rate"))) + +;; ── 7. Method install + lookup ── +(st-class-add-method! + "Account" + "balance" + (st-parse-method "balance ^ balance")) +(st-class-add-method! + "Account" + "deposit:" + (st-parse-method "deposit: amount balance := balance + amount. ^ self")) + +(st-test + "method registered" + (has-key? (get (st-class-get "Account") :methods) "balance") + true) + +(st-test + "method lookup direct" + (= (st-method-lookup "Account" "balance" false) nil) + false) + +(st-test + "method lookup walks superclass" + (= (st-method-lookup "SavingsAccount" "deposit:" false) nil) + false) + +(st-test + "method lookup unknown selector" + (st-method-lookup "Account" "frobnicate" false) + nil) + +(st-test + "method lookup records defining class" + (get (st-method-lookup "SavingsAccount" "balance" false) :defining-class) + "Account") + +;; SavingsAccount overrides deposit: +(st-class-add-method! + "SavingsAccount" + "deposit:" + (st-parse-method "deposit: amount ^ super deposit: amount + 1")) + +(st-test + "subclass override picked first" + (get (st-method-lookup "SavingsAccount" "deposit:" false) :defining-class) + "SavingsAccount") + +(st-test + "Account still finds its own deposit:" + (get (st-method-lookup "Account" "deposit:" false) :defining-class) + "Account") + +;; ── 8. Class-side methods ── +(st-class-add-class-method! + "Account" + "new" + (st-parse-method "new ^ super new")) +(st-test + "class-side lookup" + (= (st-method-lookup "Account" "new" true) nil) + false) +(st-test + "instance-side does not find class method" + (st-method-lookup "Account" "new" false) + nil) + +;; ── 9. Re-bootstrap resets table ── +(st-bootstrap-classes!) +(st-test "after re-bootstrap Account gone" (st-class-exists? "Account") false) +(st-test "after re-bootstrap Object stays" (st-class-exists? "Object") true) + +;; ── 10. Method-lookup cache ── +(st-bootstrap-classes!) +(st-class-define! "Foo" "Object" (list)) +(st-class-define! "Bar" "Foo" (list)) +(st-class-add-method! "Foo" "greet" (st-parse-method "greet ^ 1")) + +;; Bootstrap clears cache; record stats from now. +(st-method-cache-reset-stats!) + +;; First lookup is a miss; second is a hit. +(st-method-lookup "Bar" "greet" false) +(st-test + "first lookup recorded as miss" + (get (st-method-cache-stats) :misses) + 1) +(st-test + "first lookup recorded as hit count zero" + (get (st-method-cache-stats) :hits) + 0) + +(st-method-lookup "Bar" "greet" false) +(st-test + "second lookup hits cache" + (get (st-method-cache-stats) :hits) + 1) + +;; Misses are also cached as :not-found. +(st-method-lookup "Bar" "frobnicate" false) +(st-method-lookup "Bar" "frobnicate" false) +(st-test + "negative-result caches" + (get (st-method-cache-stats) :hits) + 2) + +;; Adding a new method invalidates the cache. +(st-class-add-method! "Bar" "greet" (st-parse-method "greet ^ 2")) +(st-test + "cache cleared on method add" + (get (st-method-cache-stats) :size) + 0) +(st-test + "after invalidation lookup picks up override" + (get (st-method-lookup "Bar" "greet" false) :defining-class) + "Bar") + +;; Removing a method also invalidates and exposes the inherited one. +(st-class-remove-method! "Bar" "greet") +(st-test + "after remove lookup falls through to Foo" + (get (st-method-lookup "Bar" "greet" false) :defining-class) + "Foo") + +;; Cache survives across unrelated class-table mutations? No — define! clears. +(st-method-lookup "Foo" "greet" false) ; warm cache +(st-class-define! "Baz" "Object" (list)) +(st-test + "class-define clears cache" + (get (st-method-cache-stats) :size) + 0) + +;; Class-side and instance-side cache entries are separate keys. +(st-class-add-class-method! "Foo" "make" (st-parse-method "make ^ self new")) +(st-method-lookup "Foo" "make" true) +(st-method-lookup "Foo" "make" false) +(st-test + "class-side hit found, instance-side stored as not-found" + (= (st-method-lookup "Foo" "make" true) nil) + false) +(st-test + "instance-side same selector returns nil" + (st-method-lookup "Foo" "make" false) + nil) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/streams.sx b/lib/smalltalk/tests/streams.sx new file mode 100644 index 00000000..f124fb75 --- /dev/null +++ b/lib/smalltalk/tests/streams.sx @@ -0,0 +1,159 @@ +;; Stream hierarchy tests — ReadStream / WriteStream / ReadWriteStream +;; built on a `collection` + `position` pair. Reads use Smalltalk's +;; 1-indexed `at:`; writes use the collection's `add:`. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Class hierarchy ── +(st-test "ReadStream < PositionableStream" + (st-class-inherits-from? "ReadStream" "PositionableStream") true) +(st-test "WriteStream < PositionableStream" + (st-class-inherits-from? "WriteStream" "PositionableStream") true) +(st-test "ReadWriteStream < WriteStream" + (st-class-inherits-from? "ReadWriteStream" "WriteStream") true) + +;; ── 2. ReadStream basics ── +(st-test "ReadStream next" (evp "^ (ReadStream on: #(1 2 3)) next") 1) + +(st-test "ReadStream sequential reads" + (evp + "| s | + s := ReadStream on: #(10 20 30). + ^ {s next. s next. s next}") + (list 10 20 30)) + +(st-test "ReadStream atEnd" + (evp + "| s | + s := ReadStream on: #(1 2). + s next. s next. + ^ s atEnd") + true) + +(st-test "ReadStream next past end returns nil" + (evp + "| s | + s := ReadStream on: #(1). + s next. + ^ s next") + nil) + +(st-test "ReadStream peek doesn't advance" + (evp + "| s | + s := ReadStream on: #(7 8 9). + ^ {s peek. s peek. s next}") + (list 7 7 7)) + +(st-test "ReadStream position" + (evp + "| s | + s := ReadStream on: #(1 2 3 4). + s next. s next. + ^ s position") + 2) + +(st-test "ReadStream reset goes back to start" + (evp + "| s | + s := ReadStream on: #(1 2 3). + s next. s next. s next. + s reset. + ^ s next") + 1) + +(st-test "ReadStream upToEnd" + (evp + "| s | + s := ReadStream on: #(1 2 3 4 5). + s next. s next. + ^ s upToEnd") + (list 3 4 5)) + +(st-test "ReadStream next: takes up to n" + (evp + "| s | + s := ReadStream on: #(10 20 30 40 50). + ^ s next: 3") + (list 10 20 30)) + +(st-test "ReadStream skip:" + (evp + "| s | + s := ReadStream on: #(1 2 3 4 5). + s skip: 2. + ^ s next") + 3) + +;; ── 3. WriteStream basics ── +(st-test "WriteStream nextPut: + contents" + (evp + "| s | + s := WriteStream on: (Array new: 0). + s nextPut: 10. + s nextPut: 20. + s nextPut: 30. + ^ s contents") + (list 10 20 30)) + +(st-test "WriteStream nextPutAll:" + (evp + "| s | + s := WriteStream on: (Array new: 0). + s nextPutAll: #(1 2 3). + ^ s contents") + (list 1 2 3)) + +(st-test "WriteStream nextPut: returns the value" + (evp "^ (WriteStream on: (Array new: 0)) nextPut: 42") 42) + +(st-test "WriteStream position tracks writes" + (evp + "| s | + s := WriteStream on: (Array new: 0). + s nextPut: #a. s nextPut: #b. + ^ s position") + 2) + +;; ── 4. WriteStream with: pre-fills ── +(st-test "WriteStream with: starts at end" + (evp + "| s | + s := WriteStream with: #(1 2 3). + s nextPut: 99. + ^ s contents") + (list 1 2 3 99)) + +;; ── 5. ReadStream on:collection works on String at: ── +(st-test "ReadStream on String reads chars" + (evp + "| s | + s := ReadStream on: 'abc'. + ^ {s next. s next. s next}") + (list "a" "b" "c")) + +(st-test "ReadStream atEnd on String" + (evp + "| s | + s := ReadStream on: 'ab'. + s next. s next. + ^ s atEnd") + true) + +;; ── 6. ReadWriteStream ── +(st-test "ReadWriteStream read after writes" + (evp + "| s | + s := ReadWriteStream on: (Array new: 0). + s nextPut: 1. s nextPut: 2. s nextPut: 3. + s reset. + ^ {s next. s next. s next}") + (list 1 2 3)) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/sunit.sx b/lib/smalltalk/tests/sunit.sx new file mode 100644 index 00000000..55d77ba7 --- /dev/null +++ b/lib/smalltalk/tests/sunit.sx @@ -0,0 +1,198 @@ +;; SUnit port tests. Loads `lib/smalltalk/sunit.sx` (which itself calls +;; smalltalk-load to install TestCase/TestSuite/TestResult/TestFailure) +;; and exercises the framework on small Smalltalk-defined cases. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +;; test.sh loads lib/smalltalk/sunit.sx for us BEFORE this file runs +;; (nested SX loads do not propagate top-level forms reliably, so the +;; bootstrap chain is concentrated in test.sh). The SUnit classes are +;; already present in the class table at this point. + +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Classes installed ── +(st-test "TestCase exists" (st-class-exists? "TestCase") true) +(st-test "TestSuite exists" (st-class-exists? "TestSuite") true) +(st-test "TestResult exists" (st-class-exists? "TestResult") true) +(st-test "TestFailure < Error" + (st-class-inherits-from? "TestFailure" "Error") true) + +;; ── 2. A subclass with one passing test runs cleanly ── +(smalltalk-load + "TestCase subclass: #PassingCase + instanceVariableNames: ''! + + !PassingCase methodsFor: 'tests'! + testOnePlusOne self assert: 1 + 1 = 2! !") + +(st-test "passing test runs and counts as pass" + (evp + "| suite r | + suite := PassingCase suiteForAll: #(#testOnePlusOne). + r := suite run. + ^ r passCount") + 1) + +(st-test "passing test has no failures" + (evp + "| suite r | + suite := PassingCase suiteForAll: #(#testOnePlusOne). + r := suite run. + ^ r failureCount") + 0) + +;; ── 3. A subclass with a failing assert: increments failures ── +(smalltalk-load + "TestCase subclass: #FailingCase + instanceVariableNames: ''! + + !FailingCase methodsFor: 'tests'! + testFalse self assert: false! + testEquals self assert: 1 + 1 equals: 3! !") + +(st-test "assert: false bumps failureCount" + (evp + "| suite r | + suite := FailingCase suiteForAll: #(#testFalse). + r := suite run. + ^ r failureCount") + 1) + +(st-test "assert:equals: with mismatch fails" + (evp + "| suite r | + suite := FailingCase suiteForAll: #(#testEquals). + r := suite run. + ^ r failureCount") + 1) + +(st-test "failure messageText captured" + (evp + "| suite r rec | + suite := FailingCase suiteForAll: #(#testEquals). + r := suite run. + rec := r failures at: 1. + ^ rec at: 2") + "expected 3 but got 2") + +;; ── 4. Mixed pass/fail counts add up ── +(smalltalk-load + "TestCase subclass: #MixedCase + instanceVariableNames: ''! + + !MixedCase methodsFor: 'tests'! + testGood self assert: true! + testBad self assert: false! + testAlsoGood self assert: 2 > 1! !") + +(st-test "mixed suite — totalCount" + (evp + "| s r | + s := MixedCase suiteForAll: #(#testGood #testBad #testAlsoGood). + r := s run. + ^ r totalCount") + 3) + +(st-test "mixed suite — passCount" + (evp + "| s r | + s := MixedCase suiteForAll: #(#testGood #testBad #testAlsoGood). + r := s run. + ^ r passCount") + 2) + +(st-test "mixed suite — failureCount" + (evp + "| s r | + s := MixedCase suiteForAll: #(#testGood #testBad #testAlsoGood). + r := s run. + ^ r failureCount") + 1) + +(st-test "allPassed false on mix" + (evp + "| s r | + s := MixedCase suiteForAll: #(#testGood #testBad #testAlsoGood). + r := s run. + ^ r allPassed") + false) + +(st-test "allPassed true with only passes" + (evp + "| s r | + s := MixedCase suiteForAll: #(#testGood #testAlsoGood). + r := s run. + ^ r allPassed") + true) + +;; ── 5. setUp / tearDown ── +(smalltalk-load + "TestCase subclass: #FixtureCase + instanceVariableNames: 'value'! + + !FixtureCase methodsFor: 'fixture'! + setUp value := 42. ^ self! + tearDown ^ self! ! + + !FixtureCase methodsFor: 'tests'! + testValueIs42 self assert: value = 42! !") + +(st-test "setUp ran before test" + (evp + "| s r | + s := FixtureCase suiteForAll: #(#testValueIs42). + r := s run. + ^ r passCount") + 1) + +;; ── 6. should:raise: and shouldnt:raise: ── +(smalltalk-load + "TestCase subclass: #RaiseCase + instanceVariableNames: ''! + + !RaiseCase methodsFor: 'tests'! + testShouldRaise + self should: [Error signal: 'boom'] raise: Error! + + testShouldRaiseFails + self should: [42] raise: Error! + + testShouldntRaise + self shouldnt: [42] raise: Error! !") + +(st-test "should:raise: catches matching" + (evp + "| r | + r := (RaiseCase suiteForAll: #(#testShouldRaise)) run. + ^ r passCount") 1) + +(st-test "should:raise: fails when no exception" + (evp + "| r | + r := (RaiseCase suiteForAll: #(#testShouldRaiseFails)) run. + ^ r failureCount") 1) + +(st-test "shouldnt:raise: passes when nothing thrown" + (evp + "| r | + r := (RaiseCase suiteForAll: #(#testShouldntRaise)) run. + ^ r passCount") 1) + +;; ── 7. summary string uses format: ── +(st-test "summary contains pass count" + (let + ((s (evp + "| s r | + s := MixedCase suiteForAll: #(#testGood #testBad). + r := s run. + ^ r summary"))) + (cond + ((not (string? s)) false) + (else (> (len s) 0)))) + true) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/super.sx b/lib/smalltalk/tests/super.sx new file mode 100644 index 00000000..a11bf64a --- /dev/null +++ b/lib/smalltalk/tests/super.sx @@ -0,0 +1,149 @@ +;; super-send tests. +;; +;; super looks up methods starting at the *defining class*'s superclass — +;; not the receiver's class. This means an inherited method that uses +;; `super` always reaches the same parent regardless of where in the +;; subclass chain the receiver actually sits. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) + +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Basic super: subclass override calls parent ── +(st-class-define! "Animal" "Object" (list)) +(st-class-add-method! "Animal" "speak" + (st-parse-method "speak ^ #generic")) + +(st-class-define! "Dog" "Animal" (list)) +(st-class-add-method! "Dog" "speak" + (st-parse-method "speak ^ super speak")) + +(st-test + "super reaches parent's speak" + (str (evp "^ Dog new speak")) + "generic") + +(st-class-add-method! "Dog" "loud" + (st-parse-method "loud ^ super speak , #'!' asString")) +;; The above tries to use `, #'!' asString` which won't quite work with my +;; primitives. Replace with a simpler test. +(st-class-add-method! "Dog" "loud" + (st-parse-method "loud | s | s := super speak. ^ s")) + +(st-test + "method calls super and returns same" + (str (evp "^ Dog new loud")) + "generic") + +;; ── 2. Super with argument ── +(st-class-add-method! "Animal" "greet:" + (st-parse-method "greet: name ^ name , ' (animal)'")) +(st-class-add-method! "Dog" "greet:" + (st-parse-method "greet: name ^ super greet: name")) + +(st-test + "super with arg reaches parent and threads value" + (evp "^ Dog new greet: 'Rex'") + "Rex (animal)") + +;; ── 3. Inherited method uses *defining* class for super ── +;; A defines speak ^ 'A' +;; A defines speakLog: which sends `super speak`. super starts at Object → no +;; speak there → DNU. So invoke speakLog from A subclass to test that super +;; resolves to A's parent (Object), not the subclass's parent. +(st-class-define! "RootSpeaker" "Object" (list)) +(st-class-add-method! "RootSpeaker" "speak" + (st-parse-method "speak ^ #root")) +(st-class-add-method! "RootSpeaker" "speakDelegate" + (st-parse-method "speakDelegate ^ super speak")) +;; Object has no speak (and we add a temporary DNU for testing). +(st-class-add-method! "Object" "doesNotUnderstand:" + (st-parse-method "doesNotUnderstand: aMessage ^ #dnu")) + +(st-class-define! "ChildSpeaker" "RootSpeaker" (list)) +(st-class-add-method! "ChildSpeaker" "speak" + (st-parse-method "speak ^ #child")) + +(st-test + "inherited speakDelegate uses RootSpeaker's super, not ChildSpeaker's" + (str (evp "^ ChildSpeaker new speakDelegate")) + "dnu") + +;; A non-inherited path: ChildSpeaker overrides speak, but speakDelegate is +;; inherited from RootSpeaker. The super inside speakDelegate must resolve to +;; *Object* (RootSpeaker's parent), not to RootSpeaker (ChildSpeaker's parent). +(st-test + "inherited method's super does not call subclass override" + (str (evp "^ ChildSpeaker new speak")) + "child") + +;; Remove the Object DNU shim now that those tests are done. +(st-class-remove-method! "Object" "doesNotUnderstand:") + +;; ── 4. Multi-level: A → B → C ── +(st-class-define! "GA" "Object" (list)) +(st-class-add-method! "GA" "level" + (st-parse-method "level ^ #ga")) + +(st-class-define! "GB" "GA" (list)) +(st-class-add-method! "GB" "level" + (st-parse-method "level ^ super level")) + +(st-class-define! "GC" "GB" (list)) +(st-class-add-method! "GC" "level" + (st-parse-method "level ^ super level")) + +(st-test + "super chains to grandparent" + (str (evp "^ GC new level")) + "ga") + +;; ── 5. Super inside a block ── +(st-class-add-method! "Dog" "delayed" + (st-parse-method "delayed ^ [super speak] value")) +(st-test + "super inside a block resolves correctly" + (str (evp "^ Dog new delayed")) + "generic") + +;; ── 6. Super send keeps receiver as self ── +(st-class-define! "Counter" "Object" (list "count")) +(st-class-add-method! "Counter" "init" + (st-parse-method "init count := 0. ^ self")) +(st-class-add-method! "Counter" "incr" + (st-parse-method "incr count := count + 1. ^ self")) +(st-class-add-method! "Counter" "count" + (st-parse-method "count ^ count")) + +(st-class-define! "DoubleCounter" "Counter" (list)) +(st-class-add-method! "DoubleCounter" "incr" + (st-parse-method "incr super incr. super incr. ^ self")) + +(st-test + "super uses same receiver — ivars on self update" + (evp "| c | c := DoubleCounter new init. c incr. ^ c count") + 2) + +;; ── 7. Super on a class without an immediate parent definition ── +;; Mid-chain class with no override at this level: super resolves correctly +;; through the missing rung. +(st-class-define! "Mid" "Animal" (list)) +(st-class-define! "Pup" "Mid" (list)) +(st-class-add-method! "Pup" "speak" + (st-parse-method "speak ^ super speak")) + +(st-test + "super walks past intermediate class with no override" + (str (evp "^ Pup new speak")) + "generic") + +;; ── 8. Super outside any method errors ── +;; (We don't have try/catch in SX from here; skip the negative test — +;; documented behaviour is that st-super-send errors when method-class is nil.) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/tokenize.sx b/lib/smalltalk/tests/tokenize.sx new file mode 100644 index 00000000..23f5fdb3 --- /dev/null +++ b/lib/smalltalk/tests/tokenize.sx @@ -0,0 +1,362 @@ +;; Smalltalk tokenizer tests. +;; +;; Lightweight runner: each test checks actual vs expected with structural +;; equality and accumulates pass/fail counters. Final summary read by +;; lib/smalltalk/test.sh. + +(define + st-deep=? + (fn + (a b) + (cond + ((= a b) true) + ((and (dict? a) (dict? b)) + (let + ((ak (keys a)) (bk (keys b))) + (if + (not (= (len ak) (len bk))) + false + (every? + (fn + (k) + (and (has-key? b k) (st-deep=? (get a k) (get b k)))) + ak)))) + ((and (list? a) (list? b)) + (if + (not (= (len a) (len b))) + false + (let + ((i 0) (ok true)) + (begin + (define + de-loop + (fn + () + (when + (and ok (< i (len a))) + (begin + (when + (not (st-deep=? (nth a i) (nth b i))) + (set! ok false)) + (set! i (+ i 1)) + (de-loop))))) + (de-loop) + ok)))) + (:else false)))) + +(define st-test-pass 0) +(define st-test-fail 0) +(define st-test-fails (list)) + +(define + st-test + (fn + (name actual expected) + (if + (st-deep=? actual expected) + (set! st-test-pass (+ st-test-pass 1)) + (begin + (set! st-test-fail (+ st-test-fail 1)) + (append! st-test-fails {:actual actual :expected expected :name name}))))) + +;; Strip eof and project to just :type/:value. +(define + st-toks + (fn + (src) + (map + (fn (tok) {:type (get tok :type) :value (get tok :value)}) + (filter + (fn (tok) (not (= (get tok :type) "eof"))) + (st-tokenize src))))) + +;; ── 1. Whitespace / empty ── +(st-test "empty input" (st-toks "") (list)) +(st-test "all whitespace" (st-toks " \t\n ") (list)) + +;; ── 2. Identifiers ── +(st-test + "lowercase ident" + (st-toks "foo") + (list {:type "ident" :value "foo"})) + +(st-test + "capitalised ident" + (st-toks "Foo") + (list {:type "ident" :value "Foo"})) + +(st-test + "underscore ident" + (st-toks "_x") + (list {:type "ident" :value "_x"})) + +(st-test + "digits in ident" + (st-toks "foo123") + (list {:type "ident" :value "foo123"})) + +(st-test + "two idents separated" + (st-toks "foo bar") + (list {:type "ident" :value "foo"} {:type "ident" :value "bar"})) + +;; ── 3. Keyword selectors ── +(st-test + "keyword selector" + (st-toks "foo:") + (list {:type "keyword" :value "foo:"})) + +(st-test + "keyword call" + (st-toks "x at: 1") + (list + {:type "ident" :value "x"} + {:type "keyword" :value "at:"} + {:type "number" :value 1})) + +(st-test + "two-keyword chain stays separate" + (st-toks "at: 1 put: 2") + (list + {:type "keyword" :value "at:"} + {:type "number" :value 1} + {:type "keyword" :value "put:"} + {:type "number" :value 2})) + +(st-test + "ident then assign — not a keyword" + (st-toks "x := 1") + (list + {:type "ident" :value "x"} + {:type "assign" :value ":="} + {:type "number" :value 1})) + +;; ── 4. Numbers ── +(st-test + "integer" + (st-toks "42") + (list {:type "number" :value 42})) + +(st-test + "float" + (st-toks "3.14") + (list {:type "number" :value 3.14})) + +(st-test + "hex radix" + (st-toks "16rFF") + (list + {:type "number" + :value + {:radix 16 :digits "FF" :value 255 :kind "radix"}})) + +(st-test + "binary radix" + (st-toks "2r1011") + (list + {:type "number" + :value + {:radix 2 :digits "1011" :value 11 :kind "radix"}})) + +(st-test + "exponent" + (st-toks "1e3") + (list {:type "number" :value 1000})) + +(st-test + "negative exponent (parser handles minus)" + (st-toks "1.5e-2") + (list {:type "number" :value 0.015})) + +;; ── 5. Strings ── +(st-test + "simple string" + (st-toks "'hi'") + (list {:type "string" :value "hi"})) + +(st-test + "empty string" + (st-toks "''") + (list {:type "string" :value ""})) + +(st-test + "doubled-quote escape" + (st-toks "'a''b'") + (list {:type "string" :value "a'b"})) + +;; ── 6. Characters ── +(st-test + "char literal letter" + (st-toks "$a") + (list {:type "char" :value "a"})) + +(st-test + "char literal punct" + (st-toks "$$") + (list {:type "char" :value "$"})) + +(st-test + "char literal space" + (st-toks "$ ") + (list {:type "char" :value " "})) + +;; ── 7. Symbols ── +(st-test + "symbol ident" + (st-toks "#foo") + (list {:type "symbol" :value "foo"})) + +(st-test + "symbol binary" + (st-toks "#+") + (list {:type "symbol" :value "+"})) + +(st-test + "symbol arrow" + (st-toks "#->") + (list {:type "symbol" :value "->"})) + +(st-test + "symbol keyword chain" + (st-toks "#at:put:") + (list {:type "symbol" :value "at:put:"})) + +(st-test + "quoted symbol with spaces" + (st-toks "#'foo bar'") + (list {:type "symbol" :value "foo bar"})) + +;; ── 8. Literal arrays / byte arrays ── +(st-test + "literal array open" + (st-toks "#(1 2)") + (list + {:type "array-open" :value "#("} + {:type "number" :value 1} + {:type "number" :value 2} + {:type "rparen" :value ")"})) + +(st-test + "byte array open" + (st-toks "#[1 2 3]") + (list + {:type "byte-array-open" :value "#["} + {:type "number" :value 1} + {:type "number" :value 2} + {:type "number" :value 3} + {:type "rbracket" :value "]"})) + +;; ── 9. Binary selectors ── +(st-test "plus" (st-toks "+") (list {:type "binary" :value "+"})) +(st-test "minus" (st-toks "-") (list {:type "binary" :value "-"})) +(st-test "star" (st-toks "*") (list {:type "binary" :value "*"})) +(st-test "double-equal" (st-toks "==") (list {:type "binary" :value "=="})) +(st-test "leq" (st-toks "<=") (list {:type "binary" :value "<="})) +(st-test "geq" (st-toks ">=") (list {:type "binary" :value ">="})) +(st-test "neq" (st-toks "~=") (list {:type "binary" :value "~="})) +(st-test "arrow" (st-toks "->") (list {:type "binary" :value "->"})) +(st-test "comma" (st-toks ",") (list {:type "binary" :value ","})) + +(st-test + "binary in expression" + (st-toks "a + b") + (list + {:type "ident" :value "a"} + {:type "binary" :value "+"} + {:type "ident" :value "b"})) + +;; ── 10. Punctuation ── +(st-test "lparen" (st-toks "(") (list {:type "lparen" :value "("})) +(st-test "rparen" (st-toks ")") (list {:type "rparen" :value ")"})) +(st-test "lbracket" (st-toks "[") (list {:type "lbracket" :value "["})) +(st-test "rbracket" (st-toks "]") (list {:type "rbracket" :value "]"})) +(st-test "lbrace" (st-toks "{") (list {:type "lbrace" :value "{"})) +(st-test "rbrace" (st-toks "}") (list {:type "rbrace" :value "}"})) +(st-test "period" (st-toks ".") (list {:type "period" :value "."})) +(st-test "semi" (st-toks ";") (list {:type "semi" :value ";"})) +(st-test "bar" (st-toks "|") (list {:type "bar" :value "|"})) +(st-test "caret" (st-toks "^") (list {:type "caret" :value "^"})) +(st-test "bang" (st-toks "!") (list {:type "bang" :value "!"})) +(st-test "colon" (st-toks ":") (list {:type "colon" :value ":"})) +(st-test "assign" (st-toks ":=") (list {:type "assign" :value ":="})) + +;; ── 11. Comments ── +(st-test "comment skipped" (st-toks "\"hello\"") (list)) +(st-test + "comment between tokens" + (st-toks "a \"comment\" b") + (list {:type "ident" :value "a"} {:type "ident" :value "b"})) +(st-test + "multi-line comment" + (st-toks "\"line1\nline2\"42") + (list {:type "number" :value 42})) + +;; ── 12. Compound expressions ── +(st-test + "block with params" + (st-toks "[:a :b | a + b]") + (list + {:type "lbracket" :value "["} + {:type "colon" :value ":"} + {:type "ident" :value "a"} + {:type "colon" :value ":"} + {:type "ident" :value "b"} + {:type "bar" :value "|"} + {:type "ident" :value "a"} + {:type "binary" :value "+"} + {:type "ident" :value "b"} + {:type "rbracket" :value "]"})) + +(st-test + "cascade" + (st-toks "x m1; m2") + (list + {:type "ident" :value "x"} + {:type "ident" :value "m1"} + {:type "semi" :value ";"} + {:type "ident" :value "m2"})) + +(st-test + "method body return" + (st-toks "^ self foo") + (list + {:type "caret" :value "^"} + {:type "ident" :value "self"} + {:type "ident" :value "foo"})) + +(st-test + "class declaration head" + (st-toks "Object subclass: #Foo") + (list + {:type "ident" :value "Object"} + {:type "keyword" :value "subclass:"} + {:type "symbol" :value "Foo"})) + +(st-test + "temp declaration" + (st-toks "| t1 t2 |") + (list + {:type "bar" :value "|"} + {:type "ident" :value "t1"} + {:type "ident" :value "t2"} + {:type "bar" :value "|"})) + +(st-test + "chunk separator" + (st-toks "Foo bar !") + (list + {:type "ident" :value "Foo"} + {:type "ident" :value "bar"} + {:type "bang" :value "!"})) + +(st-test + "keyword call with binary precedence" + (st-toks "x foo: 1 + 2") + (list + {:type "ident" :value "x"} + {:type "keyword" :value "foo:"} + {:type "number" :value 1} + {:type "binary" :value "+"} + {:type "number" :value 2})) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tests/while.sx b/lib/smalltalk/tests/while.sx new file mode 100644 index 00000000..4d5d244b --- /dev/null +++ b/lib/smalltalk/tests/while.sx @@ -0,0 +1,145 @@ +;; whileTrue: / whileTrue / whileFalse: / whileFalse tests. +;; +;; In Smalltalk these are *ordinary* messages sent to the condition block. +;; No special-form magic — just block sends. The runtime can intrinsify +;; them later in the JIT (Tier 1 of bytecode expansion) but the spec-level +;; semantics are what's pinned here. + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. whileTrue: with body — basic counter ── +(st-test + "whileTrue: counts down" + (evp "| n | n := 5. [n > 0] whileTrue: [n := n - 1]. ^ n") + 0) + +(st-test + "whileTrue: returns nil" + (evp "| n | n := 3. ^ [n > 0] whileTrue: [n := n - 1]") + nil) + +(st-test + "whileTrue: zero iterations is fine" + (evp "| n | n := 0. [n > 0] whileTrue: [n := n + 1]. ^ n") + 0) + +;; ── 2. whileFalse: with body ── +(st-test + "whileFalse: counts down (cond becomes true)" + (evp "| n | n := 5. [n <= 0] whileFalse: [n := n - 1]. ^ n") + 0) + +(st-test + "whileFalse: returns nil" + (evp "| n | n := 3. ^ [n <= 0] whileFalse: [n := n - 1]") + nil) + +;; ── 3. whileTrue (no arg) — body-less side-effect loop ── +(st-test + "whileTrue without argument runs cond-only loop" + (evp + "| n decrement | + n := 5. + decrement := [n := n - 1. n > 0]. + decrement whileTrue. + ^ n") + 0) + +;; ── 4. whileFalse (no arg) ── +(st-test + "whileFalse without argument" + (evp + "| n inc | + n := 0. + inc := [n := n + 1. n >= 3]. + inc whileFalse. + ^ n") + 3) + +;; ── 5. Cond block evaluated each iteration (not cached) ── +(st-test + "whileTrue: re-evaluates cond on every iter" + (evp + "| n stop | + n := 0. stop := false. + [stop] whileFalse: [ + n := n + 1. + n >= 4 ifTrue: [stop := true]]. + ^ n") + 4) + +;; ── 6. Body block sees outer locals ── +(st-test + "whileTrue: body reads + writes captured locals" + (evp + "| acc i | + acc := 0. i := 1. + [i <= 10] whileTrue: [acc := acc + i. i := i + 1]. + ^ acc") + 55) + +;; ── 7. Nested while loops ── +(st-test + "nested whileTrue: produces flat sum" + (evp + "| total i j | + total := 0. i := 0. + [i < 3] whileTrue: [ + j := 0. + [j < 4] whileTrue: [total := total + 1. j := j + 1]. + i := i + 1]. + ^ total") + 12) + +;; ── 8. ^ inside whileTrue: short-circuits the surrounding method ── +(st-class-define! "WhileEscape" "Object" (list)) +(st-class-add-method! "WhileEscape" "firstOver:in:" + (st-parse-method + "firstOver: limit in: arr + | i | + i := 1. + [i <= arr size] whileTrue: [ + (arr at: i) > limit ifTrue: [^ arr at: i]. + i := i + 1]. + ^ nil")) + +(st-test + "early ^ from whileTrue: body" + (evp "^ WhileEscape new firstOver: 5 in: #(1 3 5 7 9)") + 7) + +(st-test + "whileTrue: completes when nothing matches" + (evp "^ WhileEscape new firstOver: 100 in: #(1 2 3)") + nil) + +;; ── 9. whileTrue: invocations independent across calls ── +(st-class-define! "Counter2" "Object" (list "n")) +(st-class-add-method! "Counter2" "init" + (st-parse-method "init n := 0. ^ self")) +(st-class-add-method! "Counter2" "n" + (st-parse-method "n ^ n")) +(st-class-add-method! "Counter2" "tick:" + (st-parse-method "tick: count [count > 0] whileTrue: [n := n + 1. count := count - 1]. ^ self")) + +(st-test + "instance state survives whileTrue: invocations" + (evp + "| c | c := Counter2 new init. + c tick: 3. c tick: 4. + ^ c n") + 7) + +;; ── 10. Timing: whileTrue: on a never-true cond runs zero times ── +(st-test + "whileTrue: with always-false cond" + (evp "| ran | ran := false. [false] whileTrue: [ran := true]. ^ ran") + false) + +(list st-test-pass st-test-fail) diff --git a/lib/smalltalk/tokenizer.sx b/lib/smalltalk/tokenizer.sx new file mode 100644 index 00000000..e2e47a50 --- /dev/null +++ b/lib/smalltalk/tokenizer.sx @@ -0,0 +1,366 @@ +;; Smalltalk tokenizer. +;; +;; Token types: +;; ident identifier (foo, Foo, _x) +;; keyword selector keyword (foo:) — value is "foo:" with the colon +;; binary binary selector chars run together (+, ==, ->, <=, ~=, ...) +;; number integer or float; radix integers like 16rFF supported +;; string 'hello''world' style +;; char $c +;; symbol #foo, #foo:bar:, #+, #'with spaces' +;; array-open #( +;; byte-array-open #[ +;; lparen rparen lbracket rbracket lbrace rbrace +;; period semi bar caret colon assign bang +;; eof +;; +;; Comments "…" are skipped. + +(define st-make-token (fn (type value pos) {:type type :value value :pos pos})) + +(define st-digit? (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9")))) + +(define + st-letter? + (fn + (c) + (and + (not (= c nil)) + (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))) + +(define st-ident-start? (fn (c) (or (st-letter? c) (= c "_")))) + +(define st-ident-char? (fn (c) (or (st-ident-start? c) (st-digit? c)))) + +(define st-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r")))) + +(define + st-binary-chars + (list "+" "-" "*" "/" "\\" "~" "<" ">" "=" "@" "%" "&" "?" ",")) + +(define + st-binary-char? + (fn (c) (and (not (= c nil)) (contains? st-binary-chars c)))) + +(define + st-radix-digit? + (fn + (c) + (and + (not (= c nil)) + (or (st-digit? c) (and (>= c "A") (<= c "Z")))))) + +(define + st-tokenize + (fn + (src) + (let + ((tokens (list)) (pos 0) (src-len (len src))) + (define + pk + (fn + (offset) + (if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil))) + (define cur (fn () (pk 0))) + (define advance! (fn (n) (set! pos (+ pos n)))) + (define + push! + (fn + (type value start) + (append! tokens (st-make-token type value start)))) + (define + skip-comment! + (fn + () + (cond + ((>= pos src-len) nil) + ((= (cur) "\"") (advance! 1)) + (else (begin (advance! 1) (skip-comment!)))))) + (define + skip-ws! + (fn + () + (cond + ((>= pos src-len) nil) + ((st-ws? (cur)) (begin (advance! 1) (skip-ws!))) + ((= (cur) "\"") (begin (advance! 1) (skip-comment!) (skip-ws!))) + (else nil)))) + (define + read-ident-chars! + (fn + () + (when + (and (< pos src-len) (st-ident-char? (cur))) + (begin (advance! 1) (read-ident-chars!))))) + (define + read-decimal-digits! + (fn + () + (when + (and (< pos src-len) (st-digit? (cur))) + (begin (advance! 1) (read-decimal-digits!))))) + (define + read-radix-digits! + (fn + () + (when + (and (< pos src-len) (st-radix-digit? (cur))) + (begin (advance! 1) (read-radix-digits!))))) + (define + read-exp-part! + (fn + () + (when + (and + (< pos src-len) + (or (= (cur) "e") (= (cur) "E")) + (let + ((p1 (pk 1)) (p2 (pk 2))) + (or + (st-digit? p1) + (and (or (= p1 "+") (= p1 "-")) (st-digit? p2))))) + (begin + (advance! 1) + (when + (and (< pos src-len) (or (= (cur) "+") (= (cur) "-"))) + (advance! 1)) + (read-decimal-digits!))))) + (define + read-number + (fn + (start) + (begin + (read-decimal-digits!) + (cond + ((and (< pos src-len) (= (cur) "r")) + (let + ((base-str (slice src start pos))) + (begin + (advance! 1) + (let + ((rstart pos)) + (begin + (read-radix-digits!) + (let + ((digits (slice src rstart pos))) + {:radix (parse-number base-str) + :digits digits + :value (parse-radix base-str digits) + :kind "radix"})))))) + ((and + (< pos src-len) + (= (cur) ".") + (st-digit? (pk 1))) + (begin + (advance! 1) + (read-decimal-digits!) + (read-exp-part!) + (parse-number (slice src start pos)))) + (else + (begin + (read-exp-part!) + (parse-number (slice src start pos)))))))) + (define + parse-radix + (fn + (base-str digits) + (let + ((base (parse-number base-str)) + (chars digits) + (n-len (len digits)) + (idx 0) + (acc 0)) + (begin + (define + rd-loop + (fn + () + (when + (< idx n-len) + (let + ((c (nth chars idx))) + (let + ((d (cond + ((and (>= c "0") (<= c "9")) (- (char-code c) 48)) + ((and (>= c "A") (<= c "Z")) (- (char-code c) 55)) + (else 0)))) + (begin + (set! acc (+ (* acc base) d)) + (set! idx (+ idx 1)) + (rd-loop))))))) + (rd-loop) + acc)))) + (define + read-string + (fn + () + (let + ((chars (list))) + (begin + (advance! 1) + (define + loop + (fn + () + (cond + ((>= pos src-len) nil) + ((= (cur) "'") + (cond + ((= (pk 1) "'") + (begin + (append! chars "'") + (advance! 2) + (loop))) + (else (advance! 1)))) + (else + (begin (append! chars (cur)) (advance! 1) (loop)))))) + (loop) + (join "" chars))))) + (define + read-binary-run! + (fn + () + (let + ((start pos)) + (begin + (define + bin-loop + (fn + () + (when + (and (< pos src-len) (st-binary-char? (cur))) + (begin (advance! 1) (bin-loop))))) + (bin-loop) + (slice src start pos))))) + (define + read-symbol + (fn + (start) + (cond + ;; Quoted symbol: #'whatever' + ((= (cur) "'") + (let ((s (read-string))) (push! "symbol" s start))) + ;; Binary-char symbol: #+, #==, #->, #| + ((or (st-binary-char? (cur)) (= (cur) "|")) + (let ((b (read-binary-run!))) + (cond + ((= b "") + ;; lone | wasn't binary; consume it + (begin (advance! 1) (push! "symbol" "|" start))) + (else (push! "symbol" b start))))) + ;; Identifier or keyword chain: #foo, #foo:bar: + ((st-ident-start? (cur)) + (let ((id-start pos)) + (begin + (read-ident-chars!) + (define + kw-loop + (fn + () + (when + (and (< pos src-len) (= (cur) ":")) + (begin + (advance! 1) + (when + (and (< pos src-len) (st-ident-start? (cur))) + (begin (read-ident-chars!) (kw-loop))))))) + (kw-loop) + (push! "symbol" (slice src id-start pos) start)))) + (else + (error + (str "st-tokenize: bad symbol at " pos)))))) + (define + step + (fn + () + (begin + (skip-ws!) + (when + (< pos src-len) + (let + ((start pos) (c (cur))) + (cond + ;; Identifier or keyword + ((st-ident-start? c) + (begin + (read-ident-chars!) + (let + ((word (slice src start pos))) + (cond + ;; ident immediately followed by ':' (and not ':=') => keyword + ((and + (< pos src-len) + (= (cur) ":") + (not (= (pk 1) "="))) + (begin + (advance! 1) + (push! + "keyword" + (str word ":") + start))) + (else (push! "ident" word start)))) + (step))) + ;; Number + ((st-digit? c) + (let + ((v (read-number start))) + (begin (push! "number" v start) (step)))) + ;; String + ((= c "'") + (let + ((s (read-string))) + (begin (push! "string" s start) (step)))) + ;; Character literal + ((= c "$") + (cond + ((>= (+ pos 1) src-len) + (error (str "st-tokenize: $ at end of input"))) + (else + (begin + (advance! 1) + (push! "char" (cur) start) + (advance! 1) + (step))))) + ;; Symbol or array literal + ((= c "#") + (cond + ((= (pk 1) "(") + (begin (advance! 2) (push! "array-open" "#(" start) (step))) + ((= (pk 1) "[") + (begin (advance! 2) (push! "byte-array-open" "#[" start) (step))) + (else + (begin (advance! 1) (read-symbol start) (step))))) + ;; Assignment := or bare colon + ((= c ":") + (cond + ((= (pk 1) "=") + (begin (advance! 2) (push! "assign" ":=" start) (step))) + (else + (begin (advance! 1) (push! "colon" ":" start) (step))))) + ;; Single-char structural punctuation + ((= c "(") (begin (advance! 1) (push! "lparen" "(" start) (step))) + ((= c ")") (begin (advance! 1) (push! "rparen" ")" start) (step))) + ((= c "[") (begin (advance! 1) (push! "lbracket" "[" start) (step))) + ((= c "]") (begin (advance! 1) (push! "rbracket" "]" start) (step))) + ((= c "{") (begin (advance! 1) (push! "lbrace" "{" start) (step))) + ((= c "}") (begin (advance! 1) (push! "rbrace" "}" start) (step))) + ((= c ".") (begin (advance! 1) (push! "period" "." start) (step))) + ((= c ";") (begin (advance! 1) (push! "semi" ";" start) (step))) + ((= c "|") (begin (advance! 1) (push! "bar" "|" start) (step))) + ((= c "^") (begin (advance! 1) (push! "caret" "^" start) (step))) + ((= c "!") (begin (advance! 1) (push! "bang" "!" start) (step))) + ;; Binary selector run + ((st-binary-char? c) + (let + ((b (read-binary-run!))) + (begin (push! "binary" b start) (step)))) + (else + (error + (str + "st-tokenize: unexpected char " + c + " at " + pos))))))))) + (step) + (push! "eof" nil pos) + tokens))) diff --git a/lib/tcl/conformance.sh b/lib/tcl/conformance.sh new file mode 100755 index 00000000..50d0f8d0 --- /dev/null +++ b/lib/tcl/conformance.sh @@ -0,0 +1,145 @@ +#!/usr/bin/env bash +# Tcl-on-SX conformance runner — epoch protocol to sx_server.exe +# Usage: lib/tcl/conformance.sh [file.tcl ...] +# Defaults to lib/tcl/tests/programs/*.tcl +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then echo "ERROR: sx_server.exe not found"; exit 1; fi + +SCOREBOARD_JSON="${SCOREBOARD_JSON:-lib/tcl/scoreboard.json}" +SCOREBOARD_MD="${SCOREBOARD_MD:-lib/tcl/scoreboard.md}" + +# Collect tcl files +if [ "$#" -gt 0 ]; then + TCL_FILES=("$@") +else + TCL_FILES=(lib/tcl/tests/programs/*.tcl) +fi + +# Generate a helper .sx file that defines the Tcl source as an SX string variable. +# We escape the source for SX string literals: backslashes → \\, quotes → \", newlines → \n. +# This is safe in a (define ...) context — no double-parsing like (eval "...") would cause. +write_sx_helper() { + local tcl_file="$1" + local helper_file="$2" + python3 << PYEOF +src = open('${tcl_file}').read() +escaped = src.replace('\\\\', '\\\\\\\\').replace('"', '\\\\"').replace('\\n', '\\\\n') +with open('${helper_file}', 'w') as f: + f.write(f'(define __tcl-src "{escaped}")\\n') + f.write('(define __tcl-result (get (tcl-eval-string (make-default-tcl-interp) __tcl-src) :result))\\n') +PYEOF +} + +total=0 +passed=0 +failed=0 +programs_json="" +md_rows="" + +for tcl_file in "${TCL_FILES[@]}"; do + basename_noext=$(basename "$tcl_file" .tcl) + total=$((total + 1)) + + # Read expected value from first-line comment "# expected: VALUE" + expected=$(head -1 "$tcl_file" | sed -n 's/^# expected: *//p') + if [ -z "$expected" ]; then + echo "WARN: no '# expected:' annotation in $tcl_file — skipping" + continue + fi + + tmpfile=$(mktemp) + helper=$(mktemp --suffix=.sx) + trap "rm -f $tmpfile $helper" EXIT + + # Write helper .sx with Tcl source embedded as SX string + write_sx_helper "$tcl_file" "$helper" + + # Build epoch input using quoted heredoc for static parts; helper path via variable + cat > "$tmpfile" << EPOCHS +(epoch 1) +(load "lib/tcl/tokenizer.sx") +(epoch 2) +(load "lib/tcl/parser.sx") +(epoch 3) +(load "lib/tcl/runtime.sx") +(epoch 4) +(load "$helper") +(epoch 5) +(eval "__tcl-result") +(epoch 6) +EPOCHS + + output=$(timeout 30 "$SX_SERVER" < "$tmpfile" 2>&1) + got=$(echo "$output" | grep -A1 "^(ok-len 5 " | tail -1 | tr -d '"') + + if [ "$got" = "$expected" ]; then + status="PASS" + passed=$((passed + 1)) + echo "PASS $basename_noext (expected: $expected, got: $got)" + else + status="FAIL" + failed=$((failed + 1)) + echo "FAIL $basename_noext (expected: $expected, got: ${got:-})" + if [ -n "${VERBOSE:-}" ]; then + echo "--- server output ---" + echo "$output" + echo "--- helper.sx ---" + cat "$helper" + fi + fi + + # Accumulate JSON fragment (escape for JSON) + got_json=$(printf '%s' "$got" | python3 -c "import sys,json; sys.stdout.write(json.dumps(sys.stdin.read()))" | tr -d '"') + exp_json=$(printf '%s' "$expected" | python3 -c "import sys,json; sys.stdout.write(json.dumps(sys.stdin.read()))" | tr -d '"') + + if [ -n "$programs_json" ]; then + programs_json="${programs_json}," + fi + programs_json="${programs_json} + \"${basename_noext}\": {\"status\": \"${status}\", \"expected\": \"${exp_json}\", \"got\": \"${got_json}\"}" + + # Accumulate Markdown row + if [ "$status" = "PASS" ]; then + icon="✓ PASS" + else + icon="✗ FAIL" + fi + md_rows="${md_rows}| ${basename_noext} | ${icon} | ${expected} | ${got} | +" +done + +# Write scoreboard.json +cat > "$SCOREBOARD_JSON" << JSON +{ + "total": ${total}, + "passed": ${passed}, + "failed": ${failed}, + "programs": {${programs_json} + } +} +JSON + +# Write scoreboard.md +cat > "$SCOREBOARD_MD" << MD +# Tcl-on-SX Conformance Scoreboard + +| Program | Status | Expected | Got | +|---|---|---|---| +${md_rows} +**${passed}/${total} passing** +MD + +echo "" +echo "Scoreboard: ${passed}/${total} passing" +echo "Written: $SCOREBOARD_JSON, $SCOREBOARD_MD" + +if [ "$failed" -gt 0 ]; then + exit 1 +fi +exit 0 diff --git a/lib/tcl/parser.sx b/lib/tcl/parser.sx new file mode 100644 index 00000000..f94fd328 --- /dev/null +++ b/lib/tcl/parser.sx @@ -0,0 +1,41 @@ +; Tcl parser — thin layer over tcl-tokenize +; Adds tcl-parse entry point and word utility fns + +; Entry point: parse Tcl source to a list of commands. +; Returns same structure as tcl-tokenize. +(define tcl-parse (fn (src) (tcl-tokenize src))) + +; True if word has no substitutions — value can be read statically. +; braced words are always simple. compound words are simple when all +; parts are plain text with no var/cmd parts. +(define tcl-word-simple? + (fn (word) + (cond + ((= (get word :type) "braced") true) + ((= (get word :type) "compound") + (let ((parts (get word :parts))) + (every? (fn (p) (= (get p :type) "text")) parts))) + (else false)))) + +; Concatenate text parts of a simple word into a single string. +; For braced words returns :value directly. +; For compound words with only text parts, joins them. +; Returns nil for words with substitutions. +(define tcl-word-literal + (fn (word) + (cond + ((= (get word :type) "braced") (get word :value)) + ((= (get word :type) "compound") + (if (tcl-word-simple? word) + (join "" (map (fn (p) (get p :value)) (get word :parts))) + nil)) + (else nil)))) + +; Number of words in a parsed command. +(define tcl-cmd-len + (fn (cmd) (len (get cmd :words)))) + +; Nth word literal from a command (index 0 = command name). +; Returns nil if word has substitutions. +(define tcl-nth-literal + (fn (cmd n) (tcl-word-literal (nth (get cmd :words) n)))) diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx new file mode 100644 index 00000000..7c7fe08c --- /dev/null +++ b/lib/tcl/runtime.sx @@ -0,0 +1,3290 @@ +; Tcl-on-SX runtime evaluator +; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output} + +(define make-frame (fn (level parent) {:level level :locals {} :parent parent})) + +(define + frame-lookup + (fn + (frame name) + (if + (nil? frame) + nil + (let + ((val (get (get frame :locals) name))) + (if (nil? val) (frame-lookup (get frame :parent) name) val))))) + +(define + frame-set-top + (fn + (frame name val) + (assoc frame :locals (assoc (get frame :locals) name val)))) + +(define make-tcl-interp (fn () {:result "" :output "" :code 0 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {} :current-ns "::" :coroutines {} :in-coro false :coro-yields (list)})) + +(define + tcl-register + (fn + (interp name f) + (assoc interp :commands (assoc (get interp :commands) name f)))) + +; --- upvar alias helpers --- + +(define upvar-alias? (fn (v) (and (dict? v) (not (nil? (get v :upvar-level)))))) + +; take first n elements of a list +(define + take-n + (fn + (lst n) + (if + (or (<= n 0) (= 0 (len lst))) + (list) + (append (list (first lst)) (take-n (rest lst) (- n 1)))))) + +; replace element at index i in list with val (0-based) +(define + replace-at + (fn + (lst i val) + (let + ((go + (fn + (remaining j acc) + (if + (= 0 (len remaining)) + acc + (go + (rest remaining) + (+ j 1) + (append acc (list (if (= j i) val (first remaining))))))))) + (go lst 0 (list))))) + +; build full-stack = frame-stack + [current-frame] +(define + tcl-full-stack + (fn (interp) + (append (get interp :frame-stack) (list (get interp :frame))))) + +; get target frame at absolute level from full-stack +(define + tcl-frame-nth + (fn (full-stack level) + (nth full-stack level))) + +(define + tcl-var-get + (fn + (interp name) + (let + ((val (frame-lookup (get interp :frame) name))) + (if + (nil? val) + (error (str "can't read \"" name "\": no such variable")) + (if + (upvar-alias? val) + ; follow alias to target frame + (let + ((target-level (get val :upvar-level)) + (target-name (get val :upvar-name))) + (let + ((full-stack (tcl-full-stack interp))) + (let + ((target-frame (tcl-frame-nth full-stack target-level))) + (let + ((target-val (frame-lookup target-frame target-name))) + (if + (nil? target-val) + (error (str "can't read \"" name "\": no such variable")) + target-val))))) + val))))) + +(define + tcl-var-set + (fn + (interp name val) + (let + ((cur-val (get (get (get interp :frame) :locals) name))) + (if + (and (not (nil? cur-val)) (upvar-alias? cur-val)) + ; set in target frame + (let + ((target-level (get cur-val :upvar-level)) + (target-name (get cur-val :upvar-name))) + (let + ((full-stack (tcl-full-stack interp))) + (let + ((target-frame (tcl-frame-nth full-stack target-level))) + (let + ((updated-target (frame-set-top target-frame target-name val))) + (let + ((new-full-stack (replace-at full-stack target-level updated-target))) + (let + ((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1))) + (new-current (nth new-full-stack (- (len new-full-stack) 1)))) + (assoc interp :frame new-current :frame-stack new-frame-stack))))))) + ; normal set in current frame top + (assoc interp :frame (frame-set-top (get interp :frame) name val)))))) + +(define + tcl-eval-parts + (fn + (parts interp) + (reduce + (fn + (acc part) + (let + ((type (get part :type)) (cur-interp (get acc :interp))) + (cond + ((equal? type "text") {:values (append (get acc :values) (list (get part :value))) :interp cur-interp}) + ((equal? type "var") {:values (append (get acc :values) (list (tcl-var-get cur-interp (get part :name)))) :interp cur-interp}) + ((equal? type "var-arr") + (let + ((key-acc (tcl-eval-parts (get part :key) cur-interp))) + (let + ((key (join "" (get key-acc :values))) + (next-interp (get key-acc :interp))) + {:values (append (get acc :values) (list (tcl-var-get next-interp (str (get part :name) "(" key ")")))) :interp next-interp}))) + ((equal? type "cmd") + (let + ((new-interp (tcl-eval-string cur-interp (get part :src)))) + {:values (append (get acc :values) (list (get new-interp :result))) :interp new-interp})) + (else (error (str "tcl: unknown part type: " type)))))) + {:values (quote ()) :interp interp} + parts))) + +(define + tcl-eval-word + (fn + (word interp) + (let + ((type (get word :type))) + (cond + ((equal? type "braced") {:interp interp :value (get word :value)}) + ((equal? type "compound") + (let + ((result (tcl-eval-parts (get word :parts) interp))) + {:interp (get result :interp) :value (join "" (get result :values))})) + ((equal? type "expand") (tcl-eval-word (get word :word) interp)) + (else (error (str "tcl: unknown word type: " type))))))) + +(define + tcl-list-split + (fn + (s) + (define chars (split s "")) + (define len-s (len chars)) + (define + go + (fn + (i acc cur-item depth) + (if + (>= i len-s) + (if (> (len cur-item) 0) (append acc (list cur-item)) acc) + (let + ((c (nth chars i))) + (cond + ((equal? c "{") + (if + (= depth 0) + (go (+ i 1) acc "" (+ depth 1)) + (go (+ i 1) acc (str cur-item c) (+ depth 1)))) + ((equal? c "}") + (if + (= depth 1) + (go (+ i 1) (append acc (list cur-item)) "" 0) + (go (+ i 1) acc (str cur-item c) (- depth 1)))) + ((equal? c " ") + (if + (and (= depth 0) (> (len cur-item) 0)) + (go (+ i 1) (append acc (list cur-item)) "" 0) + (go + (+ i 1) + acc + (if (> depth 0) (str cur-item c) cur-item) + depth))) + (else (go (+ i 1) acc (str cur-item c) depth))))))) + (go 0 (list) "" 0))) + +(define + tcl-eval-words + (fn + (words interp) + (reduce + (fn + (acc w) + (let + ((cur-interp (get acc :interp))) + (if + (equal? (get w :type) "expand") + (let + ((wr (tcl-eval-word (get w :word) cur-interp))) + {:values (append (get acc :values) (tcl-list-split (get wr :value))) :interp (get wr :interp)}) + (let ((wr (tcl-eval-word w cur-interp))) {:values (append (get acc :values) (list (get wr :value))) :interp (get wr :interp)})))) + {:values (quote ()) :interp interp} + words))) + +; --- proc call --- + +; Bind proc parameters: returns updated frame +(define + tcl-bind-params + (fn + (frame params call-args) + (if + (= 0 (len params)) + frame + (let + ((pname (first params)) (rest-ps (rest params))) + (if + (equal? pname "args") + ; rest param: collect remaining call-args as list string + (frame-set-top frame "args" (tcl-list-build call-args)) + (if + (= 0 (len call-args)) + (error (str "wrong # args: no value for parameter \"" pname "\"")) + (tcl-bind-params + (frame-set-top frame pname (first call-args)) + rest-ps + (rest call-args)))))))) + +(define + tcl-call-proc + (fn + (interp proc-name proc-def call-args) + (let + ((param-spec (get proc-def :args)) + (body (get proc-def :body))) + (let + ((params (if (equal? param-spec "") (list) (tcl-list-split param-spec)))) + (let + ((caller-stack-len (len (get interp :frame-stack))) + (new-frame (make-frame (+ (len (get interp :frame-stack)) 1) nil))) + (let + ((bound-frame (tcl-bind-params new-frame params call-args))) + (let + ((proc-ns (let ((ns (get proc-def :ns))) (if (nil? ns) (get interp :current-ns) ns)))) + (let + ((proc-interp + (assoc interp + :frame bound-frame + :frame-stack (append (get interp :frame-stack) (list (get interp :frame))) + :output "" + :result "" + :code 0 + :current-ns proc-ns)) + (caller-output (get interp :output))) + (let + ((result-interp (tcl-eval-string proc-interp body))) + (let + ((code (get result-interp :code)) + (result-val (get result-interp :result)) + (proc-output (get result-interp :output))) + (let + ; result-stack = [updated-frame-0..updated-caller-frame] + ; recover updated caller frame and below-caller frames + ((result-stack (get result-interp :frame-stack))) + (let + ((updated-below (take-n result-stack caller-stack-len)) + (updated-caller + (if + (> (len result-stack) caller-stack-len) + (nth result-stack caller-stack-len) + (get interp :frame)))) + (assoc interp + :frame updated-caller + :frame-stack updated-below + :result result-val + :output (str caller-output proc-output) + :code (if (= code 2) 0 code) + :coro-yields (get result-interp :coro-yields) + :coroutines (get result-interp :coroutines) + :commands (get result-interp :commands)))))))))))))) + +(define + tcl-eval-cmd + (fn + (interp cmd) + (let + ((wr (tcl-eval-words (get cmd :words) interp))) + (let + ((words (get wr :values)) (cur-interp (get wr :interp))) + (if + (= 0 (len words)) + cur-interp + (let + ((cmd-name (first words)) (cmd-args (rest words))) + (let + ((cmd-fn (get (get cur-interp :commands) cmd-name))) + (if + (nil? cmd-fn) + (let + ((proc-entry (tcl-proc-lookup cur-interp cmd-name))) + (if + (nil? proc-entry) + (error (str "unknown command: \"" cmd-name "\"")) + (tcl-call-proc cur-interp (get proc-entry :name) (get proc-entry :def) cmd-args))) + (cmd-fn cur-interp cmd-args))))))))) + +(define + tcl-eval-script + (fn + (interp cmds) + (if + (or (= 0 (len cmds)) (not (= 0 (get interp :code)))) + interp + (tcl-eval-script (tcl-eval-cmd interp (first cmds)) (rest cmds))))) + +(define + tcl-eval-string + (fn (interp src) (tcl-eval-script interp (tcl-parse src)))) + +(define + tcl-cmd-set + (fn + (interp args) + (if + (= (len args) 1) + (assoc interp :result (tcl-var-get interp (first args))) + (let + ((val (nth args 1))) + (assoc (tcl-var-set interp (first args) val) :result val))))) + +(define + tcl-cmd-puts + (fn + (interp args) + (let + ((text (last args)) + (no-nl + (and + (> (len args) 1) + (equal? (first args) "-nonewline")))) + (let + ((line (if no-nl text (str text "\n")))) + (assoc interp :output (str (get interp :output) line)))))) + +(define + tcl-cmd-incr + (fn + (interp args) + (let + ((name (first args)) + (delta + (if + (> (len args) 1) + (parse-int (nth args 1)) + 1))) + (let + ((new-val (str (+ (parse-int (tcl-var-get interp name)) delta)))) + (assoc (tcl-var-set interp name new-val) :result new-val))))) + +(define + tcl-cmd-append + (fn + (interp args) + (let + ((name (first args)) (suffix (join "" (rest args)))) + (let + ((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" (tcl-var-get interp name))))) + (let + ((new-val (str cur suffix))) + (assoc (tcl-var-set interp name new-val) :result new-val)))))) + +(define + tcl-true? + (fn + (s) + (not + (or (equal? s "0") (equal? s "") (equal? s "false") (equal? s "no"))))) + +(define tcl-false? (fn (s) (not (tcl-true? s)))) + +(define + tcl-expr-digit? + (fn + (c) + (contains? (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") c))) + +(define + tcl-expr-alpha? + (fn + (c) + (contains? + (list + "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" + "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" + "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" + "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" + "_") + c))) + +(define + tcl-expr-op-char? + (fn + (c) + (contains? + (list "+" "-" "*" "/" "%" "!" "~" "&" "|" "^" "<" ">" "=") + c))) + +(define + tcl-expr-ws? + (fn (c) (or (equal? c " ") (equal? c "\t") (equal? c "\n") (equal? c "\r")))) + +(define + tcl-pow + (fn + (base exp) + (if + (= exp 0) + 1 + (* base (tcl-pow base (- exp 1)))))) + +(define + tcl-isqrt + (fn + (n) + (if + (<= n 0) + 0 + (let + ((go (fn (x) (let ((x2 (/ (+ x (/ n x)) 2))) (if (>= x2 x) x (go x2)))))) + (go n))))) + +(define + tcl-apply-func + (fn + (name args) + (let + ((a0 (if (> (len args) 0) (parse-int (first args)) 0)) + (a1 (if (> (len args) 1) (parse-int (nth args 1)) 0))) + (cond + ((equal? name "abs") (str (if (< a0 0) (- 0 a0) a0))) + ((equal? name "int") (str a0)) + ((equal? name "double") (str a0)) + ((equal? name "round") (str a0)) + ((equal? name "floor") (str a0)) + ((equal? name "ceil") (str a0)) + ((equal? name "sqrt") (str (tcl-isqrt a0))) + ((equal? name "pow") (str (tcl-pow a0 a1))) + ((equal? name "max") (str (if (>= a0 a1) a0 a1))) + ((equal? name "min") (str (if (<= a0 a1) a0 a1))) + ((equal? name "sin") "0") + ((equal? name "cos") "1") + ((equal? name "tan") "0") + (else (error (str "expr: unknown function: " name))))))) + +(define + tcl-apply-binop + (fn + (op l r) + (cond + ((equal? op "+") (str (+ (parse-int l) (parse-int r)))) + ((equal? op "-") (str (- (parse-int l) (parse-int r)))) + ((equal? op "*") (str (* (parse-int l) (parse-int r)))) + ((equal? op "/") (str (/ (parse-int l) (parse-int r)))) + ((equal? op "%") (str (mod (parse-int l) (parse-int r)))) + ((equal? op "==") (if (equal? l r) "1" "0")) + ((equal? op "!=") (if (equal? l r) "0" "1")) + ((equal? op "<") (if (< (parse-int l) (parse-int r)) "1" "0")) + ((equal? op ">") (if (> (parse-int l) (parse-int r)) "1" "0")) + ((equal? op "<=") (if (<= (parse-int l) (parse-int r)) "1" "0")) + ((equal? op ">=") (if (>= (parse-int l) (parse-int r)) "1" "0")) + ((equal? op "&&") (if (and (tcl-true? l) (tcl-true? r)) "1" "0")) + ((equal? op "||") (if (or (tcl-true? l) (tcl-true? r)) "1" "0")) + ((equal? op "**") (str (tcl-pow (parse-int l) (parse-int r)))) + (else (error (str "expr: unknown op: " op)))))) + +(define + tcl-expr-tokenize + (fn + (s) + (let + ((chars (split s "")) + (n (len (split s "")))) + (let + ((go + (fn + (i acc cur mode) + (if + (>= i n) + (if (> (len cur) 0) (append acc (list cur)) acc) + (let + ((c (nth chars i))) + (cond + ((tcl-expr-ws? c) + (if + (> (len cur) 0) + (go (+ i 1) (append acc (list cur)) "" "none") + (go (+ i 1) acc "" "none"))) + ((or (equal? c "(") (equal? c ")") (equal? c ",")) + (let + ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) + (go (+ i 1) (append acc2 (list c)) "" "none"))) + ((equal? c "\"") + (let + ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) + (let + ((read-str + (fn + (j s-acc) + (if + (>= j n) + {:tok s-acc :next j} + (let + ((sc (nth chars j))) + (if + (equal? sc "\"") + {:tok s-acc :next (+ j 1)} + (read-str (+ j 1) (str s-acc sc)))))))) + (let + ((sr (read-str (+ i 1) ""))) + (go (get sr :next) (append acc2 (list (get sr :tok))) "" "none"))))) + ((tcl-expr-op-char? c) + (let + ((acc2 (if (and (> (len cur) 0) (not (equal? mode "op"))) (append acc (list cur)) acc)) + (cur2 (if (and (> (len cur) 0) (not (equal? mode "op"))) "" cur))) + (let + ((next-c (if (< (+ i 1) n) (nth chars (+ i 1)) ""))) + (let + ((two (str c next-c))) + (if + (contains? (list "**" "==" "!=" "<=" ">=" "&&" "||") two) + (let + ((acc3 (if (> (len cur2) 0) (append acc2 (list cur2)) acc2))) + (go (+ i 2) (append acc3 (list two)) "" "none")) + (let + ((acc3 (if (> (len cur2) 0) (append acc2 (list cur2)) acc2))) + (go (+ i 1) (append acc3 (list c)) "" "none"))))))) + ((tcl-expr-digit? c) + (if + (equal? mode "ident") + (go (+ i 1) acc (str cur c) "ident") + (if + (or (equal? mode "num") (equal? mode "none") (equal? mode "")) + (go (+ i 1) acc (str cur c) "num") + (let + ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) + (go (+ i 1) acc2 c "num"))))) + ((equal? c ".") + (go (+ i 1) acc (str cur c) "num")) + ((tcl-expr-alpha? c) + (if + (or (equal? mode "ident") (equal? mode "none") (equal? mode "")) + (go (+ i 1) acc (str cur c) "ident") + (let + ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) + (go (+ i 1) acc2 c "ident")))) + (else + (let + ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) + (go (+ i 1) (append acc2 (list c)) "" "none"))))))))) + (go 0 (list) "" "none"))))) + +(define + tcl-expr-parse-args-rest + (fn + (tokens acc) + (if + (or (= 0 (len tokens)) (equal? (first tokens) ")")) + {:args acc :tokens tokens} + (if + (equal? (first tokens) ",") + (let + ((r (tcl-expr-parse-or (rest tokens)))) + (tcl-expr-parse-args-rest + (get r :tokens) + (append acc (list (get r :value))))) + {:args acc :tokens tokens})))) + +(define + tcl-expr-parse-args + (fn + (tokens) + (if + (or (= 0 (len tokens)) (equal? (first tokens) ")")) + {:args (list) :tokens tokens} + (let + ((r (tcl-expr-parse-or tokens))) + (tcl-expr-parse-args-rest + (get r :tokens) + (list (get r :value))))))) + +(define + tcl-expr-parse-primary + (fn + (tokens) + (if + (= 0 (len tokens)) + (error "expr: unexpected end of expression") + (let + ((tok (first tokens)) (rest-toks (rest tokens))) + (cond + ((equal? tok "(") + (let + ((inner (tcl-expr-parse-or rest-toks))) + (let + ((after (get inner :tokens))) + (if + (and (> (len after) 0) (equal? (first after) ")")) + {:value (get inner :value) :tokens (rest after)} + (error "expr: missing closing paren"))))) + ((and + (> (len rest-toks) 0) + (equal? (first rest-toks) "(")) + (let + ((args-r (tcl-expr-parse-args (rest rest-toks)))) + (let + ((after-args (get args-r :tokens))) + (if + (and (> (len after-args) 0) (equal? (first after-args) ")")) + {:value (tcl-apply-func tok (get args-r :args)) :tokens (rest after-args)} + (error (str "expr: missing ) after function call " tok)))))) + (else {:value tok :tokens rest-toks})))))) + +(define + tcl-expr-parse-unary + (fn + (tokens) + (if + (= 0 (len tokens)) + (error "expr: unexpected end in unary") + (let + ((tok (first tokens))) + (cond + ((equal? tok "!") + (let + ((r (tcl-expr-parse-unary (rest tokens)))) + {:value (if (tcl-false? (get r :value)) "1" "0") :tokens (get r :tokens)})) + ((equal? tok "-") + (let + ((r (tcl-expr-parse-unary (rest tokens)))) + {:value (str (- 0 (parse-int (get r :value)))) :tokens (get r :tokens)})) + ((equal? tok "+") + (tcl-expr-parse-unary (rest tokens))) + (else (tcl-expr-parse-primary tokens))))))) + +(define + tcl-expr-parse-power + (fn + (tokens) + (let + ((base-r (tcl-expr-parse-unary tokens))) + (let + ((base-val (get base-r :value)) (rest-toks (get base-r :tokens))) + (if + (and (> (len rest-toks) 0) (equal? (first rest-toks) "**")) + (let + ((exp-r (tcl-expr-parse-power (rest rest-toks)))) + {:value (str (tcl-pow (parse-int base-val) (parse-int (get exp-r :value)))) :tokens (get exp-r :tokens)}) + {:value base-val :tokens rest-toks}))))) + +(define + tcl-expr-parse-multiplicative-rest + (fn + (tokens left) + (if + (or (= 0 (len tokens)) (not (contains? (list "*" "/" "%") (first tokens)))) + {:value left :tokens tokens} + (let + ((op (first tokens))) + (let + ((r (tcl-expr-parse-power (rest tokens)))) + (tcl-expr-parse-multiplicative-rest + (get r :tokens) + (tcl-apply-binop op left (get r :value)))))))) + +(define + tcl-expr-parse-multiplicative + (fn + (tokens) + (let + ((r (tcl-expr-parse-power tokens))) + (tcl-expr-parse-multiplicative-rest (get r :tokens) (get r :value))))) + +(define + tcl-expr-parse-additive-rest + (fn + (tokens left) + (if + (or (= 0 (len tokens)) (not (contains? (list "+" "-") (first tokens)))) + {:value left :tokens tokens} + (let + ((op (first tokens))) + (let + ((r (tcl-expr-parse-multiplicative (rest tokens)))) + (tcl-expr-parse-additive-rest + (get r :tokens) + (tcl-apply-binop op left (get r :value)))))))) + +(define + tcl-expr-parse-additive + (fn + (tokens) + (let + ((r (tcl-expr-parse-multiplicative tokens))) + (tcl-expr-parse-additive-rest (get r :tokens) (get r :value))))) + +(define + tcl-expr-parse-relational-rest + (fn + (tokens left) + (if + (or (= 0 (len tokens)) (not (contains? (list "<" ">" "<=" ">=") (first tokens)))) + {:value left :tokens tokens} + (let + ((op (first tokens))) + (let + ((r (tcl-expr-parse-additive (rest tokens)))) + (tcl-expr-parse-relational-rest + (get r :tokens) + (tcl-apply-binop op left (get r :value)))))))) + +(define + tcl-expr-parse-relational + (fn + (tokens) + (let + ((r (tcl-expr-parse-additive tokens))) + (tcl-expr-parse-relational-rest (get r :tokens) (get r :value))))) + +(define + tcl-expr-parse-equality-rest + (fn + (tokens left) + (if + (or (= 0 (len tokens)) (not (contains? (list "==" "!=") (first tokens)))) + {:value left :tokens tokens} + (let + ((op (first tokens))) + (let + ((r (tcl-expr-parse-relational (rest tokens)))) + (tcl-expr-parse-equality-rest + (get r :tokens) + (tcl-apply-binop op left (get r :value)))))))) + +(define + tcl-expr-parse-equality + (fn + (tokens) + (let + ((r (tcl-expr-parse-relational tokens))) + (tcl-expr-parse-equality-rest (get r :tokens) (get r :value))))) + +(define + tcl-expr-parse-and-rest + (fn + (tokens left) + (if + (or (= 0 (len tokens)) (not (equal? (first tokens) "&&"))) + {:value left :tokens tokens} + (let + ((r (tcl-expr-parse-equality (rest tokens)))) + (tcl-expr-parse-and-rest + (get r :tokens) + (tcl-apply-binop "&&" left (get r :value))))))) + +(define + tcl-expr-parse-and + (fn + (tokens) + (let + ((r (tcl-expr-parse-equality tokens))) + (tcl-expr-parse-and-rest (get r :tokens) (get r :value))))) + +(define + tcl-expr-parse-or-rest + (fn + (tokens left) + (if + (or (= 0 (len tokens)) (not (equal? (first tokens) "||"))) + {:value left :tokens tokens} + (let + ((r (tcl-expr-parse-and (rest tokens)))) + (tcl-expr-parse-or-rest + (get r :tokens) + (tcl-apply-binop "||" left (get r :value))))))) + +(define + tcl-expr-parse-or + (fn + (tokens) + (let + ((r (tcl-expr-parse-and tokens))) + (tcl-expr-parse-or-rest (get r :tokens) (get r :value))))) + +(define + tcl-expr-parse + (fn + (tokens) + (if + (= 0 (len tokens)) + "0" + (get (tcl-expr-parse-or tokens) :value)))) + +(define + tcl-expr-eval + (fn + (interp s) + (let + ((cmds (tcl-parse s))) + (if + (= 0 (len cmds)) + {:result "0" :interp interp} + (let + ((wr (tcl-eval-words (get (first cmds) :words) interp))) + (let + ((flat (join " " (get wr :values)))) + (let + ((tokens (tcl-expr-tokenize flat))) + {:result (tcl-expr-parse tokens) :interp (get wr :interp)}))))))) + +(define tcl-cmd-break (fn (interp args) (assoc interp :code 3))) + +(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4))) + +; Parse -code name/number to integer +(define + tcl-return-code-num + (fn + (s) + (cond + ((equal? s "ok") 0) + ((equal? s "error") 1) + ((equal? s "return") 2) + ((equal? s "break") 3) + ((equal? s "continue") 4) + (else (parse-int s))))) + +; Parse return options from args list +; Returns {:code N :result val :errorinfo str :errorcode str} +(define + tcl-parse-return-opts + (fn + (args) + (let + ((go + (fn + (remaining code ei ec) + (if + (or (= 0 (len remaining)) (not (equal? (substring (first remaining) 0 1) "-"))) + {:code code :result (if (> (len remaining) 0) (first remaining) "") :errorinfo ei :errorcode ec} + (let + ((flag (first remaining)) (rest1 (rest remaining))) + (cond + ((equal? flag "-code") + (if + (= 0 (len rest1)) + {:code code :result "" :errorinfo ei :errorcode ec} + (go (rest rest1) (tcl-return-code-num (first rest1)) ei ec))) + ((equal? flag "-errorinfo") + (if + (= 0 (len rest1)) + {:code code :result "" :errorinfo "" :errorcode ec} + (go (rest rest1) code (first rest1) ec))) + ((equal? flag "-errorcode") + (if + (= 0 (len rest1)) + {:code code :result "" :errorinfo ei :errorcode ""} + (go (rest rest1) code ei (first rest1)))) + ((equal? flag "-level") + ; stub: consume the level arg and ignore + (if + (= 0 (len rest1)) + {:code code :result "" :errorinfo ei :errorcode ec} + (go (rest rest1) code ei ec))) + (else + ; unknown flag: treat as value + {:code code :result flag :errorinfo ei :errorcode ec}))))))) + (go args 2 "" "")))) + +(define + tcl-cmd-return + (fn + (interp args) + (let + ((opts (tcl-parse-return-opts args))) + (assoc interp + :result (get opts :result) + :code (get opts :code) + :errorinfo (get opts :errorinfo) + :errorcode (get opts :errorcode))))) + +(define + tcl-cmd-error + (fn + (interp args) + (let + ((msg (if (> (len args) 0) (first args) "error")) + (ei (if (> (len args) 1) (nth args 1) "")) + (ec (if (> (len args) 2) (nth args 2) ""))) + (assoc interp :result msg :code 1 :errorinfo ei :errorcode ec)))) + +; --- catch command --- +; catch script ?resultVar? ?optionsVar? +(define + tcl-cmd-catch + (fn + (interp args) + (let + ((script (first args)) + (result-var (if (> (len args) 1) (nth args 1) nil)) + (opts-var (if (> (len args) 2) (nth args 2) nil))) + (let + ; run script in a sub-interp with code/result/output reset + ((sub-interp (assoc interp :code 0 :result "" :output "")) + (caller-output (get interp :output))) + (let + ((result-interp (tcl-eval-string sub-interp script))) + (let + ((rc (get result-interp :code)) + (rv (get result-interp :result)) + (rei (get result-interp :errorinfo)) + (rec (get result-interp :errorcode)) + (sub-output (get result-interp :output))) + (let + ; merge sub-interp frame changes back but reset code to 0 + ((merged (assoc result-interp + :code 0 + :result (str rc) + :output (str caller-output sub-output)))) + (let + ; set resultVar if given + ((after-rv + (if (nil? result-var) + merged + (tcl-var-set merged result-var rv)))) + (let + ; set optsVar if given + ((opts-str (str "-code " rc " -errorinfo " (if (equal? rei "") "{}" rei) " -errorcode " (if (equal? rec "") "{}" rec)))) + (let + ((after-opts + (if (nil? opts-var) + after-rv + (tcl-var-set after-rv opts-var opts-str)))) + (assoc after-opts :result (str rc)))))))))))) + +; --- throw command --- +; throw type message +(define + tcl-cmd-throw + (fn + (interp args) + (let + ((ec (if (> (len args) 0) (first args) "")) + (msg (if (> (len args) 1) (nth args 1) ""))) + (assoc interp :result msg :code 1 :errorcode ec :errorinfo "")))) + +; --- try command --- +; try script ?on code var body? ... ?finally body? +(define + tcl-try-code-matches? + (fn + (code-str rc) + (cond + ((equal? code-str "ok") (= rc 0)) + ((equal? code-str "error") (= rc 1)) + ((equal? code-str "return") (= rc 2)) + ((equal? code-str "break") (= rc 3)) + ((equal? code-str "continue") (= rc 4)) + (else (= rc (parse-int code-str)))))) + +(define + tcl-cmd-try + (fn + (interp args) + (let + ((script (first args)) + (rest-args (rest args))) + ; Parse clauses: list of {:type "on"|"finally" :code str :var str :body str} + (let + ((parse-clauses + (fn + (remaining acc) + (if + (= 0 (len remaining)) + acc + (let + ((kw (first remaining))) + (cond + ((equal? kw "on") + (if (< (len remaining) 4) + acc + (parse-clauses + (slice remaining 4 (len remaining)) + (append acc (list {:type "on" :code (nth remaining 1) :var (nth remaining 2) :body (nth remaining 3)}))))) + ((equal? kw "finally") + (if (< (len remaining) 2) + acc + (parse-clauses + (slice remaining 2 (len remaining)) + (append acc (list {:type "finally" :body (nth remaining 1)}))))) + (else acc)))))) + (clauses (parse-clauses rest-args (list)))) + ; Run the main script + (let + ((sub-interp (assoc interp :code 0 :result "")) + (caller-output (get interp :output))) + (let + ((result-interp (tcl-eval-string sub-interp script))) + (let + ((rc (get result-interp :code)) + (rv (get result-interp :result)) + (sub-output (get result-interp :output))) + ; Find matching "on" clause + (let + ((find-clause + (fn + (cs) + (if + (= 0 (len cs)) + nil + (let + ((c (first cs))) + (if + (and (equal? (get c :type) "on") (tcl-try-code-matches? (get c :code) rc)) + c + (find-clause (rest cs))))))) + (matched (find-clause clauses)) + ; Find finally clause + (finally-clause + (reduce + (fn (acc c) (if (equal? (get c :type) "finally") c acc)) + nil + clauses))) + ; Evaluate matched handler if any + (let + ((after-handler + (if + (nil? matched) + (assoc result-interp :output (str caller-output sub-output)) + (let + ((handler-interp + (assoc result-interp + :code 0 + :output (str caller-output sub-output)))) + (let + ((bound-interp + (if (equal? (get matched :var) "") + handler-interp + (tcl-var-set handler-interp (get matched :var) rv)))) + (tcl-eval-string bound-interp (get matched :body))))))) + ; Run finally if present + (let + ((final-result + (if + (nil? finally-clause) + after-handler + (let + ((fi (tcl-eval-string (assoc after-handler :code 0) (get finally-clause :body)))) + ; Restore code from after-handler unless finally itself errored + (if (= (get fi :code) 0) + (assoc fi :code (get after-handler :code) :result (get after-handler :result)) + fi))))) + final-result)))))))))) + +(define + tcl-cmd-unset + (fn + (interp args) + (reduce + (fn + (i name) + (let + ((frame (get i :frame))) + (let + ((new-locals (reduce (fn (acc k) (if (equal? k name) acc (assoc acc k (get (get frame :locals) k)))) {} (keys (get frame :locals))))) + (assoc i :frame (assoc frame :locals new-locals))))) + interp + args))) + +(define + tcl-cmd-lappend + (fn + (interp args) + (let + ((name (first args)) (items (rest args))) + (let + ((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" (tcl-var-get interp name))))) + (let + ((quoted-items (map tcl-list-quote-elem items))) + (let + ((new-val (if (equal? cur "") (join " " quoted-items) (str cur " " (join " " quoted-items))))) + (assoc (tcl-var-set interp name new-val) :result new-val))))))) + +(define + tcl-cmd-eval + (fn (interp args) (tcl-eval-string interp (join " " args)))) + +(define + tcl-while-loop + (fn + (interp cond-str body) + (let + ((er (tcl-expr-eval interp cond-str))) + (if + (tcl-false? (get er :result)) + (get er :interp) + (let + ((body-result (tcl-eval-string (get er :interp) body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc body-result :code 0)) + ((= code 2) body-result) + ((= code 1) body-result) + (else + (tcl-while-loop + (assoc body-result :code 0) + cond-str + body))))))))) + +(define + tcl-cmd-while + (fn + (interp args) + (tcl-while-loop interp (first args) (nth args 1)))) + +(define + tcl-cmd-if + (fn + (interp args) + (let + ((er (tcl-expr-eval interp (first args)))) + (let + ((cond-true (tcl-true? (get er :result))) + (new-interp (get er :interp)) + (rest-args (rest args))) + (let + ((adj (if (and (> (len rest-args) 0) (equal? (first rest-args) "then")) (rest rest-args) rest-args))) + (let + ((then-body (first adj)) (rest2 (rest adj))) + (if + cond-true + (tcl-eval-string new-interp then-body) + (cond + ((= 0 (len rest2)) new-interp) + ((equal? (first rest2) "else") + (if + (> (len rest2) 1) + (tcl-eval-string new-interp (nth rest2 1)) + new-interp)) + ((equal? (first rest2) "elseif") + (tcl-cmd-if new-interp (rest rest2))) + (else new-interp))))))))) + +(define + tcl-for-loop + (fn + (interp cond-str step body) + (let + ((er (tcl-expr-eval interp cond-str))) + (if + (tcl-false? (get er :result)) + (get er :interp) + (let + ((body-result (tcl-eval-string (get er :interp) body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc body-result :code 0)) + ((= code 2) body-result) + ((= code 1) body-result) + (else + (let + ((step-result (tcl-eval-string (assoc body-result :code 0) step))) + (tcl-for-loop + (assoc step-result :code 0) + cond-str + step + body)))))))))) + +(define + tcl-cmd-for + (fn + (interp args) + (let + ((init-body (first args)) + (cond-str (nth args 1)) + (step (nth args 2)) + (body (nth args 3))) + (let + ((init-result (tcl-eval-string interp init-body))) + (tcl-for-loop init-result cond-str step body))))) + +(define + tcl-foreach-loop + (fn + (interp var-name items body) + (if + (= 0 (len items)) + interp + (let + ((body-result (tcl-eval-string (tcl-var-set interp var-name (first items)) body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc body-result :code 0)) + ((= code 2) body-result) + ((= code 1) body-result) + (else + (tcl-foreach-loop + (assoc body-result :code 0) + var-name + (rest items) + body)))))))) + +(define + tcl-cmd-foreach + (fn + (interp args) + (let + ((var-name (first args)) + (list-str (nth args 1)) + (body (nth args 2))) + (tcl-foreach-loop interp var-name (tcl-list-split list-str) body)))) + +(define + tcl-cmd-switch + (fn + (interp args) + (let + ((str-val (first args)) (body (nth args 1))) + (let + ((pairs (tcl-list-split body))) + (define + try-pairs + (fn + (ps) + (if + (= 0 (len ps)) + interp + (let + ((pat (first ps)) (bdy (nth ps 1))) + (if + (or (equal? pat str-val) (equal? pat "default")) + (if + (equal? bdy "-") + (try-pairs (rest (rest ps))) + (tcl-eval-string interp bdy)) + (try-pairs (rest (rest ps)))))))) + (try-pairs pairs))))) + +(define + tcl-cmd-expr + (fn + (interp args) + (let + ((s (join " " args))) + (let + ((er (tcl-expr-eval interp s))) + (assoc (get er :interp) :result (get er :result)))))) + +(define tcl-cmd-gets (fn (interp args) (assoc interp :result ""))) + +(define + tcl-cmd-subst + (fn (interp args) (assoc interp :result (last args)))) + +; Format helper: repeat char ch n times, building pad string +(define + tcl-fmt-make-pad + (fn + (ch cnt acc) + (if (<= cnt 0) acc (tcl-fmt-make-pad ch (- cnt 1) (str ch acc))))) + +; Format helper: pad string s to width w +(define + tcl-fmt-pad + (fn + (s width zero-pad? left-align?) + (let + ((w (if (equal? width "") 0 (parse-int width)))) + (let + ((pad-len (- w (string-length s)))) + (if + (<= pad-len 0) + s + (let + ((pad (tcl-fmt-make-pad (if zero-pad? "0" " ") pad-len ""))) + (if left-align? (str s pad) (str pad s)))))))) + +; Format helper: scan flag characters +(define + tcl-fmt-scan-flags + (fn + (chars j flags) + (if + (>= j (len chars)) + {:j j :flags flags} + (let + ((ch (nth chars j))) + (if + (contains? (list "-" "0" "+" " " "#") ch) + (tcl-fmt-scan-flags chars (+ j 1) (str flags ch)) + {:j j :flags flags}))))) + +; Format helper: scan digits for width/precision +(define + tcl-fmt-scan-num + (fn + (chars j acc-n) + (if + (>= j (len chars)) + {:j j :num acc-n} + (let + ((ch (nth chars j))) + (if + (tcl-expr-digit? ch) + (tcl-fmt-scan-num chars (+ j 1) (str acc-n ch)) + {:j j :num acc-n}))))) + +; Main format apply: process chars, produce output string +(define + tcl-fmt-apply + (fn + (chars n-len fmt-args i arg-idx acc) + (if + (>= i n-len) + acc + (let + ((c (nth chars i))) + (if + (not (equal? c "%")) + (tcl-fmt-apply chars n-len fmt-args (+ i 1) arg-idx (str acc c)) + ; parse specifier + (let + ((i2 (+ i 1))) + (if + (>= i2 n-len) + (str acc "%") + (let + ((c2 (nth chars i2))) + (if + (equal? c2 "%") + (tcl-fmt-apply chars n-len fmt-args (+ i2 1) arg-idx (str acc "%")) + ; scan flags + (let + ((fr (tcl-fmt-scan-flags chars i2 ""))) + (let + ((flags (get fr :flags)) (j (get fr :j))) + (let + ((wr (tcl-fmt-scan-num chars j ""))) + (let + ((width (get wr :num)) (j2 (get wr :j))) + ; skip precision .N + (let + ((j3 + (if + (and (< j2 n-len) (equal? (nth chars j2) ".")) + (let ((pr (tcl-fmt-scan-num chars (+ j2 1) ""))) (get pr :j)) + j2))) + (if + (>= j3 n-len) + (str acc "?") + (let + ((type-char (nth chars j3)) + (cur-arg (if (< arg-idx (len fmt-args)) (nth fmt-args arg-idx) ""))) + (let + ((zero-pad? (contains? (split flags "") "0")) + (left-align? (contains? (split flags "") "-"))) + (let + ((formatted + (cond + ((or (equal? type-char "d") (equal? type-char "i")) + (tcl-fmt-pad (str (parse-int cur-arg)) width zero-pad? left-align?)) + ((equal? type-char "s") + (tcl-fmt-pad cur-arg width false left-align?)) + ((or (equal? type-char "f") (equal? type-char "g") (equal? type-char "e")) + cur-arg) + ((equal? type-char "x") + (str (parse-int cur-arg))) + ((equal? type-char "o") + (str (parse-int cur-arg))) + ((equal? type-char "c") + cur-arg) + (else (str "%" type-char))))) + (tcl-fmt-apply chars n-len fmt-args (+ j3 1) (+ arg-idx 1) (str acc formatted)))))))))))))))))))) + +(define + tcl-cmd-format + (fn + (interp args) + (if + (= 0 (len args)) + (error "format: wrong # args") + (let + ((fmt-str (first args)) (fmt-args (rest args))) + (let + ((chars (split fmt-str "")) + (n-len (string-length fmt-str))) + (assoc interp :result (tcl-fmt-apply chars n-len fmt-args 0 0 ""))))))) + +(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0"))) + +; --- string command helpers --- + +; glob match: pattern chars list, string chars list +(define + tcl-glob-match + (fn + (pat-chars str-chars) + (cond + ; both exhausted → success + ((and (= 0 (len pat-chars)) (= 0 (len str-chars))) true) + ; pattern exhausted but string remains → fail + ((= 0 (len pat-chars)) false) + ; leading * in pattern + ((equal? (first pat-chars) "*") + (let + ((rest-pat (rest pat-chars))) + ; * can match zero chars (skip *) or consume one str char and retry + (if + (tcl-glob-match rest-pat str-chars) + true + (if + (= 0 (len str-chars)) + false + (tcl-glob-match pat-chars (rest str-chars)))))) + ; string exhausted but pattern non-empty (and not *) → fail + ((= 0 (len str-chars)) false) + ; ? matches any single char + ((equal? (first pat-chars) "?") + (tcl-glob-match (rest pat-chars) (rest str-chars))) + ; literal match + ((equal? (first pat-chars) (first str-chars)) + (tcl-glob-match (rest pat-chars) (rest str-chars))) + ; literal mismatch + (else false)))) + +; toupper/tolower via char tables +(define + tcl-upcase-char + (fn + (c) + (cond + ((equal? c "a") "A") ((equal? c "b") "B") ((equal? c "c") "C") + ((equal? c "d") "D") ((equal? c "e") "E") ((equal? c "f") "F") + ((equal? c "g") "G") ((equal? c "h") "H") ((equal? c "i") "I") + ((equal? c "j") "J") ((equal? c "k") "K") ((equal? c "l") "L") + ((equal? c "m") "M") ((equal? c "n") "N") ((equal? c "o") "O") + ((equal? c "p") "P") ((equal? c "q") "Q") ((equal? c "r") "R") + ((equal? c "s") "S") ((equal? c "t") "T") ((equal? c "u") "U") + ((equal? c "v") "V") ((equal? c "w") "W") ((equal? c "x") "X") + ((equal? c "y") "Y") ((equal? c "z") "Z") + (else c)))) + +(define + tcl-downcase-char + (fn + (c) + (cond + ((equal? c "A") "a") ((equal? c "B") "b") ((equal? c "C") "c") + ((equal? c "D") "d") ((equal? c "E") "e") ((equal? c "F") "f") + ((equal? c "G") "g") ((equal? c "H") "h") ((equal? c "I") "i") + ((equal? c "J") "j") ((equal? c "K") "k") ((equal? c "L") "l") + ((equal? c "M") "m") ((equal? c "N") "n") ((equal? c "O") "o") + ((equal? c "P") "p") ((equal? c "Q") "q") ((equal? c "R") "r") + ((equal? c "S") "s") ((equal? c "T") "t") ((equal? c "U") "u") + ((equal? c "V") "v") ((equal? c "W") "w") ((equal? c "X") "x") + ((equal? c "Y") "y") ((equal? c "Z") "z") + (else c)))) + +; strip chars from left +(define + tcl-trim-left-chars + (fn + (chars strip-set) + (if + (or (= 0 (len chars)) (not (contains? strip-set (first chars)))) + chars + (tcl-trim-left-chars (rest chars) strip-set)))) + +; strip chars from right (reverse, trim left, reverse) +(define + tcl-reverse-list + (fn (lst) (reduce (fn (acc x) (append (list x) acc)) (list) lst))) + +(define + tcl-trim-right-chars + (fn + (chars strip-set) + (tcl-reverse-list (tcl-trim-left-chars (tcl-reverse-list chars) strip-set)))) + +; default whitespace set +(define + tcl-ws-set + (list " " "\t" "\n" "\r")) + +; string map: apply flat list of pairs old→new to string +(define + tcl-string-map-apply + (fn + (s pairs) + (if + (< (len pairs) 2) + s + (let + ((old (first pairs)) (new-s (nth pairs 1)) (rest-pairs (rest (rest pairs)))) + (let + ((old-chars (split old "")) + (old-len (string-length old))) + (let + ((go + (fn + (i acc) + (if + (>= i (string-length s)) + acc + (let + ((chunk (if (> (+ i old-len) (string-length s)) "" (substring s i (+ i old-len))))) + (if + (equal? chunk old) + (go (+ i old-len) (str acc new-s)) + (go (+ i 1) (str acc (substring s i (+ i 1)))))))))) + (tcl-string-map-apply (go 0 "") rest-pairs))))))) + +; string first: index of needle in haystack starting at start +(define + tcl-string-first + (fn + (needle haystack start) + (let + ((nl (string-length needle)) (hl (string-length haystack))) + (if + (= nl 0) + (str start) + (let + ((go + (fn + (i) + (if + (> (+ i nl) hl) + "-1" + (if + (equal? (substring haystack i (+ i nl)) needle) + (str i) + (go (+ i 1))))))) + (go start)))))) + +; string last: last index of needle in haystack up to end +(define + tcl-string-last + (fn + (needle haystack end-idx) + (let + ((nl (string-length needle)) (hl (string-length haystack))) + (let + ((bound (if (< end-idx 0) (- hl 1) (if (>= end-idx hl) (- hl 1) end-idx)))) + (if + (= nl 0) + (str bound) + (let + ((go + (fn + (i) + (if + (< i 0) + "-1" + (if + (and + (<= (+ i nl) hl) + (equal? (substring haystack i (+ i nl)) needle)) + (str i) + (go (- i 1))))))) + (go (- (+ bound 1) nl)))))))) + +; string is: check string class +(define + tcl-string-is + (fn + (class s) + (let + ((chars (split s "")) + (n (string-length s))) + (cond + ((equal? class "integer") + (if + (= n 0) + "0" + (let + ((start (if (or (equal? (first chars) "-") (equal? (first chars) "+")) 1 0))) + (if + (= start n) + "0" + (if + (reduce + (fn (ok c) (and ok (tcl-expr-digit? c))) + true + (slice chars start n)) + "1" + "0"))))) + ((equal? class "double") + (if + (= n 0) + "0" + (if + (reduce + (fn (ok c) (and ok (or (tcl-expr-digit? c) (equal? c ".") (equal? c "-") (equal? c "+") (equal? c "e") (equal? c "E")))) + true + chars) + "1" + "0"))) + ((equal? class "alpha") + (if + (= n 0) + "0" + (if + (reduce (fn (ok c) (and ok (tcl-expr-alpha? c))) true chars) + "1" + "0"))) + ((equal? class "alnum") + (if + (= n 0) + "0" + (if + (reduce (fn (ok c) (and ok (or (tcl-expr-alpha? c) (tcl-expr-digit? c)))) true chars) + "1" + "0"))) + ((equal? class "digit") + (if + (= n 0) + "0" + (if + (reduce (fn (ok c) (and ok (tcl-expr-digit? c))) true chars) + "1" + "0"))) + ((equal? class "space") + (if + (= n 0) + "1" + (if + (reduce (fn (ok c) (and ok (tcl-expr-ws? c))) true chars) + "1" + "0"))) + ((equal? class "upper") + (if + (= n 0) + "0" + (if + (reduce + (fn + (ok c) + (and + ok + (contains? + (list "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" + "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z") + c))) + true + chars) + "1" + "0"))) + ((equal? class "lower") + (if + (= n 0) + "0" + (if + (reduce + (fn + (ok c) + (and + ok + (contains? + (list "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" + "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z") + c))) + true + chars) + "1" + "0"))) + ((equal? class "boolean") + (if + (or (equal? s "0") (equal? s "1") + (equal? s "true") (equal? s "false") + (equal? s "yes") (equal? s "no") + (equal? s "on") (equal? s "off")) + "1" + "0")) + (else "0"))))) + +(define + tcl-cmd-string + (fn + (interp args) + (if + (= 0 (len args)) + (error "string: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ; string length s + ((equal? sub "length") + (assoc interp :result (str (string-length (first rest-args))))) + ; string index s i + ((equal? sub "index") + (let + ((s (first rest-args)) (idx (parse-int (nth rest-args 1)))) + (let + ((n (string-length s))) + (if + (or (< idx 0) (>= idx n)) + (assoc interp :result "") + (assoc interp :result (substring s idx (+ idx 1))))))) + ; string range s first last + ((equal? sub "range") + (let + ((s (first rest-args)) + (fi (parse-int (nth rest-args 1))) + (li (parse-int (nth rest-args 2)))) + (let + ((n (string-length s))) + (let + ((f (if (< fi 0) 0 fi)) + (l (if (>= li n) (- n 1) li))) + (if + (> f l) + (assoc interp :result "") + (assoc interp :result (substring s f (+ l 1)))))))) + ; string compare s1 s2 + ((equal? sub "compare") + (let + ((s1 (first rest-args)) (s2 (nth rest-args 1))) + (assoc + interp + :result + (cond + ((equal? s1 s2) "0") + ((< s1 s2) "-1") + (else "1"))))) + ; string match pattern s + ((equal? sub "match") + (let + ((pat (first rest-args)) (s (nth rest-args 1))) + (assoc + interp + :result + (if (tcl-glob-match (split pat "") (split s "")) "1" "0")))) + ; string toupper s + ((equal? sub "toupper") + (let + ((s (first rest-args))) + (assoc + interp + :result + (join "" (map tcl-upcase-char (split s "")))))) + ; string tolower s + ((equal? sub "tolower") + (let + ((s (first rest-args))) + (assoc + interp + :result + (join "" (map tcl-downcase-char (split s "")))))) + ; string trim s ?chars? + ((equal? sub "trim") + (let + ((s (first rest-args)) + (strip-set (if (> (len rest-args) 1) (split (nth rest-args 1) "") tcl-ws-set))) + (let + ((chars (split s ""))) + (assoc + interp + :result + (join "" (tcl-trim-right-chars (tcl-trim-left-chars chars strip-set) strip-set)))))) + ; string trimleft s ?chars? + ((equal? sub "trimleft") + (let + ((s (first rest-args)) + (strip-set (if (> (len rest-args) 1) (split (nth rest-args 1) "") tcl-ws-set))) + (assoc + interp + :result + (join "" (tcl-trim-left-chars (split s "") strip-set))))) + ; string trimright s ?chars? + ((equal? sub "trimright") + (let + ((s (first rest-args)) + (strip-set (if (> (len rest-args) 1) (split (nth rest-args 1) "") tcl-ws-set))) + (assoc + interp + :result + (join "" (tcl-trim-right-chars (split s "") strip-set))))) + ; string map mapping s + ((equal? sub "map") + (let + ((mapping (first rest-args)) (s (nth rest-args 1))) + (assoc + interp + :result + (tcl-string-map-apply s (tcl-list-split mapping))))) + ; string repeat s n + ((equal? sub "repeat") + (let + ((s (first rest-args)) (n (parse-int (nth rest-args 1)))) + (assoc + interp + :result + (let + ((go (fn (i acc) (if (>= i n) acc (go (+ i 1) (str acc s)))))) + (go 0 ""))))) + ; string first needle haystack ?start? + ((equal? sub "first") + (let + ((needle (first rest-args)) + (haystack (nth rest-args 1)) + (start (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) 0))) + (assoc interp :result (tcl-string-first needle haystack start)))) + ; string last needle haystack ?end? + ((equal? sub "last") + (let + ((needle (first rest-args)) + (haystack (nth rest-args 1)) + (end-idx (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) -1))) + (assoc interp :result (tcl-string-last needle haystack end-idx)))) + ; string is class s + ((equal? sub "is") + (let + ((class (first rest-args)) (s (nth rest-args 1))) + (assoc interp :result (tcl-string-is class s)))) + ; string cat ?args...? + ((equal? sub "cat") + (assoc interp :result (join "" rest-args))) + (else (error (str "string: unknown subcommand: " sub)))))))) + + +; --- list command helpers --- + +; Quote a single list element: add braces if it contains a space or is empty +(define + tcl-list-quote-elem + (fn + (elem) + (if + (or (equal? elem "") (contains? (split elem "") " ")) + (str "{" elem "}") + elem))) + +; Build a Tcl list string from an SX list of string elements +(define + tcl-list-build + (fn (elems) (join " " (map tcl-list-quote-elem elems)))) + +; Resolve "end" index to numeric value given list length +(define + tcl-end-index + (fn + (s n) + (if (equal? s "end") (- n 1) (parse-int s)))) + +; Insertion sort for list commands (comparator: fn(a b) -> true if a before b) +(define + tcl-insert-sorted + (fn + (lst before? x) + (if + (= 0 (len lst)) + (list x) + (if + (before? x (first lst)) + (append (list x) lst) + (append (list (first lst)) (tcl-insert-sorted (rest lst) before? x)))))) + +(define + tcl-insertion-sort + (fn + (lst before?) + (reduce + (fn (sorted x) (tcl-insert-sorted sorted before? x)) + (list) + lst))) + +; --- list commands --- + +(define + tcl-cmd-list + (fn + (interp args) + (assoc interp :result (tcl-list-build args)))) + +(define + tcl-cmd-lindex + (fn + (interp args) + (let + ((elems (tcl-list-split (first args))) + (idx (tcl-end-index (nth args 1) (len (tcl-list-split (first args)))))) + (assoc + interp + :result + (if + (or (< idx 0) (>= idx (len elems))) + "" + (nth elems idx)))))) + +(define + tcl-cmd-lrange + (fn + (interp args) + (let + ((elems (tcl-list-split (first args)))) + (let + ((n (len elems)) + (fi (tcl-end-index (nth args 1) (len elems))) + (li (tcl-end-index (nth args 2) (len elems)))) + (let + ((f (if (< fi 0) 0 fi)) + (l (if (>= li n) (- n 1) li))) + (assoc + interp + :result + (if + (> f l) + "" + (tcl-list-build (slice elems f (+ l 1)))))))))) + +(define + tcl-cmd-llength + (fn + (interp args) + (assoc interp :result (str (len (tcl-list-split (first args))))))) + +(define + tcl-cmd-lreverse + (fn + (interp args) + (assoc + interp + :result + (tcl-list-build (tcl-reverse-list (tcl-list-split (first args))))))) + +(define + tcl-cmd-lsearch + (fn + (interp args) + (let + ((exact? (and (> (len args) 2) (equal? (first args) "-exact"))) + (list-str (if (and (> (len args) 2) (equal? (first args) "-exact")) (nth args 1) (first args))) + (value (if (and (> (len args) 2) (equal? (first args) "-exact")) (nth args 2) (nth args 1)))) + (let + ((elems (tcl-list-split list-str))) + (define + find-idx + (fn + (lst i) + (if + (= 0 (len lst)) + "-1" + (if + (equal? (first lst) value) + (str i) + (find-idx (rest lst) (+ i 1)))))) + (assoc interp :result (find-idx elems 0)))))) + +(define + tcl-cmd-lsort + (fn + (interp args) + (define + parse-opts + (fn + (remaining) + (if + (or (= 0 (len remaining)) (not (equal? (substring (first remaining) 0 1) "-"))) + {:mode "ascii" :decreasing false :list-str (first remaining)} + (if + (equal? (first remaining) "-integer") + (let ((r (parse-opts (rest remaining)))) (assoc r :mode "integer")) + (if + (equal? (first remaining) "-real") + (let ((r (parse-opts (rest remaining)))) (assoc r :mode "real")) + (if + (equal? (first remaining) "-dictionary") + (let ((r (parse-opts (rest remaining)))) (assoc r :mode "dictionary")) + (if + (equal? (first remaining) "-decreasing") + (let ((r (parse-opts (rest remaining)))) (assoc r :decreasing true)) + {:mode "ascii" :decreasing false :list-str (first remaining)}))))))) + (let + ((opts (parse-opts args))) + (let + ((elems (tcl-list-split (get opts :list-str))) + (mode (get opts :mode)) + (decreasing? (get opts :decreasing))) + (let + ((before? + (if + (equal? mode "integer") + (fn (a b) (< (parse-int a) (parse-int b))) + (fn (a b) (< a b))))) + (let + ((sorted (tcl-insertion-sort elems before?))) + (assoc + interp + :result + (tcl-list-build + (if decreasing? (tcl-reverse-list sorted) sorted))))))))) + +(define + tcl-cmd-lreplace + (fn + (interp args) + (let + ((elems (tcl-list-split (first args)))) + (let + ((n (len elems)) + (fi (tcl-end-index (nth args 1) n)) + (li (tcl-end-index (nth args 2) n)) + (new-elems (slice args 3 (len args)))) + (let + ((f (if (< fi 0) 0 fi)) + (l (if (>= li (- n 1)) (- n 1) li))) + (let + ((before (slice elems 0 f)) + (after (slice elems (+ l 1) n))) + (assoc + interp + :result + (tcl-list-build + (reduce + (fn (acc x) (append acc (list x))) + (reduce (fn (acc x) (append acc (list x))) before new-elems) + after))))))))) + +(define + tcl-cmd-linsert + (fn + (interp args) + (let + ((elems (tcl-list-split (first args)))) + (let + ((n (len elems)) + (raw-idx (nth args 1)) + (new-elems (slice args 2 (len args)))) + (let + ((idx + (if + (equal? raw-idx "end") + n + (let + ((i (parse-int raw-idx))) + (if (< i 0) 0 (if (> i n) n i)))))) + (let + ((before (slice elems 0 idx)) + (after (slice elems idx n))) + (assoc + interp + :result + (tcl-list-build + (reduce + (fn (acc x) (append acc (list x))) + (reduce (fn (acc x) (append acc (list x))) before new-elems) + after))))))))) + +(define + tcl-cmd-concat + (fn + (interp args) + (let + ((all-elems + (reduce + (fn (acc s) (append acc (tcl-list-split s))) + (list) + args))) + (assoc interp :result (tcl-list-build all-elems))))) + +(define + tcl-cmd-split + (fn + (interp args) + (let + ((s (first args)) + (sep (if (> (len args) 1) (nth args 1) " "))) + (let + ((parts + (if + (equal? sep " ") + (filter (fn (x) (not (equal? x ""))) (split s " ")) + (split s sep)))) + (assoc interp :result (tcl-list-build parts)))))) + +(define + tcl-cmd-join + (fn + (interp args) + (let + ((elems (tcl-list-split (first args))) + (sep (if (> (len args) 1) (nth args 1) " "))) + (assoc interp :result (join sep elems))))) + +; --- dict command helpers --- + +; Parse flat dict string into SX list of [key val] pairs +(define + tcl-dict-to-pairs + (fn + (dict-str) + (let + ((flat (tcl-list-split dict-str))) + (let + ((go + (fn + (lst acc) + (if + (= 0 (len lst)) + acc + (if + (= 1 (len lst)) + (error "dict: malformed dict (odd number of elements)") + (go (rest (rest lst)) (append acc (list (list (first lst) (nth lst 1)))))))))) + (go flat (list)))))) + +; Build flat dict string from SX list of [key val] pairs +(define + tcl-dict-from-pairs + (fn + (pairs) + (tcl-list-build + (reduce + (fn (acc pair) (append (append acc (list (first pair))) (list (nth pair 1)))) + (list) + pairs)))) + +; Get value for key from flat dict string; returns nil if missing +(define + tcl-dict-get + (fn + (dict-str key) + (let + ((flat (tcl-list-split dict-str))) + (let + ((go + (fn + (lst) + (if + (< (len lst) 2) + nil + (if + (equal? (first lst) key) + (nth lst 1) + (go (rest (rest lst)))))))) + (go flat))))) + +; Set key=val in flat dict string; returns new flat dict string +(define + tcl-dict-set-pair + (fn + (dict-str key val) + (let + ((pairs (tcl-dict-to-pairs dict-str))) + (let + ((found? (reduce (fn (acc pair) (or acc (equal? (first pair) key))) false pairs))) + (if + found? + (tcl-dict-from-pairs (map (fn (pair) (if (equal? (first pair) key) (list key val) pair)) pairs)) + (tcl-dict-from-pairs (append pairs (list (list key val))))))))) + +; Remove key from flat dict string; returns new flat dict string +(define + tcl-dict-unset-key + (fn + (dict-str key) + (tcl-dict-from-pairs + (filter (fn (pair) (not (equal? (first pair) key))) (tcl-dict-to-pairs dict-str))))) + +; --- dict command --- + +(define + tcl-cmd-dict + (fn + (interp args) + (if + (= 0 (len args)) + (error "dict: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ; dict create ?key val …? + ((equal? sub "create") + (if + (= 1 (mod (len rest-args) 2)) + (error "dict create: wrong # args (must be even)") + (assoc interp :result (tcl-list-build rest-args)))) + ; dict get dict key + ((equal? sub "get") + (let + ((dict-str (first rest-args)) (key (nth rest-args 1))) + (let + ((val (tcl-dict-get dict-str key))) + (if + (nil? val) + (error (str "dict get: key \"" key "\" not known in dictionary")) + (assoc interp :result val))))) + ; dict set varname key val + ((equal? sub "set") + (let + ((varname (first rest-args)) + (key (nth rest-args 1)) + (val (nth rest-args 2))) + (let + ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v)))) + (let + ((new-dict (tcl-dict-set-pair cur key val))) + (assoc (tcl-var-set interp varname new-dict) :result new-dict))))) + ; dict unset varname key + ((equal? sub "unset") + (let + ((varname (first rest-args)) (key (nth rest-args 1))) + (let + ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v)))) + (let + ((new-dict (tcl-dict-unset-key cur key))) + (assoc (tcl-var-set interp varname new-dict) :result new-dict))))) + ; dict exists dict key + ((equal? sub "exists") + (let + ((dict-str (first rest-args)) (key (nth rest-args 1))) + (assoc interp :result (if (nil? (tcl-dict-get dict-str key)) "0" "1")))) + ; dict keys dict ?pattern? + ((equal? sub "keys") + (let + ((dict-str (first rest-args)) + (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil))) + (let + ((all-keys (map first (tcl-dict-to-pairs dict-str)))) + (let + ((filtered + (if + (nil? pattern) + all-keys + (filter (fn (k) (tcl-glob-match (split pattern "") (split k ""))) all-keys)))) + (assoc interp :result (tcl-list-build filtered)))))) + ; dict values dict + ((equal? sub "values") + (let + ((dict-str (first rest-args))) + (assoc interp :result (tcl-list-build (map (fn (pair) (nth pair 1)) (tcl-dict-to-pairs dict-str)))))) + ; dict size dict + ((equal? sub "size") + (let + ((dict-str (first rest-args))) + (assoc interp :result (str (len (tcl-dict-to-pairs dict-str)))))) + ; dict for {kvar vvar} dict body + ((equal? sub "for") + (let + ((var-pair-str (first rest-args)) + (dict-str (nth rest-args 1)) + (body (nth rest-args 2))) + (let + ((var-list (tcl-list-split var-pair-str))) + (let + ((kvar (first var-list)) (vvar (nth var-list 1))) + (let + ((pairs (tcl-dict-to-pairs dict-str))) + (define + dict-for-loop + (fn + (cur-interp ps) + (if + (= 0 (len ps)) + cur-interp + (let + ((pair (first ps))) + (let + ((bound (tcl-var-set (tcl-var-set cur-interp kvar (first pair)) vvar (nth pair 1)))) + (let + ((body-result (tcl-eval-string bound body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc body-result :code 0)) + ((= code 2) body-result) + ((= code 1) body-result) + (else (dict-for-loop (assoc body-result :code 0) (rest ps))))))))))) + (dict-for-loop interp pairs)))))) + ; dict update varname key var … body + ((equal? sub "update") + (let + ((varname (first rest-args))) + (let + ((n (len rest-args))) + (let + ((body (nth rest-args (- n 1))) + (kv-args (slice rest-args 1 (- n 1)))) + (let + ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v)))) + (let + ((bound-interp + (let + ((bind-pairs + (fn + (i-interp remaining) + (if + (< (len remaining) 2) + i-interp + (let + ((k (first remaining)) (var (nth remaining 1))) + (let + ((val (tcl-dict-get cur k))) + (bind-pairs + (tcl-var-set i-interp var (if (nil? val) "" val)) + (rest (rest remaining))))))))) + (bind-pairs interp kv-args)))) + (let + ((body-result (tcl-eval-string bound-interp body))) + (let + ((write-back + (fn + (i-interp remaining new-dict) + (if + (< (len remaining) 2) + (assoc (tcl-var-set i-interp varname new-dict) :result new-dict) + (let + ((k (first remaining)) (var (nth remaining 1))) + (let + ((new-val (frame-lookup (get body-result :frame) var))) + (write-back + i-interp + (rest (rest remaining)) + (if (nil? new-val) (tcl-dict-unset-key new-dict k) (tcl-dict-set-pair new-dict k new-val))))))))) + (write-back body-result kv-args cur))))))))) + ; dict merge ?dict…? + ((equal? sub "merge") + (let + ((merged + (reduce + (fn + (acc dict-str) + (reduce + (fn (a pair) (tcl-dict-set-pair a (first pair) (nth pair 1))) + acc + (tcl-dict-to-pairs dict-str))) + "" + rest-args))) + (assoc interp :result merged))) + ; dict incr varname key ?increment? + ((equal? sub "incr") + (let + ((varname (first rest-args)) + (key (nth rest-args 1)) + (delta (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) 1))) + (let + ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v)))) + (let + ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "0" v)))) + (let + ((new-val (str (+ (parse-int old-val) delta)))) + (let + ((new-dict (tcl-dict-set-pair cur key new-val))) + (assoc (tcl-var-set interp varname new-dict) :result new-dict))))))) + ; dict append varname key ?string…? + ((equal? sub "append") + (let + ((varname (first rest-args)) + (key (nth rest-args 1)) + (suffix (join "" (slice rest-args 2 (len rest-args))))) + (let + ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v)))) + (let + ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "" v)))) + (let + ((new-val (str old-val suffix))) + (let + ((new-dict (tcl-dict-set-pair cur key new-val))) + (assoc (tcl-var-set interp varname new-dict) :result new-dict))))))) + (else (error (str "dict: unknown subcommand \"" sub "\"")))))))) + +; --- namespace helpers --- + +; Normalize a namespace name to fully-qualified form: ::ns +; Accepts: "ns", "::ns", "ns::", "::ns::", "" → "::" +(define + tcl-ns-normalize + (fn + (ns) + (if + (or (equal? ns "") (equal? ns "::")) + "::" + (let + ; strip trailing :: + ((stripped + (if + (equal? (substring ns (- (string-length ns) 2) (string-length ns)) "::") + (substring ns 0 (- (string-length ns) 2)) + ns))) + ; ensure leading :: + (if + (equal? (substring stripped 0 2) "::") + stripped + (str "::" stripped)))))) + +; Test whether string s starts with prefix p +(define + tcl-starts-with? + (fn + (s p) + (let + ((pl (string-length p)) (sl (string-length s))) + (if (> pl sl) false (equal? (substring s 0 pl) p))))) + +; Qualify a proc name relative to current-ns. +; If name already starts with :: return as-is. +; Otherwise prepend current-ns:: (or :: if current-ns is ::). +(define + tcl-qualify-name + (fn + (name current-ns) + (if + (tcl-starts-with? name "::") + name + (if + (equal? current-ns "::") + (str "::" name) + (str current-ns "::" name))))) + +; Look up a command by name with namespace resolution. +; Try: exact name → ::current-ns::name → ::name +(define + tcl-proc-lookup + (fn + (interp name) + (let + ((procs (get interp :procs)) + (current-ns (get interp :current-ns))) + (let + ((exact (get procs name))) + (if (not (nil? exact)) + {:name name :def exact} + (let + ((qualified (tcl-qualify-name name current-ns))) + (let + ((qual-def (get procs qualified))) + (if (not (nil? qual-def)) + {:name qualified :def qual-def} + (let + ((global-name (str "::" name))) + (let + ((global-def (get procs global-name))) + (if (not (nil? global-def)) + {:name global-name :def global-def} + nil))))))))))) + +; Get all proc names in a namespace (returns list of fully-qualified names) +(define + tcl-ns-procs + (fn + (procs ns) + (let + ((prefix (if (equal? ns "::") "::" (str ns "::")))) + (filter + (fn (k) + (if (equal? ns "::") + ; global ns: keys that start with :: but have no further :: + (and + (tcl-starts-with? k "::") + (not (tcl-starts-with? (substring k 2 (string-length k)) "::"))) + (tcl-starts-with? k prefix))) + (keys procs))))) + +; Check if a namespace exists (has any procs) +(define + tcl-ns-exists? + (fn + (procs ns) + (> (len (tcl-ns-procs procs ns)) 0))) + +; Extract last component from qualified name ::ns::foo → foo +(define + tcl-ns-tail + (fn + (name) + (let + ((parts (filter (fn (p) (not (equal? p ""))) (split name ":")))) + (if (= 0 (len parts)) name (nth parts (- (len parts) 1)))))) + +; --- proc command --- + +(define + tcl-cmd-proc + (fn + (interp args) + (let + ((raw-name (first args)) + (arg-spec (nth args 1)) + (body (nth args 2))) + (let + ; qualify name based on current namespace + ((name (tcl-qualify-name raw-name (get interp :current-ns)))) + (let + ; extract the namespace of the proc for runtime context + ((proc-ns + (let + ((parts (filter (fn (p) (not (equal? p ""))) (split name ":")))) + ; proc-ns is all but last component, re-joined as ::ns or :: + (if (<= (len parts) 1) + "::" + (str "::" (join "::" (take-n parts (- (len parts) 1)))))))) + (assoc interp + :procs (assoc (get interp :procs) name {:args arg-spec :body body :ns proc-ns}) + :result "")))))) + +; --- parse uplevel/upvar level argument --- +; Returns absolute level number. +; current-level = len(frame-stack) +(define + tcl-parse-level + (fn + (level-str current-level) + (if + (equal? (substring level-str 0 1) "#") + ; absolute: #N + (parse-int (substring level-str 1 (string-length level-str))) + ; relative: N levels up from current + (- current-level (parse-int level-str))))) + +; --- uplevel command --- + +(define + tcl-cmd-uplevel + (fn + (interp args) + (let + ((current-level (len (get interp :frame-stack)))) + (let + ; check if first arg is a level specifier + ((has-level + (and + (> (len args) 1) + (or + (equal? (substring (first args) 0 1) "#") + (let + ((fst (first args))) + (and + (> (string-length fst) 0) + (tcl-expr-digit? (substring fst 0 1))))))) + (level-str (if (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (and (> (string-length (first args)) 0) (tcl-expr-digit? (substring (first args) 0 1))))) (first args) "1")) + (script (if (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (and (> (string-length (first args)) 0) (tcl-expr-digit? (substring (first args) 0 1))))) (nth args 1) (first args)))) + (let + ((target-level (tcl-parse-level level-str current-level))) + (let + ((full-stack (tcl-full-stack interp))) + (let + ((target-frame (tcl-frame-nth full-stack target-level))) + (let + ((temp-interp + (assoc interp + :frame target-frame + :frame-stack (take-n (get interp :frame-stack) target-level) + :output "")) + (saved-output (get interp :output))) + (let + ((result-interp (tcl-eval-string temp-interp script))) + (let + ((updated-target (get result-interp :frame)) + (new-output (get result-interp :output))) + (let + ((new-full-stack (replace-at full-stack target-level updated-target))) + (let + ((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1))) + (new-current (nth new-full-stack (- (len new-full-stack) 1)))) + (assoc interp + :frame new-current + :frame-stack new-frame-stack + :result (get result-interp :result) + :output (str saved-output new-output) + :code (get result-interp :code)))))))))))))) + +; --- upvar command --- + +(define + tcl-cmd-upvar + (fn + (interp args) + (let + ((current-level (len (get interp :frame-stack)))) + (let + ; check if first arg is a level specifier + ((has-level + (and + (> (len args) 2) + (or + (equal? (substring (first args) 0 1) "#") + (tcl-expr-digit? (substring (first args) 0 1))))) + (level-str (if (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))) (first args) "1")) + (pair-args (if (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))) (rest args) args))) + (let + ((target-level (tcl-parse-level level-str current-level))) + (let + ((bind-pairs + (fn + (i-interp remaining) + (if + (< (len remaining) 2) + i-interp + (let + ((remote-name (first remaining)) + (local-name (nth remaining 1))) + (let + ((alias {:upvar-level target-level :upvar-name remote-name})) + (bind-pairs + (assoc i-interp :frame (frame-set-top (get i-interp :frame) local-name alias)) + (rest (rest remaining))))))))) + (assoc (bind-pairs interp pair-args) :result ""))))))) + +; --- global command --- + +(define + tcl-cmd-global + (fn + (interp args) + (reduce + (fn + (i name) + (tcl-cmd-upvar i (list "#0" name name))) + interp + args))) + +; --- variable command --- + +(define + tcl-cmd-variable + (fn + (interp args) + (let + ((go + (fn + (i remaining) + (if + (= 0 (len remaining)) + i + (let + ((name (first remaining)) + (rest-rem (rest remaining))) + (let + ((linked (tcl-cmd-upvar i (list "#0" name name)))) + (if + (and (> (len rest-rem) 0) (not (equal? (substring (first rest-rem) 0 1) "-"))) + (let + ((val (first rest-rem))) + (go (assoc (tcl-var-set linked name val) :result "") (rest rest-rem))) + (go linked rest-rem)))))))) + (go interp args)))) + +; --- namespace command --- + +; namespace ensemble dispatch fn for a given ns and map +(define + tcl-make-ensemble + (fn + (procs ns map-dict) + (fn + (interp args) + (if + (= 0 (len args)) + (error (str "wrong # args: ensemble \"" ns "\" requires subcommand")) + (let + ((subcmd (first args)) (rest-args (rest args))) + (let + ((target-name (tcl-dict-get map-dict subcmd))) + (if (not (nil? target-name)) + ; dispatch via mapped name + (let + ((proc-entry (tcl-proc-lookup interp target-name))) + (if (nil? proc-entry) + (error (str "ensemble: command \"" target-name "\" not found")) + (tcl-call-proc interp (get proc-entry :name) (get proc-entry :def) rest-args))) + (error (str "unknown or ambiguous subcommand \"" subcmd "\": must be one of " (join ", " (map first (tcl-dict-to-pairs map-dict)))))))))))) + +(define + tcl-cmd-namespace + (fn + (interp args) + (if + (= 0 (len args)) + (error "namespace: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ; namespace eval ns body + ((equal? sub "eval") + (let + ((ns-raw (if (> (len rest-args) 0) (first rest-args) "")) + (body (if (> (len rest-args) 1) (nth rest-args 1) ""))) + (let + ; if ns-raw is relative (no leading ::), resolve relative to current-ns + ((ns + (let + ((normalized (tcl-ns-normalize ns-raw)) + (current-ns (get interp :current-ns))) + ; tcl-ns-normalize always adds :: prefix, so ::name is absolute + ; check if the original had leading :: + (if + (tcl-starts-with? ns-raw "::") + normalized + ; relative: if current is ::, just use ::name; else ::current::name + (if + (equal? current-ns "::") + normalized + (str current-ns "::" (tcl-ns-tail normalized)))))) + (saved-ns (get interp :current-ns))) + (let + ((ns-interp (assoc interp :current-ns ns))) + (let + ((result-interp (tcl-eval-string ns-interp body))) + ; restore current-ns after eval + (assoc result-interp :current-ns saved-ns)))))) + ; namespace current + ((equal? sub "current") + (assoc interp :result (get interp :current-ns))) + ; namespace which -command name + ((equal? sub "which") + (let + ((name (if (and (> (len rest-args) 0) (equal? (first rest-args) "-command")) + (if (> (len rest-args) 1) (nth rest-args 1) "") + (if (> (len rest-args) 0) (first rest-args) "")))) + (let + ((entry (tcl-proc-lookup interp name))) + (if (nil? entry) + (assoc interp :result "") + (assoc interp :result (get entry :name)))))) + ; namespace exists ns + ((equal? sub "exists") + (let + ((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) "")))) + (assoc interp :result (if (tcl-ns-exists? (get interp :procs) ns) "1" "0")))) + ; namespace delete ns + ((equal? sub "delete") + (let + ((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) "")))) + (let + ((prefix (if (equal? ns "::") "::" (str ns "::")))) + (let + ((remaining-procs + (reduce + (fn (acc k) (if (tcl-starts-with? k prefix) acc (assoc acc k (get (get interp :procs) k)))) + {} + (keys (get interp :procs))))) + (assoc interp :procs remaining-procs :result ""))))) + ; namespace export pattern — stub + ((equal? sub "export") + (assoc interp :result "")) + ; namespace import ns::name + ((equal? sub "import") + (let + ((target-name (if (> (len rest-args) 0) (first rest-args) ""))) + (let + ((tail (tcl-ns-tail target-name)) + (entry (tcl-proc-lookup interp target-name))) + (if (nil? entry) + (error (str "namespace import: \"" target-name "\" not found")) + (let + ((local-name (tcl-qualify-name tail (get interp :current-ns)))) + (assoc interp + :procs (assoc (get interp :procs) local-name (get entry :def)) + :result "")))))) + ; namespace forget name — remove import alias + ((equal? sub "forget") + (let + ((name (if (> (len rest-args) 0) (first rest-args) ""))) + (let + ((qualified (tcl-qualify-name name (get interp :current-ns)))) + (let + ((new-procs (reduce + (fn (acc k) (if (equal? k qualified) acc (assoc acc k (get (get interp :procs) k)))) + {} + (keys (get interp :procs))))) + (assoc interp :procs new-procs :result ""))))) + ; namespace path ?nslist? — stub + ((equal? sub "path") + (assoc interp :result "")) + ; namespace ensemble create ?-map dict? + ((equal? sub "ensemble") + (if (and (> (len rest-args) 0) (equal? (first rest-args) "create")) + (let + ((ens-args (rest rest-args)) + (current-ns (get interp :current-ns))) + (let + ; parse optional -map {subcmd cmd ...} + ((map-str + (let + ((go + (fn + (remaining) + (if + (< (len remaining) 2) + nil + (if (equal? (first remaining) "-map") + (nth remaining 1) + (go (rest remaining))))))) + (go ens-args)))) + (let + ; build dispatch map + ((dispatch-map + (if (nil? map-str) + ; auto-map: all procs in this namespace → tail name + (let + ((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns))) + (reduce + (fn (acc qname) + (let + ((tail (tcl-ns-tail qname))) + (tcl-dict-set-pair acc tail qname))) + "" + ns-proc-names)) + map-str))) + ; ensemble command name = tail of current-ns + (let + ((ens-name (tcl-ns-tail current-ns)) + (ens-fn (tcl-make-ensemble (get interp :procs) current-ns dispatch-map))) + (assoc interp + :commands (assoc (get interp :commands) ens-name ens-fn) + :result ""))))) + (error "namespace ensemble: unknown subcommand"))) + (else (error (str "namespace: unknown subcommand \"" sub "\"")))))))) + +; --- info command --- + +(define + tcl-cmd-info + (fn + (interp args) + (if + (= 0 (len args)) + (error "info: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ; info level + ((equal? sub "level") + (assoc interp :result (str (len (get interp :frame-stack))))) + ; info vars / info locals + ((or (equal? sub "vars") (equal? sub "locals")) + (let + ((frame-locals (get (get interp :frame) :locals))) + (assoc interp :result + (tcl-list-build + (filter + (fn (k) (not (upvar-alias? (get frame-locals k)))) + (keys frame-locals)))))) + ; info globals + ((equal? sub "globals") + (let + ((global-frame + (if + (= 0 (len (get interp :frame-stack))) + (get interp :frame) + (first (get interp :frame-stack))))) + (let + ((global-locals (get global-frame :locals))) + (assoc interp :result + (tcl-list-build + (filter + (fn (k) (not (upvar-alias? (get global-locals k)))) + (keys global-locals))))))) + ; info commands + ((equal? sub "commands") + (assoc interp :result (tcl-list-build (keys (get interp :commands))))) + ; info procs — return unqualified names of procs in current namespace + ((equal? sub "procs") + (let + ((current-ns (get interp :current-ns))) + (let + ((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns))) + (assoc interp :result (tcl-list-build (map tcl-ns-tail ns-proc-names)))))) + ; info args procname + ((equal? sub "args") + (let + ((pname (first rest-args))) + (let + ((entry (tcl-proc-lookup interp pname))) + (if + (nil? entry) + (error (str "info args: \"" pname "\" isn't a procedure")) + (assoc interp :result (get (get entry :def) :args)))))) + ; info body procname + ((equal? sub "body") + (let + ((pname (first rest-args))) + (let + ((entry (tcl-proc-lookup interp pname))) + (if + (nil? entry) + (error (str "info body: \"" pname "\" isn't a procedure")) + (assoc interp :result (get (get entry :def) :body)))))) + ; info exists varname — 1 if variable exists in current frame, 0 otherwise + ((equal? sub "exists") + (let + ((varname (first rest-args))) + (let + ((val (frame-lookup (get interp :frame) varname))) + (assoc interp :result (if (nil? val) "0" "1"))))) + ; info hostname — stub + ((equal? sub "hostname") + (assoc interp :result "localhost")) + ; info script — stub + ((equal? sub "script") + (assoc interp :result "")) + ; info tclversion — stub + ((equal? sub "tclversion") + (assoc interp :result "8.6")) + (else (error (str "info: unknown subcommand \"" sub "\"")))))))) + +; --- coroutine support --- + +; yield: inside a coroutine body, record a yielded value +(define + tcl-cmd-yield + (fn + (interp args) + (let + ((val (if (> (len args) 0) (first args) ""))) + (if + (get interp :in-coro) + (assoc + (assoc interp :coro-yields (append (get interp :coro-yields) (list val))) + :result "") + (error "yield called outside coroutine"))))) + +; yieldto: stub — yield empty string +(define + tcl-cmd-yieldto + (fn + (interp args) + (if + (get interp :in-coro) + (assoc + (assoc interp :coro-yields (append (get interp :coro-yields) (list ""))) + :result "") + (error "yieldto called outside coroutine")))) + +; make-coro-cmd: returns a command function that pops values from the coroutine's yields list +(define + make-coro-cmd + (fn + (coro-name) + (fn + (interp args) + (let + ((coros (get interp :coroutines))) + (let + ((coro (get coros coro-name))) + (if + (nil? coro) + (error (str "coroutine \"" coro-name "\" not found")) + (let + ((yields (get coro :yields)) + (pos (get coro :pos))) + (if + (>= pos (len yields)) + (assoc interp :result "") + (let + ((val (nth yields pos))) + (let + ((new-coro (assoc coro :pos (+ pos 1)))) + (assoc + (assoc interp :coroutines (assoc coros coro-name new-coro)) + :result val))))))))))) + +; coroutine: execute proc eagerly in a coroutine context, collecting all yields +(define + tcl-cmd-coroutine + (fn + (interp args) + (if + (< (len args) 2) + (error "coroutine: wrong # args") + (let + ((coro-name (first args)) + (cmd-name (nth args 1)) + (call-args (rest (rest args)))) + ; set up coroutine context + (let + ((coro-interp + (assoc interp + :in-coro true + :coro-yields (list) + :result "" + :code 0))) + ; find the command or proc and execute it + (let + ((cmd-fn (get (get coro-interp :commands) cmd-name))) + (let + ((exec-result + (if + (nil? cmd-fn) + (let + ((proc-entry (tcl-proc-lookup coro-interp cmd-name))) + (if + (nil? proc-entry) + (error (str "coroutine: unknown command \"" cmd-name "\"")) + (tcl-call-proc coro-interp (get proc-entry :name) (get proc-entry :def) call-args))) + (cmd-fn coro-interp call-args)))) + (let + ((yields (get exec-result :coro-yields))) + ; build the coroutine state + (let + ((new-coros (assoc (get exec-result :coroutines) coro-name {:yields yields :pos 0}))) + ; register the coroutine command in the commands dict + (let + ((new-commands (assoc (get exec-result :commands) coro-name (make-coro-cmd coro-name)))) + (assoc exec-result + :coroutines new-coros + :commands new-commands + :in-coro false + :coro-yields (list) + :result ""))))))))))) + +; --- clock command (stubs) --- + +(define + tcl-cmd-clock + (fn + (interp args) + (if + (= 0 (len args)) + (error "clock: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ((equal? sub "seconds") (assoc interp :result "0")) + ((equal? sub "milliseconds") (assoc interp :result "0")) + ((equal? sub "format") (assoc interp :result "Thu Jan 1 00:00:00 UTC 1970")) + ((equal? sub "scan") (assoc interp :result "0")) + (else (error (str "clock: unknown subcommand \"" sub "\"")))))))) + +; --- file I/O stubs --- + +(define + tcl-cmd-open + (fn + (interp args) + (assoc interp :result "file0"))) + +(define + tcl-cmd-close + (fn + (interp args) + (assoc interp :result ""))) + +(define + tcl-cmd-read + (fn + (interp args) + (assoc interp :result ""))) + +; gets channel ?varname? +(define + tcl-cmd-gets-chan + (fn + (interp args) + (if + (> (len args) 1) + ; gets channel varname: store "" and return -1 (EOF) + (assoc (tcl-var-set interp (nth args 1) "") :result "-1") + ; gets channel: return "" (EOF) + (assoc interp :result "")))) + +(define + tcl-cmd-eof + (fn + (interp args) + (assoc interp :result "1"))) + +(define + tcl-cmd-seek + (fn + (interp args) + (assoc interp :result ""))) + +(define + tcl-cmd-tell + (fn + (interp args) + (assoc interp :result "0"))) + +(define + tcl-cmd-flush + (fn + (interp args) + (assoc interp :result ""))) + +; file command dispatcher +(define + tcl-cmd-file + (fn + (interp args) + (if + (= 0 (len args)) + (error "file: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ((equal? sub "exists") + (assoc interp :result "0")) + ((equal? sub "join") + (assoc interp :result (join "/" rest-args))) + ((equal? sub "split") + (assoc interp :result (tcl-list-build (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/"))))) + ((equal? sub "tail") + (let + ((parts (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/")))) + (assoc interp :result (if (= 0 (len parts)) "" (last parts))))) + ((equal? sub "dirname") + (let + ((parts (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/")))) + (assoc interp :result + (if + (<= (len parts) 1) + "." + (str "/" (join "/" (take-n parts (- (len parts) 1)))))))) + ((equal? sub "extension") + (let + ((nm (first rest-args))) + (let + ((dot-idx (tcl-string-last "." nm (- (string-length nm) 1)))) + (assoc interp :result + (if + (equal? dot-idx "-1") + "" + (substring nm (parse-int dot-idx) (string-length nm))))))) + ((equal? sub "rootname") + (let + ((nm (first rest-args))) + (let + ((dot-idx (tcl-string-last "." nm (- (string-length nm) 1)))) + (assoc interp :result + (if + (equal? dot-idx "-1") + nm + (substring nm 0 (parse-int dot-idx))))))) + ((equal? sub "isfile") (assoc interp :result "0")) + ((equal? sub "isdir") (assoc interp :result "0")) + ((equal? sub "isdirectory") (assoc interp :result "0")) + ((equal? sub "readable") (assoc interp :result "0")) + ((equal? sub "writable") (assoc interp :result "0")) + ((equal? sub "size") (assoc interp :result "0")) + ((equal? sub "mkdir") (assoc interp :result "")) + ((equal? sub "copy") (assoc interp :result "")) + ((equal? sub "rename") (assoc interp :result "")) + ((equal? sub "delete") (assoc interp :result "")) + (else (error (str "file: unknown subcommand \"" sub "\"")))))))) + +(define + make-default-tcl-interp + (fn + () + (let + ((i (make-tcl-interp))) + (let + ((i (tcl-register i "set" tcl-cmd-set))) + (let + ((i (tcl-register i "puts" tcl-cmd-puts))) + (let + ((i (tcl-register i "incr" tcl-cmd-incr))) + (let + ((i (tcl-register i "append" tcl-cmd-append))) + (let + ((i (tcl-register i "unset" tcl-cmd-unset))) + (let + ((i (tcl-register i "lappend" tcl-cmd-lappend))) + (let + ((i (tcl-register i "eval" tcl-cmd-eval))) + (let + ((i (tcl-register i "if" tcl-cmd-if))) + (let + ((i (tcl-register i "while" tcl-cmd-while))) + (let + ((i (tcl-register i "for" tcl-cmd-for))) + (let + ((i (tcl-register i "foreach" tcl-cmd-foreach))) + (let + ((i (tcl-register i "switch" tcl-cmd-switch))) + (let + ((i (tcl-register i "break" tcl-cmd-break))) + (let + ((i (tcl-register i "continue" tcl-cmd-continue))) + (let + ((i (tcl-register i "return" tcl-cmd-return))) + (let + ((i (tcl-register i "error" tcl-cmd-error))) + (let + ((i (tcl-register i "expr" tcl-cmd-expr))) + (let + ((i (tcl-register i "gets" tcl-cmd-gets))) + (let + ((i (tcl-register i "subst" tcl-cmd-subst))) + (let + ((i (tcl-register i "format" tcl-cmd-format))) + (let + ((i (tcl-register i "scan" tcl-cmd-scan))) + (let + ((i (tcl-register i "string" tcl-cmd-string))) + (let + ((i (tcl-register i "list" tcl-cmd-list))) + (let + ((i (tcl-register i "lindex" tcl-cmd-lindex))) + (let + ((i (tcl-register i "lrange" tcl-cmd-lrange))) + (let + ((i (tcl-register i "llength" tcl-cmd-llength))) + (let + ((i (tcl-register i "lreverse" tcl-cmd-lreverse))) + (let + ((i (tcl-register i "lsearch" tcl-cmd-lsearch))) + (let + ((i (tcl-register i "lsort" tcl-cmd-lsort))) + (let + ((i (tcl-register i "lreplace" tcl-cmd-lreplace))) + (let + ((i (tcl-register i "linsert" tcl-cmd-linsert))) + (let + ((i (tcl-register i "concat" tcl-cmd-concat))) + (let + ((i (tcl-register i "split" tcl-cmd-split))) + (let + ((i (tcl-register i "join" tcl-cmd-join))) + (let + ((i (tcl-register i "dict" tcl-cmd-dict))) + (let + ((i (tcl-register i "proc" tcl-cmd-proc))) + (let + ((i (tcl-register i "uplevel" tcl-cmd-uplevel))) + (let + ((i (tcl-register i "upvar" tcl-cmd-upvar))) + (let + ((i (tcl-register i "global" tcl-cmd-global))) + (let + ((i (tcl-register i "variable" tcl-cmd-variable))) + (let + ((i (tcl-register i "info" tcl-cmd-info))) + (let + ((i (tcl-register i "catch" tcl-cmd-catch))) + (let + ((i (tcl-register i "throw" tcl-cmd-throw))) + (let + ((i (tcl-register i "try" tcl-cmd-try))) + (let + ((i (tcl-register i "namespace" tcl-cmd-namespace))) + (let + ((i (tcl-register i "coroutine" tcl-cmd-coroutine))) + (let + ((i (tcl-register i "yield" tcl-cmd-yield))) + (let + ((i (tcl-register i "yieldto" tcl-cmd-yieldto))) + (let + ((i (tcl-register i "clock" tcl-cmd-clock))) + (let + ((i (tcl-register i "open" tcl-cmd-open))) + (let + ((i (tcl-register i "close" tcl-cmd-close))) + (let + ((i (tcl-register i "read" tcl-cmd-read))) + (let + ((i (tcl-register i "eof" tcl-cmd-eof))) + (let + ((i (tcl-register i "seek" tcl-cmd-seek))) + (let + ((i (tcl-register i "tell" tcl-cmd-tell))) + (let + ((i (tcl-register i "flush" tcl-cmd-flush))) + (tcl-register i "file" tcl-cmd-file)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/scoreboard.json b/lib/tcl/scoreboard.json new file mode 100644 index 00000000..8d3dd95f --- /dev/null +++ b/lib/tcl/scoreboard.json @@ -0,0 +1,10 @@ +{ + "total": 3, + "passed": 3, + "failed": 0, + "programs": { + "assert": {"status": "PASS", "expected": "10", "got": "10"}, + "for-each-line": {"status": "PASS", "expected": "13", "got": "13"}, + "with-temp-var": {"status": "PASS", "expected": "100 999", "got": "100 999"} + } +} diff --git a/lib/tcl/scoreboard.md b/lib/tcl/scoreboard.md new file mode 100644 index 00000000..910b3a40 --- /dev/null +++ b/lib/tcl/scoreboard.md @@ -0,0 +1,9 @@ +# Tcl-on-SX Conformance Scoreboard + +| Program | Status | Expected | Got | +|---|---|---|---| +| assert | ✓ PASS | 10 | 10 | +| for-each-line | ✓ PASS | 13 | 13 | +| with-temp-var | ✓ PASS | 100 999 | 100 999 | + +**3/3 passing** diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh new file mode 100755 index 00000000..b9c74216 --- /dev/null +++ b/lib/tcl/test.sh @@ -0,0 +1,113 @@ +#!/usr/bin/env bash +# Tcl-on-SX test runner — epoch protocol to sx_server.exe +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then echo "ERROR: sx_server.exe not found"; exit 1; fi + +VERBOSE="${1:-}" +TMPFILE=$(mktemp) +HELPER=$(mktemp --suffix=.sx) +trap "rm -f $TMPFILE $HELPER" EXIT + +# Helper file: run all test suites and format a parseable summary string +cat > "$HELPER" << 'HELPER_EOF' +(define __pr (tcl-run-parse-tests)) +(define __er (tcl-run-eval-tests)) +(define __xr (tcl-run-error-tests)) +(define __nr (tcl-run-namespace-tests)) +(define __cr (tcl-run-coro-tests)) +(define __ir (tcl-run-idiom-tests)) +(define tcl-test-summary + (str "PARSE:" (get __pr "passed") ":" (get __pr "failed") + " EVAL:" (get __er "passed") ":" (get __er "failed") + " ERROR:" (get __xr "passed") ":" (get __xr "failed") + " NAMESPACE:" (get __nr "passed") ":" (get __nr "failed") + " CORO:" (get __cr "passed") ":" (get __cr "failed") + " IDIOM:" (get __ir "passed") ":" (get __ir "failed"))) +HELPER_EOF + +cat > "$TMPFILE" << EPOCHS +(epoch 1) +(load "lib/tcl/tokenizer.sx") +(epoch 2) +(load "lib/tcl/parser.sx") +(epoch 3) +(load "lib/tcl/tests/parse.sx") +(epoch 4) +(load "lib/tcl/runtime.sx") +(epoch 5) +(load "lib/tcl/tests/eval.sx") +(epoch 6) +(load "lib/tcl/tests/error.sx") +(epoch 7) +(load "lib/tcl/tests/namespace.sx") +(epoch 8) +(load "lib/tcl/tests/coro.sx") +(epoch 9) +(load "lib/tcl/tests/idioms.sx") +(epoch 10) +(load "$HELPER") +(epoch 11) +(eval "tcl-test-summary") +EPOCHS + +OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>&1) +[ "$VERBOSE" = "-v" ] && echo "$OUTPUT" + +# Extract summary line from epoch 11 output +SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 11 " | tail -1 | tr -d '"') + +if [ -z "$SUMMARY" ]; then + echo "ERROR: no summary from test run" + echo "$OUTPUT" | tail -20 + exit 1 +fi + +# Parse PARSE:N:M EVAL:N:M ERROR:N:M NAMESPACE:N:M CORO:N:M IDIOM:N:M +PARSE_PART=$(echo "$SUMMARY" | grep -o 'PARSE:[0-9]*:[0-9]*') +EVAL_PART=$(echo "$SUMMARY" | grep -o 'EVAL:[0-9]*:[0-9]*') +ERROR_PART=$(echo "$SUMMARY" | grep -o 'ERROR:[0-9]*:[0-9]*') +NAMESPACE_PART=$(echo "$SUMMARY" | grep -o 'NAMESPACE:[0-9]*:[0-9]*') +CORO_PART=$(echo "$SUMMARY" | grep -o 'CORO:[0-9]*:[0-9]*') +IDIOM_PART=$(echo "$SUMMARY" | grep -o 'IDIOM:[0-9]*:[0-9]*') + +PARSE_PASSED=$(echo "$PARSE_PART" | cut -d: -f2) +PARSE_FAILED=$(echo "$PARSE_PART" | cut -d: -f3) +EVAL_PASSED=$(echo "$EVAL_PART" | cut -d: -f2) +EVAL_FAILED=$(echo "$EVAL_PART" | cut -d: -f3) +ERROR_PASSED=$(echo "$ERROR_PART" | cut -d: -f2) +ERROR_FAILED=$(echo "$ERROR_PART" | cut -d: -f3) +NAMESPACE_PASSED=$(echo "$NAMESPACE_PART" | cut -d: -f2) +NAMESPACE_FAILED=$(echo "$NAMESPACE_PART" | cut -d: -f3) +CORO_PASSED=$(echo "$CORO_PART" | cut -d: -f2) +CORO_FAILED=$(echo "$CORO_PART" | cut -d: -f3) +IDIOM_PASSED=$(echo "$IDIOM_PART" | cut -d: -f2) +IDIOM_FAILED=$(echo "$IDIOM_PART" | cut -d: -f3) + +PARSE_PASSED=${PARSE_PASSED:-0}; PARSE_FAILED=${PARSE_FAILED:-1} +EVAL_PASSED=${EVAL_PASSED:-0}; EVAL_FAILED=${EVAL_FAILED:-1} +ERROR_PASSED=${ERROR_PASSED:-0}; ERROR_FAILED=${ERROR_FAILED:-1} +NAMESPACE_PASSED=${NAMESPACE_PASSED:-0}; NAMESPACE_FAILED=${NAMESPACE_FAILED:-1} +CORO_PASSED=${CORO_PASSED:-0}; CORO_FAILED=${CORO_FAILED:-1} +IDIOM_PASSED=${IDIOM_PASSED:-0}; IDIOM_FAILED=${IDIOM_FAILED:-1} + +TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED + ERROR_PASSED + NAMESPACE_PASSED + CORO_PASSED + IDIOM_PASSED)) +TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED + ERROR_FAILED + NAMESPACE_FAILED + CORO_FAILED + IDIOM_FAILED)) +TOTAL=$((TOTAL_PASSED + TOTAL_FAILED)) + +if [ "$TOTAL_FAILED" = "0" ]; then + echo "ok $TOTAL_PASSED/$TOTAL tcl tests passed (parse: $PARSE_PASSED, eval: $EVAL_PASSED, error: $ERROR_PASSED, namespace: $NAMESPACE_PASSED, coro: $CORO_PASSED, idiom: $IDIOM_PASSED)" + exit 0 +else + echo "FAIL $TOTAL_PASSED/$TOTAL passed, $TOTAL_FAILED failed (parse: $PARSE_PASSED/$((PARSE_PASSED+PARSE_FAILED)), eval: $EVAL_PASSED/$((EVAL_PASSED+EVAL_FAILED)), error: $ERROR_PASSED/$((ERROR_PASSED+ERROR_FAILED)), namespace: $NAMESPACE_PASSED/$((NAMESPACE_PASSED+NAMESPACE_FAILED)), coro: $CORO_PASSED/$((CORO_PASSED+CORO_FAILED)), idiom: $IDIOM_PASSED/$((IDIOM_PASSED+IDIOM_FAILED)))" + if [ -z "$VERBOSE" ]; then + echo "--- output ---" + echo "$OUTPUT" | tail -30 + fi + exit 1 +fi diff --git a/lib/tcl/tests/coro.sx b/lib/tcl/tests/coro.sx new file mode 100644 index 00000000..541ee625 --- /dev/null +++ b/lib/tcl/tests/coro.sx @@ -0,0 +1,136 @@ +; Tcl-on-SX coroutine tests (Phase 6) +(define tcl-coro-pass 0) +(define tcl-coro-fail 0) +(define tcl-coro-failures (list)) + +(define + tcl-coro-assert + (fn + (label expected actual) + (if + (equal? expected actual) + (set! tcl-coro-pass (+ tcl-coro-pass 1)) + (begin + (set! tcl-coro-fail (+ tcl-coro-fail 1)) + (append! + tcl-coro-failures + (str label ": expected=" (str expected) " got=" (str actual))))))) + +(define + tcl-run-coro-tests + (fn + () + (set! tcl-coro-pass 0) + (set! tcl-coro-fail 0) + (set! tcl-coro-failures (list)) + (define interp (fn () (make-default-tcl-interp))) + (define run (fn (src) (tcl-eval-string (interp) src))) + (define + ok + (fn (label actual expected) (tcl-coro-assert label expected actual))) + + ; --- basic coroutine: yields one value --- + (ok "coro-single-yield" + (get (run "proc gen {} { yield hello }\ncoroutine g gen\ng") :result) + "hello") + + ; --- coroutine yields multiple values in order --- + (ok "coro-multi-yield-1" + (get (run "proc cnt {} { yield a; yield b; yield c }\ncoroutine c1 cnt\nc1") :result) + "a") + + (ok "coro-multi-yield-2" + (get (run "proc cnt {} { yield a; yield b; yield c }\ncoroutine c1 cnt\nc1\nc1") :result) + "b") + + (ok "coro-multi-yield-3" + (get (run "proc cnt {} { yield a; yield b; yield c }\ncoroutine c1 cnt\nc1\nc1\nc1") :result) + "c") + + ; --- coroutine with arguments to proc --- + (ok "coro-args" + (get (run "proc gen2 {n} { yield $n; yield [expr {$n + 1}] }\ncoroutine g2 gen2 10\ng2") :result) + "10") + + (ok "coro-args-2" + (get (run "proc gen2 {n} { yield $n; yield [expr {$n + 1}] }\ncoroutine g2 gen2 10\ng2\ng2") :result) + "11") + + ; --- coroutine exhausted returns empty string --- + (ok "coro-exhausted" + (get (run "proc g3 {} { yield only }\ncoroutine c3 g3\nc3\nc3") :result) + "") + + ; --- yield in while loop --- + (ok "coro-while-loop-1" + (get (run "proc counter {max} { set i 0; while {$i < $max} { yield $i; incr i } }\ncoroutine cw counter 3\ncw") :result) + "0") + + (ok "coro-while-loop-2" + (get (run "proc counter {max} { set i 0; while {$i < $max} { yield $i; incr i } }\ncoroutine cw counter 3\ncw\ncw") :result) + "1") + + (ok "coro-while-loop-3" + (get (run "proc counter {max} { set i 0; while {$i < $max} { yield $i; incr i } }\ncoroutine cw counter 3\ncw\ncw\ncw") :result) + "2") + + ; --- collect all yields from coroutine --- + (ok "coro-collect-all" + (get + (run + "proc counter {n max} { while {$n < $max} { yield $n; incr n }; yield done }\ncoroutine gen1 counter 0 3\nset out {}\nfor {set i 0} {$i < 4} {incr i} { lappend out [gen1] }\nlindex $out 3") + :result) + "done") + + ; --- two independent coroutines --- + (ok "coro-two-independent" + (get + (run + "proc seq {start} { yield $start; yield [expr {$start+1}] }\ncoroutine ca seq 0\ncoroutine cb seq 10\nset r [ca]\nappend r \":\" [cb]") + :result) + "0:10") + + ; --- yield with no value returns empty string --- + (ok "coro-yield-no-val" + (get (run "proc g {} { yield }\ncoroutine cg g\ncg") :result) + "") + + ; --- clock seconds stub --- + (ok "clock-seconds" + (get (run "clock seconds") :result) + "0") + + ; --- clock milliseconds stub --- + (ok "clock-milliseconds" + (get (run "clock milliseconds") :result) + "0") + + ; --- clock format stub --- + (ok "clock-format" + (get (run "clock format 0") :result) + "Thu Jan 1 00:00:00 UTC 1970") + + ; --- file stubs --- + (ok "file-exists-stub" + (get (run "file exists /no/such/file") :result) + "0") + + (ok "file-join" + (get (run "file join foo bar baz") :result) + "foo/bar/baz") + + (ok "open-returns-channel" + (get (run "open /dev/null r") :result) + "file0") + + (ok "eof-returns-1" + (get (run "set ch [open /dev/null r]\neof $ch") :result) + "1") + + (dict + "passed" + tcl-coro-pass + "failed" + tcl-coro-fail + "failures" + tcl-coro-failures))) diff --git a/lib/tcl/tests/error.sx b/lib/tcl/tests/error.sx new file mode 100644 index 00000000..8ea6ff32 --- /dev/null +++ b/lib/tcl/tests/error.sx @@ -0,0 +1,192 @@ +; Tcl-on-SX error handling tests (Phase 4) +(define tcl-err-pass 0) +(define tcl-err-fail 0) +(define tcl-err-failures (list)) + +(define + tcl-err-assert + (fn + (label expected actual) + (if + (equal? expected actual) + (set! tcl-err-pass (+ tcl-err-pass 1)) + (begin + (set! tcl-err-fail (+ tcl-err-fail 1)) + (append! + tcl-err-failures + (str label ": expected=" (str expected) " got=" (str actual))))))) + +(define + tcl-run-error-tests + (fn + () + (set! tcl-err-pass 0) + (set! tcl-err-fail 0) + (set! tcl-err-failures (list)) + (define interp (fn () (make-default-tcl-interp))) + (define run (fn (src) (tcl-eval-string (interp) src))) + (define + ok + (fn (label actual expected) (tcl-err-assert label expected actual))) + (define + ok? + (fn (label condition) (tcl-err-assert label true condition))) + + ; --- catch basic --- + (ok "catch-ok-code" (get (run "catch {set x 1}") :result) "0") + (ok "catch-ok-result-var" (tcl-var-get (run "catch {set x hello} r") "r") "hello") + (ok "catch-ok-returns-0" (get (run "catch {set x hello} r") :result) "0") + + ; --- catch error --- + (ok "catch-error-code" (get (run "catch {error oops} r") :result) "1") + (ok "catch-error-result-var" (tcl-var-get (run "catch {error oops} r") "r") "oops") + + ; --- catch outer code stays 0 --- + (ok? "catch-outer-code-ok" (= (get (run "catch {error boom} r") :code) 0)) + + ; --- catch code 2 (return) --- + (ok "catch-return-code" (get (run "proc p {} {return hello}\ncatch {p} r") :result) "0") + (ok "catch-return-val" (tcl-var-get (run "proc p {} {return hello}\ncatch {p} r") "r") "hello") + + ; --- catch code 3 (break) --- + (ok "catch-break-code" (get (run "catch {break} r") :result) "3") + + ; --- catch code 4 (continue) --- + (ok "catch-continue-code" (get (run "catch {continue} r") :result) "4") + + ; --- catch no resultVar --- + (ok "catch-no-var-ok" (get (run "catch {set x 1}") :result) "0") + (ok "catch-no-var-err" (get (run "catch {error boom}") :result) "1") + + ; --- catch with optsVar --- + (ok? "catch-opts-var-set" + (let + ((i (run "catch {error boom} r opts"))) + (not (equal? (tcl-var-get i "opts") "")))) + (ok? "catch-opts-contains-code" + (let + ((i (run "catch {error boom} r opts"))) + (let + ((opts-str (tcl-var-get i "opts"))) + (not (equal? (tcl-string-first "-code" opts-str 0) "-1"))))) + + ; --- catch nested --- + (ok "catch-nested" + (tcl-var-get (run "catch {catch {error inner} r2} outer") "r2") + "inner") + + ; --- return -code error --- + (ok "return-code-error-code" + (get (run "catch {return -code error oops} r") :result) + "1") + (ok "return-code-error-val" + (tcl-var-get (run "catch {return -code error oops} r") "r") + "oops") + + ; --- return -code ok --- + (ok "return-code-ok" + (get (run "catch {return -code ok hello} r") :result) + "0") + (ok "return-code-ok-val" + (tcl-var-get (run "catch {return -code ok hello} r") "r") + "hello") + + ; --- return -code break --- + (ok "return-code-break" + (get (run "catch {return -code break} r") :result) + "3") + + ; --- return -code continue --- + (ok "return-code-continue" + (get (run "catch {return -code continue} r") :result) + "4") + + ; --- return -code numeric --- + (ok "return-code-numeric-5" + (get (run "catch {return -code 5 msg} r") :result) + "5") + + ; --- return plain still code 2 (catch sees raw return code) --- + (ok "return-plain-code" + (get (run "catch {return hello} r") :result) + "2") + (ok "return-plain-val" + (tcl-var-get (run "catch {return hello} r") "r") + "hello") + + ; --- proc return -code error --- + (ok "proc-return-code-error" + (get (run "proc p {} {return -code error bad}\ncatch {p} r") :result) + "1") + (ok "proc-return-code-error-val" + (tcl-var-get (run "proc p {} {return -code error bad}\ncatch {p} r") "r") + "bad") + + ; --- error with info/code args --- + (ok? "error-errorinfo-stored" + (let + ((i (run "catch {error msg myinfo mycode} r"))) + (= (get i :code) 0))) + + ; --- throw --- + (ok "throw-code" (get (run "catch {throw MYERR something} r") :result) "1") + (ok "throw-msg" (tcl-var-get (run "catch {throw MYERR something} r") "r") "something") + + ; --- try basic ok --- + (ok "try-ok-result" + (get (run "try {set x hello} on ok {r} {set r2 $r}") :result) + "hello") + + ; --- try on error --- + (ok "try-on-error-handled" + (get (run "try {error boom} on error {e} {set caught $e}") :result) + "boom") + (ok "try-on-error-var" + (tcl-var-get (run "try {error boom} on error {e} {set caught $e}") "caught") + "boom") + + ; --- try finally always runs --- + (ok "try-finally-ok" + (tcl-var-get (run "try {set x 1} finally {set done yes}") "done") + "yes") + (ok "try-finally-error" + (tcl-var-get (run "catch {try {error boom} finally {set done yes}} r") "done") + "yes") + + ; --- try on error + finally --- + (ok "try-error-finally" + (tcl-var-get + (run "try {error oops} on error {e} {set caught $e} finally {set cleaned yes}") + "cleaned") + "yes") + (ok "try-error-finally-caught" + (tcl-var-get + (run "try {error oops} on error {e} {set caught $e} finally {set cleaned yes}") + "caught") + "oops") + + ; --- try on ok and on error --- + (ok "try-multi-clause-ok" + (tcl-var-get + (run "try {set x 1} on ok {r} {set which ok} on error {e} {set which err}") + "which") + "ok") + (ok "try-multi-clause-err" + (tcl-var-get + (run "try {error boom} on ok {r} {set which ok} on error {e} {set which err}") + "which") + "err") + + ; --- catch preserves output --- + (ok "catch-output-preserved" + (get (run "puts -nonewline before\ncatch {puts -nonewline inside\nerror oops}\nputs -nonewline after") + :output) + "beforeinsideafter") + + (dict + "passed" + tcl-err-pass + "failed" + tcl-err-fail + "failures" + tcl-err-failures))) diff --git a/lib/tcl/tests/eval.sx b/lib/tcl/tests/eval.sx new file mode 100644 index 00000000..5352646c --- /dev/null +++ b/lib/tcl/tests/eval.sx @@ -0,0 +1,338 @@ +; Tcl-on-SX eval tests +(define tcl-eval-pass 0) +(define tcl-eval-fail 0) +(define tcl-eval-failures (list)) + +(define + tcl-eval-assert + (fn + (label expected actual) + (if + (equal? expected actual) + (set! tcl-eval-pass (+ tcl-eval-pass 1)) + (begin + (set! tcl-eval-fail (+ tcl-eval-fail 1)) + (append! + tcl-eval-failures + (str label ": expected=" (str expected) " got=" (str actual))))))) + +(define + tcl-run-eval-tests + (fn + () + (set! tcl-eval-pass 0) + (set! tcl-eval-fail 0) + (set! tcl-eval-failures (list)) + (define interp (fn () (make-default-tcl-interp))) + (define run (fn (src) (tcl-eval-string (interp) src))) + (define + ok + (fn (label actual expected) (tcl-eval-assert label expected actual))) + (define + ok? + (fn (label condition) (tcl-eval-assert label true condition))) + (tcl-eval-assert "set-result" "hello" (get (run "set x hello") :result)) + (tcl-eval-assert + "set-stored" + "hello" + (tcl-var-get (run "set x hello") "x")) + (tcl-eval-assert + "var-sub" + "hello" + (tcl-var-get (run "set x hello\nset y $x") "y")) + (tcl-eval-assert + "puts" + "world\n" + (get (run "set x world\nputs $x") :output)) + (tcl-eval-assert + "puts-nonewline" + "hi" + (get (run "puts -nonewline hi") :output)) + (tcl-eval-assert "incr" "6" (tcl-var-get (run "set x 5\nincr x") "x")) + (tcl-eval-assert + "incr-delta" + "8" + (tcl-var-get (run "set x 5\nincr x 3") "x")) + (tcl-eval-assert + "incr-neg" + "7" + (tcl-var-get (run "set x 10\nincr x -3") "x")) + (tcl-eval-assert + "append" + "foobar" + (tcl-var-get (run "set x foo\nappend x bar") "x")) + (tcl-eval-assert + "append-new" + "hello" + (tcl-var-get (run "append x hello") "x")) + (tcl-eval-assert + "cmdsub-result" + "6" + (get (run "set x 5\nset y [incr x]") :result)) + (tcl-eval-assert + "cmdsub-y" + "6" + (tcl-var-get (run "set x 5\nset y [incr x]") "y")) + (tcl-eval-assert + "cmdsub-x" + "6" + (tcl-var-get (run "set x 5\nset y [incr x]") "x")) + (tcl-eval-assert + "multi-cmd" + "second" + (get (run "set x first\nset x second") :result)) + (tcl-eval-assert "semi-x" "1" (tcl-var-get (run "set x 1; set y 2") "x")) + (tcl-eval-assert "semi-y" "2" (tcl-var-get (run "set x 1; set y 2") "y")) + (tcl-eval-assert + "braced-nosub" + "$x" + (tcl-var-get (run "set x 42\nset y {$x}") "y")) + (tcl-eval-assert + "concat-word" + "foobar" + (tcl-var-get (run "set x foo\nset y ${x}bar") "y")) + (tcl-eval-assert + "set-get" + "world" + (get (run "set x world\nset x") :result)) + (tcl-eval-assert + "puts-channel" + "hello\n" + (get (run "puts stdout hello") :output)) + (ok "if-true" (get (run "set x 0\nif {1} {set x 1}") :result) "1") + (ok "if-false" (get (run "set x 0\nif {0} {set x 1}") :result) "0") + (ok + "if-else-t" + (tcl-var-get (run "if {1} {set x yes} else {set x no}") "x") + "yes") + (ok + "if-else-f" + (tcl-var-get (run "if {0} {set x yes} else {set x no}") "x") + "no") + (ok + "if-cmp" + (tcl-var-get + (run "set x 5\nif {$x > 3} {set r big} else {set r small}") + "r") + "big") + (ok + "while" + (tcl-var-get + (run "set i 0\nset s 0\nwhile {$i < 5} {incr i\nincr s $i}") + "s") + "15") + (ok + "while-break" + (tcl-var-get + (run "set i 0\nwhile {1} {incr i\nif {$i == 3} {break}}") + "i") + "3") + (ok + "for" + (tcl-var-get + (run "set s 0\nfor {set i 1} {$i <= 5} {incr i} {incr s $i}") + "s") + "15") + (ok + "foreach" + (tcl-var-get (run "set s 0\nforeach x {1 2 3 4 5} {incr s $x}") "s") + "15") + (ok + "foreach-list" + (get (run "set acc \"\"\nforeach w {hello world} {append acc $w}") :result) + "helloworld") + (ok + "lappend" + (tcl-var-get (run "lappend lst a\nlappend lst b\nlappend lst c") "lst") + "a b c") + (ok? + "unset-gone" + (let + ((i (run "set x 42\nunset x"))) + (let + ((frame (get i :frame))) + (nil? (get (get frame :locals) "x"))))) + (ok "eval" (tcl-var-get (run "eval {set x hello}") "x") "hello") + (ok "expr-precedence" (get (run "expr {3 + 4 * 2}") :result) "11") + (ok "expr-parens" (get (run "expr {(3 + 4) * 2}") :result) "14") + (ok "expr-unary-minus" (get (run "expr {-5}") :result) "-5") + (ok "expr-unary-not-0" (get (run "expr {!0}") :result) "1") + (ok "expr-unary-not-1" (get (run "expr {!1}") :result) "0") + (ok "expr-power" (get (run "expr {2 ** 10}") :result) "1024") + (ok "expr-le" (get (run "expr {3 <= 3}") :result) "1") + (ok "expr-ge" (get (run "expr {4 >= 5}") :result) "0") + (ok "expr-and" (get (run "expr {1 && 1}") :result) "1") + (ok "expr-or" (get (run "expr {0 || 1}") :result) "1") + (ok "expr-var-sub" (get (run "set x 7\nexpr {$x * 3}") :result) "21") + (ok "expr-abs-neg" (get (run "expr {abs(-3)}") :result) "3") + (ok "expr-abs-pos" (get (run "expr {abs(5)}") :result) "5") + (ok "expr-pow-fn" (get (run "expr {pow(2, 8)}") :result) "256") + (ok "expr-max" (get (run "expr {max(3, 7)}") :result) "7") + (ok "expr-min" (get (run "expr {min(3, 7)}") :result) "3") + (ok "expr-sqrt-9" (get (run "expr {sqrt(9)}") :result) "3") + (ok "expr-sqrt-16" (get (run "expr {sqrt(16)}") :result) "4") + (ok "expr-mod" (get (run "expr {17 % 5}") :result) "2") + (ok "expr-nospace" (get (run "expr {3+4*2}") :result) "11") + (ok "expr-add" (get (run "expr {3 + 4}") :result) "7") + (ok "expr-cmp" (get (run "expr {5 > 3}") :result) "1") + (ok + "break-stops" + (tcl-var-get (run "set x 0\nwhile {1} {set x 1\nbreak\nset x 99}") "x") + "1") + (ok + "continue" + (tcl-var-get + (run + "set s 0\nfor {set i 1} {$i <= 5} {incr i} {if {$i == 3} {continue}\nincr s $i}") + "s") + "12") + (ok + "switch" + (tcl-var-get + (run "set x foo\nswitch $x {{foo} {set r yes} {bar} {set r no}}") + "r") + "yes") + (ok + "switch-default" + (tcl-var-get + (run "set x baz\nswitch $x {{foo} {set r yes} default {set r other}}") + "r") + "other") + (ok + "nested-if" + (tcl-var-get + (run + "set x 5\nif {$x > 10} {set r big} elseif {$x > 3} {set r mid} else {set r small}") + "r") + "mid") + (ok "str-length" (get (run "string length hello") :result) "5") + (ok "str-length-empty" (get (run "string length {}") :result) "0") + (ok "str-index" (get (run "string index hello 1") :result) "e") + (ok "str-index-oob" (get (run "string index hello 99") :result) "") + (ok "str-range" (get (run "string range hello 1 3") :result) "ell") + (ok "str-range-clamp" (get (run "string range hello 3 99") :result) "lo") + (ok "str-compare-eq" (get (run "string compare abc abc") :result) "0") + (ok "str-compare-lt" (get (run "string compare abc abd") :result) "-1") + (ok "str-compare-gt" (get (run "string compare b a") :result) "1") + (ok "str-match-star" (get (run "string match h*o hello") :result) "1") + (ok "str-match-q" (get (run "string match h?llo hello") :result) "1") + (ok "str-match-no" (get (run "string match h*x hello") :result) "0") + (ok "str-toupper" (get (run "string toupper hello") :result) "HELLO") + (ok "str-tolower" (get (run "string tolower WORLD") :result) "world") + (ok "str-trim" (get (run "string trim { hi }") :result) "hi") + (ok "str-trimleft" (get (run "string trimleft { hi }") :result) "hi ") + (ok "str-trimright" (get (run "string trimright { hi }") :result) " hi") + (ok "str-trim-chars" (get (run "string trim {xxhelloxx} x") :result) "hello") + (ok "str-map" (get (run "string map {a X b Y} {abc}") :result) "XYc") + (ok "str-repeat" (get (run "string repeat ab 3") :result) "ababab") + (ok "str-first" (get (run "string first ll hello") :result) "2") + (ok "str-first-miss" (get (run "string first z hello") :result) "-1") + (ok "str-last" (get (run "string last l hello") :result) "3") + (ok "str-is-int" (get (run "string is integer 42") :result) "1") + (ok "str-is-not-int" (get (run "string is integer foo") :result) "0") + (ok "str-is-alpha" (get (run "string is alpha hello") :result) "1") + (ok "str-is-alpha-no" (get (run "string is alpha hello1") :result) "0") + (ok "str-is-boolean" (get (run "string is boolean true") :result) "1") + (ok "str-cat" (get (run "string cat foo bar baz") :result) "foobarbaz") + ; --- list command tests --- + (ok "list-simple" (get (run "list a b c") :result) "a b c") + (ok "list-brace-elem" (get (run "list {a b} c") :result) "{a b} c") + (ok "list-empty" (get (run "list") :result) "") + (ok "lindex-1" (get (run "lindex {a b c} 1") :result) "b") + (ok "lindex-0" (get (run "lindex {a b c} 0") :result) "a") + (ok "lindex-oob" (get (run "lindex {a b c} 5") :result) "") + (ok "lrange" (get (run "lrange {a b c d} 1 2") :result) "b c") + (ok "lrange-full" (get (run "lrange {a b c} 0 end") :result) "a b c") + (ok "llength" (get (run "llength {a b c}") :result) "3") + (ok "llength-empty" (get (run "llength {}") :result) "0") + (ok "lreverse" (get (run "lreverse {1 2 3}") :result) "3 2 1") + (ok "lsearch-found" (get (run "lsearch {a b c} b") :result) "1") + (ok "lsearch-missing" (get (run "lsearch {a b c} z") :result) "-1") + (ok "lsearch-exact" (get (run "lsearch -exact {foo bar} foo") :result) "0") + (ok "lsort-asc" (get (run "lsort {banana apple cherry}") :result) "apple banana cherry") + (ok "lsort-int" (get (run "lsort -integer {10 2 30 5}") :result) "2 5 10 30") + (ok "lsort-dec" (get (run "lsort -decreasing {c a b}") :result) "c b a") + (ok "lreplace" (get (run "lreplace {a b c d} 1 2 X Y") :result) "a X Y d") + (ok "linsert" (get (run "linsert {a b c} 1 X Y") :result) "a X Y b c") + (ok "linsert-end" (get (run "linsert {a b} end Z") :result) "a b Z") + (ok "concat" (get (run "concat {a b} {c d}") :result) "a b c d") + (ok "split-sep" (get (run "split {a:b:c} :") :result) "a b c") + (ok "split-ws" (get (run "split {a b c}") :result) "a b c") + (ok "join-sep" (get (run "join {a b c} -") :result) "a-b-c") + (ok "join-default" (get (run "join {a b c}") :result) "a b c") + (ok "list-var" (get (run "set L {x y z}\nllength $L") :result) "3") + ; --- dict command tests --- + (ok "dict-create" (get (run "dict create a 1 b 2") :result) "a 1 b 2") + (ok "dict-create-empty" (get (run "dict create") :result) "") + (ok "dict-get" (get (run "dict get {a 1 b 2} a") :result) "1") + (ok "dict-get-b" (get (run "dict get {a 1 b 2} b") :result) "2") + (ok "dict-exists-yes" (get (run "dict exists {a 1 b 2} a") :result) "1") + (ok "dict-exists-no" (get (run "dict exists {a 1 b 2} z") :result) "0") + (ok "dict-set-new" (get (run "set d {}\ndict set d x 42") :result) "x 42") + (ok "dict-set-update" (get (run "set d {a 1 b 2}\ndict set d a 99") :result) "a 99 b 2") + (ok "dict-set-stored" (tcl-var-get (run "set d {a 1}\ndict set d b 2") "d") "a 1 b 2") + (ok "dict-unset" (get (run "set d {a 1 b 2}\ndict unset d a") :result) "b 2") + (ok "dict-unset-stored" (tcl-var-get (run "set d {a 1 b 2}\ndict unset d a") "d") "b 2") + (ok "dict-keys" (get (run "dict keys {a 1 b 2}") :result) "a b") + (ok "dict-keys-pattern" (get (run "dict keys {abc 1 abd 2 xyz 3} ab*") :result) "abc abd") + (ok "dict-values" (get (run "dict values {a 1 b 2}") :result) "1 2") + (ok "dict-size" (get (run "dict size {a 1 b 2 c 3}") :result) "3") + (ok "dict-size-empty" (get (run "dict size {}") :result) "0") + (ok "dict-for" (tcl-var-get (run "set acc {}\ndict for {k v} {a 1 b 2} {append acc $k$v}") "acc") "a1b2") + (ok "dict-merge-disjoint" (get (run "dict merge {a 1} {b 2}") :result) "a 1 b 2") + (ok "dict-merge-overlap" (get (run "dict merge {a 1 b 2} {b 99}") :result) "a 1 b 99") + (ok "dict-incr-existing" (get (run "set d {x 5}\ndict incr d x") :result) "x 6") + (ok "dict-incr-delta" (get (run "set d {x 5}\ndict incr d x 3") :result) "x 8") + (ok "dict-incr-missing" (get (run "set d {}\ndict incr d n") :result) "n 1") + (ok "dict-append" (get (run "set d {x hello}\ndict append d x _hi") :result) "x hello_hi") + (ok "dict-append-new" (get (run "set d {}\ndict append d k val") :result) "k val") + ; --- proc tests --- + (ok "proc-basic" (get (run "proc add {a b} {expr {$a + $b}}\nadd 3 4") :result) "7") + (ok "proc-return" (get (run "proc greet {name} {set msg \"hi $name\"\nreturn $msg}\ngreet World") :result) "hi World") + (ok "proc-factorial" (get (run "proc factorial {n} {if {$n <= 1} {return 1}\nexpr {$n * [factorial [expr {$n - 1}]]}}\nfactorial 5") :result) "120") + (ok "proc-args" (get (run "proc sum args {set t 0\nforeach x $args {incr t $x}\nreturn $t}\nsum 1 2 3 4") :result) "10") + (ok "proc-isolated" (get (run "set x outer\nproc p {} {set x inner\nreturn $x}\np") :result) "inner") + (ok "proc-caller-unchanged" (tcl-var-get (run "set x outer\nproc p {} {set x inner\nreturn $x}\np\nset dummy 1") "x") "outer") + (ok "proc-output" (get (run "proc hello {} {puts -nonewline hi}\nhello") :output) "hi") + ; --- upvar tests --- + (ok "upvar-incr" (tcl-var-get (run "proc incr2 {varname} {upvar 1 $varname v\nincr v}\nset counter 10\nincr2 counter\nset counter") "counter") "11") + (ok "upvar-double" (tcl-var-get (run "proc double-it {varname} {upvar 1 $varname x\nset x [expr {$x * 2}]}\nset val 5\ndouble-it val\nset val") "val") "10") + (ok "upvar-result" (get (run "proc double-it {varname} {upvar 1 $varname x\nset x [expr {$x * 2}]}\nset val 5\ndouble-it val\nset val") :result) "10") + ; --- uplevel tests --- + (ok "uplevel-set" (tcl-var-get (run "proc setvar {name val} {uplevel 1 \"set $name $val\"}\nsetvar x 99\nset x") "x") "99") + (ok "uplevel-get" (get (run "proc getvar {name} {uplevel 1 \"set $name\"}\nset y 77\ngetvar y") :result) "77") + ; --- global tests --- + (ok "global-read" (get (run "set g 100\nproc getg {} {global g\nreturn $g}\ngetg") :result) "100") + (ok "global-write" (tcl-var-get (run "set g 0\nproc bumping {} {global g\nincr g}\nbumping\nbumping\nset g") "g") "2") + ; --- info tests --- + (ok "info-level-0" (get (run "info level") :result) "0") + (ok "info-level-proc" (get (run "proc p {} {info level}\np") :result) "1") + (ok "info-procs" (let ((r (get (run "proc myfn {} {}\ninfo procs") :result))) (contains? (tcl-list-split r) "myfn")) true) + (ok "info-args" (get (run "proc add {a b} {expr {$a+$b}}\ninfo args add") :result) "a b") + (ok "info-commands-has-set" (let ((r (get (run "info commands") :result))) (contains? (tcl-list-split r) "set")) true) + ; --- classic programs --- + (ok + "classic-for-each-line" + (get + (run "proc for-each-line {var lines body} {\n foreach item $lines {\n uplevel 1 [list set $var $item]\n uplevel 1 $body\n }\n}\nset total 0\nfor-each-line line {hello world foo} {\n incr total [string length $line]\n}\nset total") + :result) + "13") + (ok + "classic-assert" + (get + (run "proc assert {expr_str} {\n set result [uplevel 1 [list expr $expr_str]]\n if {!$result} {\n error \"Assertion failed: $expr_str\"\n }\n}\nset x 42\nassert {$x == 42}\nassert {$x > 0}\nset x 10\nassert {$x < 100}\nset x") + :result) + "10") + (ok + "classic-with-temp-var" + (get + (run "proc with-temp-var {varname tempval body} {\n upvar 1 $varname v\n set saved $v\n set v $tempval\n uplevel 1 $body\n set v $saved\n}\nset x 100\nwith-temp-var x 999 {\n set captured $x\n}\nlist $x $captured") + :result) + "100 999") + (dict + "passed" + tcl-eval-pass + "failed" + tcl-eval-fail + "failures" + tcl-eval-failures))) diff --git a/lib/tcl/tests/idioms.sx b/lib/tcl/tests/idioms.sx new file mode 100644 index 00000000..1a6fac71 --- /dev/null +++ b/lib/tcl/tests/idioms.sx @@ -0,0 +1,193 @@ +; Tcl-on-SX idiom corpus (Phase 6) +; Classic Tcl idioms covering lists, dicts, procs, patterns +(define tcl-idiom-pass 0) +(define tcl-idiom-fail 0) +(define tcl-idiom-failures (list)) + +(define + tcl-idiom-assert + (fn + (label expected actual) + (if + (equal? expected actual) + (set! tcl-idiom-pass (+ tcl-idiom-pass 1)) + (begin + (set! tcl-idiom-fail (+ tcl-idiom-fail 1)) + (append! + tcl-idiom-failures + (str label ": expected=" (str expected) " got=" (str actual))))))) + +(define + tcl-run-idiom-tests + (fn + () + (set! tcl-idiom-pass 0) + (set! tcl-idiom-fail 0) + (set! tcl-idiom-failures (list)) + (define interp (fn () (make-default-tcl-interp))) + (define run (fn (src) (tcl-eval-string (interp) src))) + (define + ok + (fn (label actual expected) (tcl-idiom-assert label expected actual))) + + ; 1. lmap idiom: accumulate mapped values with foreach+lappend + (ok "idiom-lmap" + (get + (run "set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result") + :result) + "1 4 9") + + ; 2. Recursive list flatten + (ok "idiom-flatten" + (get + (run + "proc flatten {lst} { set out {}\n foreach item $lst {\n if {[llength $item] > 1} {\n foreach sub [flatten $item] { lappend out $sub }\n } else {\n lappend out $item\n }\n }\n return $out\n}\nflatten {1 {2 3} {4 {5 6}}}") + :result) + "1 2 3 4 5 6") + + ; 3. String builder accumulator + (ok "idiom-string-builder" + (get + (run "set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf") + :result) + "Hello World Tcl") + + ; 4. Default parameter via info exists + (ok "idiom-default-param" + (get + (run "if {![info exists x]} { set x 42 }\nset x") + :result) + "42") + + ; 5. Association list lookup (parallel key/value lists) + (ok "idiom-alist-lookup" + (get + (run + "set keys {a b c}\nset vals {10 20 30}\nset idx [lsearch $keys b]\nlindex $vals $idx") + :result) + "20") + + ; 6. Proc with optional args via args + (ok "idiom-optional-args" + (get + (run + "proc greet {name args} {\n set greeting \"Hello\"\n if {[llength $args] > 0} { set greeting [lindex $args 0] }\n return \"$greeting $name\"\n}\ngreet World Hi") + :result) + "Hi World") + + ; 7. Builder pattern: dict create from args + (ok "idiom-dict-builder" + (get + (run + "proc build-dict {args} { dict create {*}$args }\ndict get [build-dict name Alice age 30] name") + :result) + "Alice") + + ; 8. Loop with index using array + (ok "idiom-loop-with-index" + (get + (run + "set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)") + :result) + "b") + + ; 9. String reverse via split+lreverse+join + (ok "idiom-string-reverse" + (get + (run + "set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"") + :result) + "olleh") + + ; 10. Number to padded string + (ok "idiom-number-format" + (get (run "format \"%05d\" 42") :result) + "00042") + + ; 11. Dict comprehension pattern + (ok "idiom-dict-comprehension" + (get + (run + "set squares {}\nforeach n {1 2 3 4} { dict set squares $n [expr {$n * $n}] }\ndict get $squares 3") + :result) + "9") + + ; 12. Stack ADT using list: push/pop + (ok "idiom-stack" + (get + (run + "proc stack-push {stackvar val} { upvar $stackvar s; lappend s $val }\nproc stack-pop {stackvar} { upvar $stackvar s; set val [lindex $s end]; set s [lrange $s 0 end-1]; return $val }\nset stk {}\nstack-push stk 10\nstack-push stk 20\nstack-push stk 30\nstack-pop stk") + :result) + "30") + + ; 13. Queue ADT using list: enqueue/dequeue + (ok "idiom-queue" + (get + (run + "proc q-enq {qvar val} { upvar $qvar q; lappend q $val }\nproc q-deq {qvar} { upvar $qvar q; set val [lindex $q 0]; set q [lrange $q 1 end]; return $val }\nset q {}\nq-enq q alpha\nq-enq q beta\nq-enq q gamma\nq-deq q") + :result) + "alpha") + + ; 14. Pipeline via proc chaining + (ok "idiom-pipeline" + (get + (run + "proc double {x} { expr {$x * 2} }\nproc add1 {x} { expr {$x + 1} }\nproc pipeline {val procs} { foreach p $procs { set val [$p $val] }; return $val }\npipeline 5 {double add1 double}") + :result) + "22") + + ; 15. Memoize pattern using dict (simple cache, not recursive) + (ok "idiom-memoize" + (get + (run + "set cache {}\nproc cached-square {n} { global cache\n if {[dict exists $cache $n]} { return [dict get $cache $n] }\n set r [expr {$n * $n}]\n dict set cache $n $r\n return $r\n}\nset a [cached-square 7]\nset b [cached-square 7]\nset c [cached-square 8]\nexpr {$a == $b && $c == 64}") + :result) + "1") + + ; 16. Simple expression evaluator in Tcl (recursive descent) + (ok "idiom-recursive-eval" + (get + (run + "proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}") + :result) + "11") + + ; 17. Apply proc to each pair in a dict + (ok "idiom-dict-for" + (get + (run + "set d [dict create a 1 b 2 c 3]\nset total 0\ndict for {k v} $d { incr total $v }\nset total") + :result) + "6") + + ; 18. Find max in list + (ok "idiom-find-max" + (get + (run + "proc list-max {lst} {\n set m [lindex $lst 0]\n foreach x $lst { if {$x > $m} { set m $x } }\n return $m\n}\nlist-max {3 1 4 1 5 9 2 6}") + :result) + "9") + + ; 19. Filter list by predicate + (ok "idiom-filter-list" + (get + (run + "proc list-filter {lst pred} {\n set out {}\n foreach x $lst { if {[$pred $x]} { lappend out $x } }\n return $out\n}\nproc is-even {n} { expr {$n % 2 == 0} }\nlist-filter {1 2 3 4 5 6} is-even") + :result) + "2 4 6") + + ; 20. Zip two lists + (ok "idiom-zip" + (get + (run + "proc zip {a b} {\n set out {}\n set n [llength $a]\n for {set i 0} {$i < $n} {incr i} {\n lappend out [lindex $a $i]\n lappend out [lindex $b $i]\n }\n return $out\n}\nzip {1 2 3} {a b c}") + :result) + "1 a 2 b 3 c") + + (dict + "passed" + tcl-idiom-pass + "failed" + tcl-idiom-fail + "failures" + tcl-idiom-failures))) diff --git a/lib/tcl/tests/namespace.sx b/lib/tcl/tests/namespace.sx new file mode 100644 index 00000000..77f5ffd9 --- /dev/null +++ b/lib/tcl/tests/namespace.sx @@ -0,0 +1,147 @@ +; Tcl-on-SX namespace tests (Phase 5) +(define tcl-ns-pass 0) +(define tcl-ns-fail 0) +(define tcl-ns-failures (list)) + +(define + tcl-ns-assert + (fn + (label expected actual) + (if + (equal? expected actual) + (set! tcl-ns-pass (+ tcl-ns-pass 1)) + (begin + (set! tcl-ns-fail (+ tcl-ns-fail 1)) + (append! + tcl-ns-failures + (str label ": expected=" (str expected) " got=" (str actual))))))) + +(define + tcl-run-namespace-tests + (fn + () + (set! tcl-ns-pass 0) + (set! tcl-ns-fail 0) + (set! tcl-ns-failures (list)) + (define interp (fn () (make-default-tcl-interp))) + (define run (fn (src) (tcl-eval-string (interp) src))) + (define + ok + (fn (label actual expected) (tcl-ns-assert label expected actual))) + (define + ok? + (fn (label condition) (tcl-ns-assert label true condition))) + + ; --- namespace current --- + (ok "ns-current-global" + (get (run "namespace current") :result) + "::") + + ; --- namespace eval defines proc --- + (ok "ns-eval-proc-result" + (get (run "namespace eval myns { proc foo {} { return bar } }\nmyns::foo") :result) + "bar") + + ; --- fully qualified call --- + (ok "ns-qualified-call" + (get (run "namespace eval myns { proc greet {name} { return \"hello $name\" } }\n::myns::greet World") :result) + "hello World") + + ; --- namespace current inside eval --- + (ok "ns-current-inside" + (get (run "namespace eval myns { namespace current }") :result) + "::myns") + + ; --- namespace current restored after eval --- + (ok "ns-current-restored" + (get (run "namespace eval myns { set x 1 }\nnamespace current") :result) + "::") + + ; --- relative call from within namespace --- + (ok "ns-relative-call" + (get (run "namespace eval math {\n proc double {x} { expr {$x * 2} }\n proc quad {x} { double [double $x] }\n}\nmath::quad 3") :result) + "12") + + ; --- proc defined as qualified name inside namespace eval --- + (ok "ns-qualified-proc-name" + (get (run "namespace eval utils { proc ::utils::helper {x} { return $x } }\n::utils::helper done") :result) + "done") + + ; --- namespace exists --- + (ok "ns-exists-yes" + (get (run "namespace eval testns { proc p {} {} }\nnamespace exists testns") :result) + "1") + + (ok "ns-exists-no" + (get (run "namespace exists nosuchns") :result) + "0") + + (ok "ns-exists-global" + (get (run "proc top {} {}\nnamespace exists ::") :result) + "1") + + ; --- namespace delete --- + (ok "ns-delete-removes" + (get (run "namespace eval todel { proc pp {} { return yes } }\nnamespace delete todel\nnamespace exists todel") :result) + "0") + + ; --- namespace which --- + (ok "ns-which-found" + (get (run "namespace eval wns { proc wfn {} {} }\nnamespace which -command wns::wfn") :result) + "::wns::wfn") + + (ok "ns-which-not-found" + (get (run "namespace which -command nosuchfn") :result) + "") + + ; --- namespace ensemble create auto-map --- + (ok "ns-ensemble-add" + (get (run "namespace eval mymath {\n proc add {a b} { expr {$a + $b} }\n proc mul {a b} { expr {$a * $b} }\n namespace ensemble create\n}\nmymath add 3 4") :result) + "7") + + (ok "ns-ensemble-mul" + (get (run "namespace eval mymath {\n proc add {a b} { expr {$a + $b} }\n proc mul {a b} { expr {$a * $b} }\n namespace ensemble create\n}\nmymath mul 3 4") :result) + "12") + + ; --- namespace ensemble with -map --- + (ok "ns-ensemble-map" + (get (run "namespace eval ops {\n proc do-add {a b} { expr {$a + $b} }\n namespace ensemble create -map {plus ::ops::do-add}\n}\nops plus 5 6") :result) + "11") + + ; --- proc inside namespace eval with args --- + (ok "ns-proc-args" + (get (run "namespace eval calc {\n proc sum {a b c} { expr {$a + $b + $c} }\n}\ncalc::sum 1 2 3") :result) + "6") + + ; --- info procs inside namespace --- + (ok? "ns-info-procs-in-ns" + (let + ((r (get (run "namespace eval foo { proc bar {} {} }\nnamespace eval foo { info procs }") :result))) + (contains? (tcl-list-split r) "bar"))) + + ; --- variable inside namespace eval --- + (ok "ns-variable-inside" + (get (run "namespace eval storage {\n variable count 0\n proc bump {} { global count\n incr count\n return $count }\n}\n::storage::bump\n::storage::bump") :result) + "2") + + ; --- nested namespaces --- + (ok "ns-nested" + (get (run "namespace eval outer {\n namespace eval inner {\n proc greet {} { return nested }\n }\n}\n::outer::inner::greet") :result) + "nested") + + ; --- namespace eval accumulates procs --- + (ok "ns-eval-accumulate" + (get (run "namespace eval acc { proc f1 {} { return one } }\nnamespace eval acc { proc f2 {} { return two } }\nacc::f1") :result) + "one") + + (ok "ns-eval-accumulate-2" + (get (run "namespace eval acc { proc f1 {} { return one } }\nnamespace eval acc { proc f2 {} { return two } }\nacc::f2") :result) + "two") + + (dict + "passed" + tcl-ns-pass + "failed" + tcl-ns-fail + "failures" + tcl-ns-failures))) diff --git a/lib/tcl/tests/parse.sx b/lib/tcl/tests/parse.sx new file mode 100644 index 00000000..0e9df378 --- /dev/null +++ b/lib/tcl/tests/parse.sx @@ -0,0 +1,186 @@ +(define tcl-parse-pass 0) +(define tcl-parse-fail 0) +(define tcl-parse-failures (list)) + +(define tcl-assert + (fn (label expected actual) + (if (= expected actual) + (set! tcl-parse-pass (+ tcl-parse-pass 1)) + (begin + (set! tcl-parse-fail (+ tcl-parse-fail 1)) + (append! tcl-parse-failures + (str label ": expected=" (str expected) " got=" (str actual))))))) + +(define tcl-first-cmd + (fn (src) (nth (tcl-tokenize src) 0))) + +(define tcl-cmd-words + (fn (src) (get (tcl-first-cmd src) :words))) + +(define tcl-word + (fn (src wi) (nth (tcl-cmd-words src) wi))) + +(define tcl-parts + (fn (src wi) (get (tcl-word src wi) :parts))) + +(define tcl-part + (fn (src wi pi) (nth (tcl-parts src wi) pi))) + +(define tcl-run-parse-tests + (fn () + (set! tcl-parse-pass 0) + (set! tcl-parse-fail 0) + (set! tcl-parse-failures (list)) + + ; empty / whitespace-only + (tcl-assert "empty" 0 (len (tcl-tokenize ""))) + (tcl-assert "ws-only" 0 (len (tcl-tokenize " "))) + (tcl-assert "nl-only" 0 (len (tcl-tokenize "\n\n"))) + + ; single command word count + (tcl-assert "1word" 1 (len (tcl-cmd-words "set"))) + (tcl-assert "3words" 3 (len (tcl-cmd-words "set x 1"))) + (tcl-assert "4words" 4 (len (tcl-cmd-words "set a b c"))) + + ; word type — bare word is compound + (tcl-assert "bare-type" "compound" (get (tcl-word "set x 1" 0) :type)) + (tcl-assert "bare-quoted" false (get (tcl-word "set x 1" 0) :quoted)) + (tcl-assert "bare-part-type" "text" (get (tcl-part "set x 1" 0 0) :type)) + (tcl-assert "bare-part-val" "set" (get (tcl-part "set x 1" 0 0) :value)) + (tcl-assert "bare-part2-val" "x" (get (tcl-part "set x 1" 1 0) :value)) + (tcl-assert "bare-part3-val" "1" (get (tcl-part "set x 1" 2 0) :value)) + + ; multiple commands + (tcl-assert "semi-sep" 2 (len (tcl-tokenize "set x 1; set y 2"))) + (tcl-assert "nl-sep" 2 (len (tcl-tokenize "set x 1\nset y 2"))) + (tcl-assert "multi-nl" 3 (len (tcl-tokenize "a\nb\nc"))) + + ; comments + (tcl-assert "comment-only" 0 (len (tcl-tokenize "# comment"))) + (tcl-assert "comment-nl" 0 (len (tcl-tokenize "# comment\n"))) + (tcl-assert "comment-then-cmd" 1 (len (tcl-tokenize "# comment\nset x 1"))) + (tcl-assert "semi-then-comment" 1 (len (tcl-tokenize "set x 1; # comment"))) + + ; brace-quoted words + (tcl-assert "brace-type" "braced" (get (tcl-word "{hello}" 0) :type)) + (tcl-assert "brace-value" "hello" (get (tcl-word "{hello}" 0) :value)) + (tcl-assert "brace-spaces" "hello world" (get (tcl-word "{hello world}" 0) :value)) + (tcl-assert "brace-nested" "a {b} c" (get (tcl-word "{a {b} c}" 0) :value)) + (tcl-assert "brace-no-var-sub" "hello $x" (get (tcl-word "{hello $x}" 0) :value)) + (tcl-assert "brace-no-cmd-sub" "[expr 1]" (get (tcl-word "{[expr 1]}" 0) :value)) + + ; double-quoted words + (tcl-assert "dq-type" "compound" (get (tcl-word "\"hello\"" 0) :type)) + (tcl-assert "dq-quoted" true (get (tcl-word "\"hello\"" 0) :quoted)) + (tcl-assert "dq-literal" "hello" (get (tcl-part "\"hello\"" 0 0) :value)) + + ; variable substitution in bare word + (tcl-assert "var-type" "var" (get (tcl-part "$x" 0 0) :type)) + (tcl-assert "var-name" "x" (get (tcl-part "$x" 0 0) :name)) + (tcl-assert "var-long" "long_name" (get (tcl-part "$long_name" 0 0) :name)) + + ; ${name} form + (tcl-assert "var-brace-type" "var" (get (tcl-part "${x}" 0 0) :type)) + (tcl-assert "var-brace-name" "x" (get (tcl-part "${x}" 0 0) :name)) + + ; array variable substitution + (tcl-assert "arr-type" "var-arr" (get (tcl-part "$arr(key)" 0 0) :type)) + (tcl-assert "arr-name" "arr" (get (tcl-part "$arr(key)" 0 0) :name)) + (tcl-assert "arr-key-len" 1 (len (get (tcl-part "$arr(key)" 0 0) :key))) + (tcl-assert "arr-key-text" "key" + (get (nth (get (tcl-part "$arr(key)" 0 0) :key) 0) :value)) + + ; command substitution + (tcl-assert "cmd-type" "cmd" (get (tcl-part "[expr 1+1]" 0 0) :type)) + (tcl-assert "cmd-src" "expr 1+1" (get (tcl-part "[expr 1+1]" 0 0) :src)) + + ; nested command substitution + (tcl-assert "cmd-nested-src" "expr [string length x]" + (get (tcl-part "[expr [string length x]]" 0 0) :src)) + + ; backslash substitution in double-quoted word + (let ((ps (tcl-parts "\"a\\nb\"" 0))) + (begin + (tcl-assert "bs-n-part0" "a" (get (nth ps 0) :value)) + (tcl-assert "bs-n-part1" "\n" (get (nth ps 1) :value)) + (tcl-assert "bs-n-part2" "b" (get (nth ps 2) :value)))) + + (let ((ps (tcl-parts "\"a\\tb\"" 0))) + (tcl-assert "bs-t-part1" "\t" (get (nth ps 1) :value))) + + (let ((ps (tcl-parts "\"a\\\\b\"" 0))) + (tcl-assert "bs-bs-part1" "\\" (get (nth ps 1) :value))) + + ; mixed word: text + var + text in double-quoted + (let ((ps (tcl-parts "\"hello $name!\"" 0))) + (begin + (tcl-assert "mixed-text0" "hello " (get (nth ps 0) :value)) + (tcl-assert "mixed-var1-type" "var" (get (nth ps 1) :type)) + (tcl-assert "mixed-var1-name" "name" (get (nth ps 1) :name)) + (tcl-assert "mixed-text2" "!" (get (nth ps 2) :value)))) + + ; {*} expansion + (tcl-assert "expand-type" "expand" (get (tcl-word "{*}$list" 0) :type)) + + ; line continuation between words + (tcl-assert "cont-words" 3 (len (tcl-cmd-words "set x \\\n 1"))) + + ; continuation — third command word is correct + (tcl-assert "cont-word2-val" "1" + (get (tcl-part "set x \\\n 1" 2 0) :value)) + + + ; --- parser helpers --- + ; tcl-parse is an alias for tcl-tokenize + (tcl-assert "parse-cmd-count" 1 (len (tcl-parse "set x 1"))) + (tcl-assert "parse-2cmds" 2 (len (tcl-parse "set x 1; set y 2"))) + + ; tcl-cmd-len + (tcl-assert "cmd-len-3" 3 (tcl-cmd-len (nth (tcl-parse "set x 1") 0))) + (tcl-assert "cmd-len-1" 1 (tcl-cmd-len (nth (tcl-parse "puts") 0))) + + ; tcl-word-simple? on braced word + (tcl-assert "simple-braced" true + (tcl-word-simple? (nth (get (nth (tcl-parse "{hello}") 0) :words) 0))) + + ; tcl-word-simple? on bare word with no subs + (tcl-assert "simple-bare" true + (tcl-word-simple? (nth (get (nth (tcl-parse "hello") 0) :words) 0))) + + ; tcl-word-simple? on word containing a var sub — false + (tcl-assert "simple-var-false" false + (tcl-word-simple? (nth (get (nth (tcl-parse "$x") 0) :words) 0))) + + ; tcl-word-simple? on word containing a cmd sub — false + (tcl-assert "simple-cmd-false" false + (tcl-word-simple? (nth (get (nth (tcl-parse "[expr 1]") 0) :words) 0))) + + ; tcl-word-literal on braced word + (tcl-assert "lit-braced" "hello world" + (tcl-word-literal (nth (get (nth (tcl-parse "{hello world}") 0) :words) 0))) + + ; tcl-word-literal on bare word + (tcl-assert "lit-bare" "hello" + (tcl-word-literal (nth (get (nth (tcl-parse "hello") 0) :words) 0))) + + ; tcl-word-literal on word with var sub returns nil + (tcl-assert "lit-var-nil" nil + (tcl-word-literal (nth (get (nth (tcl-parse "$x") 0) :words) 0))) + + ; tcl-nth-literal + (tcl-assert "nth-lit-0" "set" + (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 0)) + (tcl-assert "nth-lit-1" "x" + (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 1)) + (tcl-assert "nth-lit-2" "1" + (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 2)) + + ; tcl-nth-literal returns nil when word has subs + (tcl-assert "nth-lit-nil" nil + (tcl-nth-literal (nth (tcl-parse "set x $y") 0) 2)) + + + (dict + "passed" tcl-parse-pass + "failed" tcl-parse-fail + "failures" tcl-parse-failures))) diff --git a/lib/tcl/tests/programs/assert.tcl b/lib/tcl/tests/programs/assert.tcl new file mode 100644 index 00000000..5f745d90 --- /dev/null +++ b/lib/tcl/tests/programs/assert.tcl @@ -0,0 +1,14 @@ +# expected: 10 +proc assert {expr_str} { + set result [uplevel 1 [list expr $expr_str]] + if {!$result} { + error "Assertion failed: $expr_str" + } +} + +set x 42 +assert {$x == 42} +assert {$x > 0} +set x 10 +assert {$x < 100} +set x diff --git a/lib/tcl/tests/programs/event-loop.tcl b/lib/tcl/tests/programs/event-loop.tcl new file mode 100644 index 00000000..713ef384 --- /dev/null +++ b/lib/tcl/tests/programs/event-loop.tcl @@ -0,0 +1,22 @@ +# expected: done +# Cooperative scheduler demo using coroutines (generator style) +# coroutine eagerly collects all yields; invoking the coroutine name pops values + +proc counter {n max} { + while {$n < $max} { + yield $n + incr n + } + yield done +} + +coroutine gen1 counter 0 3 + +# gen1 yields: 0 1 2 done +set out {} +for {set i 0} {$i < 4} {incr i} { + lappend out [gen1] +} + +# last val is "done" +lindex $out 3 diff --git a/lib/tcl/tests/programs/for-each-line.tcl b/lib/tcl/tests/programs/for-each-line.tcl new file mode 100644 index 00000000..0fd44d92 --- /dev/null +++ b/lib/tcl/tests/programs/for-each-line.tcl @@ -0,0 +1,14 @@ +# expected: 13 +proc for-each-line {var lines body} { + foreach item $lines { + uplevel 1 [list set $var $item] + uplevel 1 $body + } +} + +# Usage: accumulate lengths of each "line" +set total 0 +for-each-line line {hello world foo} { + incr total [string length $line] +} +set total diff --git a/lib/tcl/tests/programs/with-temp-var.tcl b/lib/tcl/tests/programs/with-temp-var.tcl new file mode 100644 index 00000000..cec3e792 --- /dev/null +++ b/lib/tcl/tests/programs/with-temp-var.tcl @@ -0,0 +1,14 @@ +# expected: 100 999 +proc with-temp-var {varname tempval body} { + upvar 1 $varname v + set saved $v + set v $tempval + uplevel 1 $body + set v $saved +} + +set x 100 +with-temp-var x 999 { + set captured $x +} +list $x $captured diff --git a/lib/tcl/tests/runtime.sx b/lib/tcl/tests/runtime.sx new file mode 100644 index 00000000..ccf81461 --- /dev/null +++ b/lib/tcl/tests/runtime.sx @@ -0,0 +1,146 @@ +;; lib/tcl/tests/runtime.sx — Tests for lib/tcl/runtime.sx + +(define tcl-test-pass 0) +(define tcl-test-fail 0) +(define tcl-test-fails (list)) + +(define + (tcl-test name got expected) + (if + (= got expected) + (set! tcl-test-pass (+ tcl-test-pass 1)) + (begin + (set! tcl-test-fail (+ tcl-test-fail 1)) + (set! tcl-test-fails (append tcl-test-fails (list {:got got :expected expected :name name})))))) + +;; --------------------------------------------------------------------------- +;; 1. String buffer +;; --------------------------------------------------------------------------- + +(define sb1 (tcl-sb-new)) +(tcl-test "sb? new" (tcl-sb? sb1) true) +(tcl-test "sb? non-sb" (tcl-sb? "hello") false) +(tcl-test "sb value empty" (tcl-sb-value sb1) "") +(tcl-test "sb length empty" (tcl-sb-length sb1) 0) +(tcl-sb-append! sb1 "hello") +(tcl-test "sb value after append" (tcl-sb-value sb1) "hello") +(tcl-sb-append! sb1 " ") +(tcl-sb-append! sb1 "world") +(tcl-test "sb value after multi-append" (tcl-sb-value sb1) "hello world") +(tcl-test "sb length" (tcl-sb-length sb1) 11) +(tcl-sb-clear! sb1) +(tcl-test "sb value after clear" (tcl-sb-value sb1) "") +(tcl-test "sb length after clear" (tcl-sb-length sb1) 0) + +;; --------------------------------------------------------------------------- +;; 2. String port (channel) +;; --------------------------------------------------------------------------- + +(define chin1 (tcl-chan-in-new "hello\nworld\nfoo")) +(tcl-test "chan? read" (tcl-chan? chin1) true) +(tcl-test "chan eof? no" (tcl-chan-eof? chin1) false) +(tcl-test "chan gets line1" (tcl-chan-gets chin1) "hello") +(tcl-test "chan gets line2" (tcl-chan-gets chin1) "world") +(tcl-test "chan gets line3" (tcl-chan-gets chin1) "foo") +(tcl-test "chan eof? yes" (tcl-chan-eof? chin1) true) +(tcl-test "chan gets at eof" (tcl-chan-gets chin1) "") + +(define chin2 (tcl-chan-in-new "abcdef")) +(tcl-test "chan read all" (tcl-chan-read chin2) "abcdef") +(tcl-test "chan read empty" (tcl-chan-read chin2) "") + +(define chout1 (tcl-chan-out-new)) +(tcl-test "chan? write" (tcl-chan? chout1) true) +(tcl-chan-puts! chout1 "hello") +(tcl-chan-puts! chout1 " world") +(tcl-test "chan string" (tcl-chan-string chout1) "hello world") +(tcl-chan-puts-line! chout1 "!") +(tcl-test "chan string with newline" (tcl-chan-string chout1) "hello world!\n") + +(define chout2 (tcl-chan-out-new)) +(tcl-chan-puts-line! chout2 "line1") +(tcl-chan-puts-line! chout2 "line2") +(tcl-test "chan multi-line" (tcl-chan-string chout2) "line1\nline2\n") + +;; --------------------------------------------------------------------------- +;; 3. Regexp +;; --------------------------------------------------------------------------- + +(define rx1 (tcl-re-new "hel+o")) +(tcl-test "re? yes" (tcl-re? rx1) true) +(tcl-test "re? no" (tcl-re? "hello") false) +(tcl-test "re match? yes" (tcl-re-match? rx1 "say hello") true) +(tcl-test "re match? no" (tcl-re-match? rx1 "goodbye") false) + +(define m1 (tcl-re-match rx1 "say hello world")) +(tcl-test "re match result" (get m1 "match") "hello") + +(define rx2 (tcl-re-new "[0-9]+")) +(define all (tcl-re-match-all rx2 "a1b22c333")) +(tcl-test "re match-all count" (len all) 3) +(tcl-test "re match-all last" (get (nth all 2) "match") "333") + +(tcl-test "re sub" (tcl-re-sub rx2 "a1b2" "N") "aNb2") +(tcl-test "re sub-all" (tcl-re-sub-all rx2 "a1b2" "N") "aNbN") + +(define rx3 (tcl-re-new "[ ,]+")) +(tcl-test "re split" (tcl-re-split rx3 "a b,c") (list "a" "b" "c")) + +;; --------------------------------------------------------------------------- +;; 4. Format +;; --------------------------------------------------------------------------- + +(tcl-test "format %s" (tcl-format "hello %s" (list "world")) "hello world") +(tcl-test "format %d" (tcl-format "n=%d" (list 42)) "n=42") +(tcl-test "format %d truncates float" (tcl-format "n=%d" (list 3.9)) "n=3") +(tcl-test + "format %s %d" + (tcl-format "%s is %d" (list "age" 30)) + "age is 30") +(tcl-test "format %%" (tcl-format "100%% done" (list)) "100% done") +(tcl-test "format %x" (tcl-format "%x" (list 255)) "ff") +(tcl-test "format %x 16" (tcl-format "0x%x" (list 16)) "0x10") +(tcl-test "format %o" (tcl-format "%o" (list 8)) "10") +(tcl-test "format %o 255" (tcl-format "%o" (list 255)) "377") +(tcl-test "format no spec" (tcl-format "plain text" (list)) "plain text") +(tcl-test + "format multiple" + (tcl-format "%s=%d (0x%x)" (list "val" 255 255)) + "val=255 (0xff)") + +;; --------------------------------------------------------------------------- +;; 5. Coroutine +;; tcl-co-yield works from top-level helper functions. +;; --------------------------------------------------------------------------- + +(define + co1 + (tcl-co-new + (fn () (tcl-co-yield 1) (tcl-co-yield 2) 3))) + +(tcl-test "co? yes" (tcl-co? co1) true) +(tcl-test "co? no" (tcl-co? 42) false) +(tcl-test "co alive? before" (tcl-co-alive? co1) true) +(define cor1 (tcl-co-resume co1)) +(tcl-test "co resume 1" cor1 1) +(tcl-test "co alive? mid" (tcl-co-alive? co1) true) +(define cor2 (tcl-co-resume co1)) +(tcl-test "co resume 2" cor2 2) +(define cor3 (tcl-co-resume co1)) +(tcl-test "co resume 3 completion" cor3 3) +(tcl-test "co alive? dead" (tcl-co-alive? co1) false) + +;; Top-level helper for recursive yield (avoids JIT letrec limitation) +(define + (tcl-co-count-down i) + (when + (>= i 1) + (tcl-co-yield i) + (tcl-co-count-down (- i 1)))) + +(define co2 (tcl-co-new (fn () (tcl-co-count-down 3) "done"))) +(tcl-test "co loop 3" (tcl-co-resume co2) 3) +(tcl-test "co loop 2" (tcl-co-resume co2) 2) +(tcl-test "co loop 1" (tcl-co-resume co2) 1) +(tcl-test "co loop done" (tcl-co-resume co2) "done") +(tcl-test "co loop dead" (tcl-co-alive? co2) false) diff --git a/lib/tcl/tokenizer.sx b/lib/tcl/tokenizer.sx new file mode 100644 index 00000000..6ad455ac --- /dev/null +++ b/lib/tcl/tokenizer.sx @@ -0,0 +1,308 @@ +(define tcl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\r")))) + +(define tcl-alpha? + (fn (c) + (and + (not (= c nil)) + (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))) + +(define tcl-digit? + (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9")))) + +(define tcl-ident-start? + (fn (c) (or (tcl-alpha? c) (= c "_")))) + +(define tcl-ident-char? + (fn (c) (or (tcl-ident-start? c) (tcl-digit? c)))) + +(define tcl-tokenize + (fn (src) + (let ((pos 0) (src-len (len src)) (commands (list))) + + (define char-at + (fn (off) + (if (< (+ pos off) src-len) (nth src (+ pos off)) nil))) + + (define cur (fn () (char-at 0))) + + (define advance! (fn (n) (set! pos (+ pos n)))) + + (define skip-ws! + (fn () + (when (tcl-ws? (cur)) + (begin (advance! 1) (skip-ws!))))) + + (define skip-to-eol! + (fn () + (when (and (< pos src-len) (not (= (cur) "\n"))) + (begin (advance! 1) (skip-to-eol!))))) + + (define skip-brace-content! + (fn (d) + (when (and (< pos src-len) (> d 0)) + (cond + ((= (cur) "{") (begin (advance! 1) (skip-brace-content! (+ d 1)))) + ((= (cur) "}") (begin (advance! 1) (skip-brace-content! (- d 1)))) + (else (begin (advance! 1) (skip-brace-content! d))))))) + + (define skip-dquote-content! + (fn () + (when (and (< pos src-len) (not (= (cur) "\""))) + (begin + (when (= (cur) "\\") (advance! 1)) + (when (< pos src-len) (advance! 1)) + (skip-dquote-content!))))) + + (define parse-bs + (fn () + (advance! 1) + (let ((c (cur))) + (cond + ((= c nil) "\\") + ((= c "n") (begin (advance! 1) "\n")) + ((= c "t") (begin (advance! 1) "\t")) + ((= c "r") (begin (advance! 1) "\r")) + ((= c "\\") (begin (advance! 1) "\\")) + ((= c "[") (begin (advance! 1) "[")) + ((= c "]") (begin (advance! 1) "]")) + ((= c "{") (begin (advance! 1) "{")) + ((= c "}") (begin (advance! 1) "}")) + ((= c "$") (begin (advance! 1) "$")) + ((= c ";") (begin (advance! 1) ";")) + ((= c "\"") (begin (advance! 1) "\"")) + ((= c "'") (begin (advance! 1) "'")) + ((= c " ") (begin (advance! 1) " ")) + ((= c "\n") + (begin + (advance! 1) + (skip-ws!) + " ")) + (else (begin (advance! 1) (str "\\" c))))))) + + (define parse-cmd-sub + (fn () + (advance! 1) + (let ((start pos) (depth 1)) + (define scan! + (fn () + (when (and (< pos src-len) (> depth 0)) + (cond + ((= (cur) "[") + (begin (set! depth (+ depth 1)) (advance! 1) (scan!))) + ((= (cur) "]") + (begin + (set! depth (- depth 1)) + (when (> depth 0) (advance! 1)) + (scan!))) + ((= (cur) "{") + (begin (advance! 1) (skip-brace-content! 1) (scan!))) + ((= (cur) "\"") + (begin + (advance! 1) + (skip-dquote-content!) + (when (= (cur) "\"") (advance! 1)) + (scan!))) + ((= (cur) "\\") + (begin (advance! 1) (when (< pos src-len) (advance! 1)) (scan!))) + (else (begin (advance! 1) (scan!))))))) + (scan!) + (let ((src-text (slice src start pos))) + (begin + (when (= (cur) "]") (advance! 1)) + {:type "cmd" :src src-text}))))) + + (define scan-name! + (fn () + (when (and (< pos src-len) (not (= (cur) "}"))) + (begin (advance! 1) (scan-name!))))) + + (define scan-ns-name! + (fn () + (cond + ((tcl-ident-char? (cur)) + (begin (advance! 1) (scan-ns-name!))) + ((and (= (cur) ":") (= (char-at 1) ":")) + (begin (advance! 2) (scan-ns-name!))) + (else nil)))) + + (define scan-klit! + (fn () + (when (and (< pos src-len) + (not (= (cur) ")")) + (not (= (cur) "$")) + (not (= (cur) "[")) + (not (= (cur) "\\"))) + (begin (advance! 1) (scan-klit!))))) + + (define scan-key! + (fn (kp) + (when (and (< pos src-len) (not (= (cur) ")"))) + (cond + ((= (cur) "$") + (begin (append! kp (parse-var-sub)) (scan-key! kp))) + ((= (cur) "[") + (begin (append! kp (parse-cmd-sub)) (scan-key! kp))) + ((= (cur) "\\") + (begin + (append! kp {:type "text" :value (parse-bs)}) + (scan-key! kp))) + (else + (let ((kstart pos)) + (begin + (scan-klit!) + (append! kp {:type "text" :value (slice src kstart pos)}) + (scan-key! kp)))))))) + + (define parse-var-sub + (fn () + (advance! 1) + (cond + ((= (cur) "{") + (begin + (advance! 1) + (let ((start pos)) + (begin + (scan-name!) + (let ((name (slice src start pos))) + (begin + (when (= (cur) "}") (advance! 1)) + {:type "var" :name name})))))) + ((tcl-ident-start? (cur)) + (let ((start pos)) + (begin + (scan-ns-name!) + (let ((name (slice src start pos))) + (if (= (cur) "(") + (begin + (advance! 1) + (let ((key-parts (list))) + (begin + (scan-key! key-parts) + (when (= (cur) ")") (advance! 1)) + {:type "var-arr" :name name :key key-parts}))) + {:type "var" :name name}))))) + (else {:type "text" :value "$"})))) + + (define scan-lit! + (fn (stop?) + (when (and (< pos src-len) + (not (stop? (cur))) + (not (= (cur) "$")) + (not (= (cur) "[")) + (not (= (cur) "\\"))) + (begin (advance! 1) (scan-lit! stop?))))) + + (define parse-word-parts! + (fn (parts stop?) + (when (and (< pos src-len) (not (stop? (cur)))) + (cond + ((= (cur) "$") + (begin (append! parts (parse-var-sub)) (parse-word-parts! parts stop?))) + ((= (cur) "[") + (begin (append! parts (parse-cmd-sub)) (parse-word-parts! parts stop?))) + ((= (cur) "\\") + (begin + (append! parts {:type "text" :value (parse-bs)}) + (parse-word-parts! parts stop?))) + (else + (let ((start pos)) + (begin + (scan-lit! stop?) + (when (> pos start) + (append! parts {:type "text" :value (slice src start pos)})) + (parse-word-parts! parts stop?)))))))) + + (define parse-brace-word + (fn () + (advance! 1) + (let ((depth 1) (start pos)) + (define scan! + (fn () + (when (and (< pos src-len) (> depth 0)) + (cond + ((= (cur) "{") + (begin (set! depth (+ depth 1)) (advance! 1) (scan!))) + ((= (cur) "}") + (begin (set! depth (- depth 1)) (when (> depth 0) (advance! 1)) (scan!))) + (else (begin (advance! 1) (scan!))))))) + (scan!) + (let ((value (slice src start pos))) + (begin + (when (= (cur) "}") (advance! 1)) + {:type "braced" :value value}))))) + + (define parse-dquote-word + (fn () + (advance! 1) + (let ((parts (list))) + (begin + (parse-word-parts! parts (fn (c) (or (= c "\"") (= c nil)))) + (when (= (cur) "\"") (advance! 1)) + {:type "compound" :parts parts :quoted true})))) + + (define parse-bare-word + (fn () + (let ((parts (list))) + (begin + (parse-word-parts! + parts + (fn (c) (or (tcl-ws? c) (= c "\n") (= c ";") (= c nil)))) + {:type "compound" :parts parts :quoted false})))) + + (define parse-word-no-expand + (fn () + (cond + ((= (cur) "{") (parse-brace-word)) + ((= (cur) "\"") (parse-dquote-word)) + (else (parse-bare-word))))) + + (define parse-word + (fn () + (cond + ((and (= (cur) "{") (= (char-at 1) "*") (= (char-at 2) "}")) + (begin + (advance! 3) + {:type "expand" :word (parse-word-no-expand)})) + ((= (cur) "{") (parse-brace-word)) + ((= (cur) "\"") (parse-dquote-word)) + (else (parse-bare-word))))) + + (define parse-words! + (fn (words) + (skip-ws!) + (cond + ((or (= (cur) nil) (= (cur) "\n") (= (cur) ";")) nil) + ((and (= (cur) "\\") (= (char-at 1) "\n")) + (begin (advance! 2) (skip-ws!) (parse-words! words))) + (else + (begin + (append! words (parse-word)) + (parse-words! words)))))) + + (define skip-seps! + (fn () + (when (< pos src-len) + (cond + ((or (tcl-ws? (cur)) (= (cur) "\n") (= (cur) ";")) + (begin (advance! 1) (skip-seps!))) + ((and (= (cur) "\\") (= (char-at 1) "\n")) + (begin (advance! 2) (skip-seps!))) + (else nil))))) + + (define parse-all! + (fn () + (skip-seps!) + (when (< pos src-len) + (cond + ((= (cur) "#") + (begin (skip-to-eol!) (parse-all!))) + (else + (let ((words (list))) + (begin + (parse-words! words) + (when (> (len words) 0) + (append! commands {:type "command" :words words})) + (parse-all!)))))))) + + (parse-all!) + commands))) diff --git a/plans/agent-briefings/primitives-loop.md b/plans/agent-briefings/primitives-loop.md new file mode 100644 index 00000000..c2fa7d23 --- /dev/null +++ b/plans/agent-briefings/primitives-loop.md @@ -0,0 +1,789 @@ +# SX Primitives — Meta-Loop Briefing + +Goal: add fundamental missing SX primitives in sequence, then sweep all language +implementations to replace their workarounds. Full rationale: vectors fix O(n) array +access across every language; numeric tower fixes float/int conflation; dynamic-wind +fixes cleanup semantics; coroutine primitive unifies Ruby/Lua/Tcl; string buffer fixes +O(n²) concat; algebraic data types eliminate the tagged-dict pattern everywhere. + +**Each fire: find the first unchecked `[ ]`, do it, commit, tick it, stop.** +Sub-items within a Phase may span multiple fires — just commit progress and tick what's done. + +--- + +## Phase 0 — Prep (gate) + +- [x] Stop new-language loops: send `/exit` to sx-loops windows for the four blank-slate + languages that haven't committed workarounds yet: + ``` + tmux send-keys -t sx-loops:common-lisp "/exit" Enter + tmux send-keys -t sx-loops:apl "/exit" Enter + tmux send-keys -t sx-loops:ruby "/exit" Enter + tmux send-keys -t sx-loops:tcl "/exit" Enter + ``` + Verify all four windows are idle (claude prompt, no active task). + +- [x] E38 + E39 landed: check both Bucket-E branches for implementation commits. + ``` + git log --oneline hs-e38-sourceinfo | head -5 + git log --oneline hs-e39-webworker | head -5 + ``` + If either branch has only its base commit (no impl work yet): note "pending" and stop — + next fire re-checks. Proceed only when both have at least one implementation commit. + +--- + +## Phase 1 — Vectors + +Native mutable integer-indexed arrays. Fix: Lua O(n) sort, APL rank polymorphism, Ruby +Array, Tcl lists, Common Lisp vectors, all using string-keyed dicts today. + +Primitives to add: +- `make-vector` `n` `[fill]` → vector of length n +- `vector?` `v` → bool +- `vector-ref` `v` `i` → element at index i (0-based) +- `vector-set!` `v` `i` `x` → mutate in place +- `vector-length` `v` → integer +- `vector->list` `v` → list +- `list->vector` `lst` → vector +- `vector-fill!` `v` `x` → fill all elements +- `vector-copy` `v` `[start]` `[end]` → fresh copy of slice + +Steps: +- [x] OCaml: add `SxVector of value array` to `hosts/ocaml/sx_types.ml`; implement all + primitives in `hosts/ocaml/sx_primitives.ml` (or equivalent); wire into evaluator. + Note: Vector type + most prims were already present; added bounds-checked vector-ref/set! + and optional start/end to vector-copy. 10/10 vector tests pass (r7rs suite). +- [x] Spec: add vector entries to `spec/primitives.sx` with type signatures and descriptions. + All 10 vector primitives now have :as type annotations, :returns, and :doc strings. + make-vector: optional fill param; vector-copy: optional start/end (done prev step). +- [x] JS bootstrapper: implement vectors in `hosts/javascript/platform.js` (or equivalent); + ensure `sx-browser.js` rebuild picks them up. + Fixed index-of for lists (was returning -1 not NIL, breaking bind-lambda-params), + added _lastErrorKont_/hostError/try-catch/without-io-hook stubs. Vectors work. +- [x] Tests: 40+ tests in `spec/tests/test-vectors.sx` covering construction, ref, set!, + length, conversions, fill, copy, bounds behaviour. + 42 tests, all pass. 1847 standard / 2362 full passing (up from 5). +- [x] Verify: full test suite still passes (`node hosts/javascript/run_tests.js --full`). + 2362/4924 pass (improvement from pre-existing lambda binding bug, no regressions). +- [x] Commit: `spec: vector primitive (make-vector/vector-ref/vector-set!/etc)` + Committed as: js: fix lambda binding (index-of on lists), add vectors + R7RS platform stubs + +--- + +## Phase 2 — Numeric tower + +Float ≠ integer distinction. Fix: Erlang `=:=`, Lua `math.type()`, Haskell `Num`/`Integral`, +Common Lisp `integerp`/`floatp`/`ratio`, JS `Number.isInteger`. + +Changes: +- `parse-number` preserves float identity: `"1.0"` → float 1.0, not integer 1 +- New predicates: `integer?`, `float?`, `exact?`, `inexact?` +- New coercions: `exact->inexact`, `inexact->exact` +- Fix `floor`/`ceiling`/`truncate`/`round` to return integers when applied to floats +- `number->string` renders `1.0` as `"1.0"`, `1` as `"1"` +- Arithmetic: `(+ 1 1.0)` → `2.0` (float contagion), `(+ 1 1)` → `2` (integer) + +Steps: +- [x] OCaml: distinguish `Integer of int` / `Number of float` in `sx_types.ml`; update all + arithmetic primitives for float contagion; fix `parse-number`. + 92/92 numeric tower tests pass; 4874 total (394 pre-existing hs-upstream fails unchanged). +- [x] Spec: update `spec/primitives.sx` with new predicates + coercions; document contagion rules. + Added integer?/float? predicates; updated number? body; / returns "float"; floor/ceil/truncate + return "integer"; +/-/* doc float contagion; fixed double-paren params; 4874/394 baseline. +- [x] JS bootstrapper: update number representation and arithmetic. + Added integer?/float?/exact?/inexact?/truncate/remainder/modulo/random-int/exact->inexact/ + inexact->exact/parse-number. Fixed sx_server.ml epoch protocol for Integer type. + JS: 1940 passed (+60); OCaml: 4874/394 unchanged. 6 tests JS-only fail (float≡int limitation). +- [x] Tests: 92 tests in `spec/tests/test-numeric-tower.sx` — int-arithmetic, float-contagion, + division, predicates, coercions, rounding, parse-number, equality, modulo, min-max, stringify. +- [x] Verify: full suite passes. OCaml 4874/394 (baseline unchanged). JS 1940/2500 (+60 vs pre-tower). + No regressions on any test that relied on `1.0 = 1` — those tests were already using integer + literals which remain identical in JS. 6 JS-only failures are platform-inherent (JS float≡int). +- [x] Commit: all work landed across 4 commits (c70bbdeb, 45ec5535, b12a22e6, f5acb31c). + +--- + +## Phase 3 — Dynamic-wind + +Fix: Common Lisp `unwind-protect`, Ruby `ensure`, JS `finally`, Tcl `catch`+cleanup, +Erlang `try...after` (currently uses double-nested guard workaround). + +- [x] Spec: implement `dynamic-wind` in `spec/evaluator.sx` such that the after-thunk fires + on both normal return AND non-local exit (raise/call-cc escape). Must compose with + `guard` — currently they don't interact. +- [x] OCaml: wire `dynamic-wind` through the CEK machine with a `WindFrame` continuation. +- [x] JS bootstrapper: update. +- [x] Tests: 20+ tests covering normal return, raise, call/cc escape, nested dynamic-winds. +- [x] Commit: `spec: dynamic-wind + guard integration` + +--- + +## Phase 4 — Coroutine primitive + +Unify Ruby fibers, Lua coroutines, Tcl coroutines — all currently reimplemented separately +using call/cc+perform/resume. + +- [x] Spec: add `make-coroutine`, `coroutine-resume`, `coroutine-yield`, `coroutine?`, + `coroutine-alive?` to `spec/primitives.sx`. Build on existing `perform`/`cek-resume` + machinery — coroutines ARE perform/resume with a stable identity. + Implemented as `spec/coroutines.sx` define-library; `make-coroutine` stub in evaluator.sx. + 17/17 coroutine tests pass (OCaml). Drives iteration via define+fn recursion (not named let — + named let uses cek_call→cek_run which errors on IO suspension). +- [x] OCaml: implement coroutine type; wire resume/yield through CEK suspension. + No new native type needed — dict-based coroutine identity + existing cek-step-loop/ + cek-resume/perform primitives in run_tests.ml ARE the OCaml implementation. 17/17 pass. +- [x] JS bootstrapper: update. + All CEK primitives already in sx-browser.js. Fix: pre-load spec/coroutines.sx + + spec/signals.sx in run_tests.js so (import (sx coroutines)) resolves without suspension. + 17/17 pass in JS. 1965/2500 (+25 vs 1940 baseline). Zero new failures. +- [x] Tests: 25+ tests — multi-yield, final return, arg passthrough, alive? predicate, + nested coroutines, "final return vs yield" distinction (the Lua gotcha). + 27 tests: added 10 new — state field inspection (ready/suspended/dead), yield from + nested helper, initial resume arg ignored, mutable closure state, complex yield values, + round-robin scheduling, factory-shared-no-state, non-coroutine error. 27/27 OCaml+JS. +- [x] Commit: `spec: coroutine primitive (make-coroutine/resume/yield)` + Phase 4 landed across 4 commits: 21cb9cf5 (spec library), 9eb12c66 (ocaml verified), + b78e06a7 (js pre-load), 0ffe208e (27 tests). Phase 4 complete. + +--- + +## Phase 5 — String buffer + +Fix O(n²) string concatenation in loops across Lua, Ruby, Common Lisp, Tcl. + +- [x] Spec + OCaml: add `make-string-buffer`, `string-buffer-append!`, `string-buffer->string`, + `string-buffer-length` to primitives. OCaml: `Buffer.t` wrapper. JS: array+join. + Also: string-buffer? predicate; SxStringBuffer._string_buffer marker for typeOf/dict? + exclusion; inspect case in sx_types.ml. 17/17 tests OCaml+JS. +- [x] Tests: 15+ tests. + 17 tests written inline with Spec+OCaml step: construction, type-of, empty/length, + single/multi-append, append-returns-nil, empty-string-append, reuse-after-to-string, + independence, loop-building, CSV-row, unicode, repeated-to-string, join-pattern. + 17/17 OCaml+JS. +- [x] Commit: `spec: string-buffer primitive` + Committed as d98b5fa2 — all work in one commit (OCaml type + primitives + JS + spec + 17 tests). + +--- + +## Phase 6 — Algebraic data types + +The deepest structural gap. Every language uses `{:tag "..." :field ...}` tagged dicts to +simulate sum types. A native `define-type` + `match` form eliminates this everywhere. + +- [x] Design: write `plans/designs/sx-adt.md` covering syntax, CEK dispatch, interaction with + existing `cond`/`case`, exhaustiveness checking, recursive types, pattern variables. + Draft, then stop — next fire reviews design before implementing. + Written: define-type/match syntax, AdtValue runtime rep, stepSfDefineType + MatchFrame + CEK dispatch, exhaustiveness warnings via _adt_registry, recursive types, nested patterns, + wildcard _, 3-phase impl plan (basic/nested/exhaustiveness), open questions on accessors/singletons/inspect. + +- [x] Spec: implement `define-type` special form in `spec/evaluator.sx`: + `(define-type Name (Ctor1 field...) (Ctor2 field...) ...)` + Creates constructor functions `Ctor1`, `Ctor2` + predicate `Name?`. + +- [x] Spec: implement `match` special form: + `(match expr ((Ctor1 a b) body) ((Ctor2 x) body) (else body))` + Exhaustiveness warning if not all constructors covered and no `else`. + +- [x] OCaml: add `SxAdt of string * value array` to types; implement constructors + match. + Dict-based ADT (no native type needed — matches spec). Hand-written sf_define_type + in bootstrap.py FIXUPS; registered via register_special_form. 172 assertions pass. + 4280/1080 full suite (37 improvement over old baseline 4243/1117). +- [x] JS bootstrapper: update. + No changes needed — define-type/match are spec-level; sx-browser.js rebuilt at 0dc7e159. + 40/40 ADT tests pass JS. 2032/2500 total (+67 vs 1965 phase-4 baseline). +- [x] Tests: 40+ tests in `spec/tests/test-adt.sx`. + 40 tests written across two spec commits (6c872107+0dc7e159). All pass OCaml+JS. +- [x] Commit: `spec: algebraic data types (define-type + match)` + Phase 6 landed across 5 commits: 6c872107 (define-type spec), 0dc7e159 (match spec), + 5d1913e7 (ocaml bootstrap), f63b2147 (plan tick). JS already current. + +--- + +## Phase 7 — Bitwise operations + +Completely absent today. Needed by: Forth (core), APL (array masks), Erlang (bitmatch), +JS (typed arrays, bitfields), Common Lisp (`logand`/`logior`/`logxor`/`lognot`/`ash`). + +Primitives to add: +- `bitwise-and` `a` `b` → integer +- `bitwise-or` `a` `b` → integer +- `bitwise-xor` `a` `b` → integer +- `bitwise-not` `a` → integer +- `arithmetic-shift` `a` `count` → integer (left if count > 0, right if count < 0) +- `bit-count` `a` → number of set bits (popcount) +- `integer-length` `a` → number of bits needed to represent a + +Steps: +- [x] Spec: add entries to `spec/primitives.sx` with type signatures. + stdlib.bitwise module with 7 entries appended to spec/primitives.sx. +- [x] OCaml: implement in `hosts/ocaml/sx_primitives.ml` using OCaml `land`/`lor`/`lxor`/`lnot`/`lsl`/`asr`. + land/lor/lxor/lnot/lsl/asr in sx_primitives.ml. bit-count: Kernighan loop. integer-length: lsr loop. +- [x] JS bootstrapper: implement in `hosts/javascript/platform.js` using JS `&`/`|`/`^`/`~`/`<<`/`>>`. + stdlib.bitwise module added to PRIMITIVES_JS_MODULES. bit-count: Hamming weight. integer-length: Math.clz32. +- [x] Tests: 25+ tests in `spec/tests/test-bitwise.sx` — basic ops, shift left/right, negative numbers, popcount. + 26 tests, 158 assertions, all pass OCaml+JS. +- [x] Commit: `spec: bitwise operations (bitwise-and/or/xor/not, arithmetic-shift, bit-count)` + Committed a8a79dc9. Phase 7 complete in single commit. + +--- + +## Phase 8 — Multiple values + +R7RS standard. Common Lisp uses them heavily; Haskell tuples map naturally; Erlang +multi-return. Without them, every function returning two things encodes it as a list or dict. + +Primitives / forms to add: +- `values` `v...` → multiple-value object +- `call-with-values` `producer` `consumer` → applies consumer to values from producer +- `let-values` `(((a b) expr) ...)` `body` — binding form (special form in evaluator) +- `define-values` `(a b ...)` `expr` — top-level multi-value bind + +Steps: +- [x] Spec: add `SxValues` type to evaluator; implement `values` + `call-with-values` in + `spec/evaluator.sx`; add `let-values` / `define-values` special forms. +- [x] OCaml: add `SxValues of value list` to `sx_types.ml`; wire through CEK. +- [x] JS bootstrapper: implement values type + forms. +- [x] Tests: 25+ tests in `spec/tests/test-values.sx` — basic producer/consumer, let-values + destructuring, define-values, interaction with `begin`/`do`. +- [x] Commit: `spec: multiple values (values/call-with-values/let-values)` + +--- + +## Phase 9 — Promises (lazy evaluation) + +Critical for Haskell — lazy evaluation is so central that without it the Haskell +implementation can't be idiomatic. Also useful for lazy lists in Common Lisp and +lazy streams in Scheme-style code generally. + +Primitives / forms to add: +- `delay` `expr` → promise (special form — expr not evaluated yet) +- `force` `p` → evaluate promise, cache result, return it +- `make-promise` `v` → already-forced promise wrapping v +- `promise?` `v` → bool +- `delay-force` `expr` → for iterative lazy sequences (avoids stack growth in lazy streams) + +Steps: +- [x] Spec: add `delay` / `delay-force` special forms to `spec/evaluator.sx`; add promise + type with mutable forced/value slots; `force` checks if already forced before eval. +- [x] OCaml: add `SxPromise of { mutable forced: bool; mutable value: value; thunk: value }`; + wire `delay`/`force`/`delay-force` through CEK. +- [x] JS bootstrapper: implement promise type + forms. +- [x] Tests: 25+ tests in `spec/tests/test-promises.sx` — basic delay/force, memoisation + (forced only once), delay-force lazy stream, promise? predicate, make-promise. +- [x] Commit: `spec: promises — delay/force/delay-force for lazy evaluation` + +--- + +## Phase 10 — Mutable hash tables + +Distinct from SX's immutable dicts. Dict primitives copy on every update — fine for +functional code, wrong for table-heavy language implementations. Lua tables, Smalltalk +dicts, Erlang process dictionaries, and JS Map all need O(1) mutable associative storage. + +Primitives to add: +- `make-hash-table` `[capacity]` → fresh mutable hash table +- `hash-table?` `v` → bool +- `hash-table-set!` `ht` `key` `val` → mutate in place +- `hash-table-ref` `ht` `key` `[default]` → value or default/error +- `hash-table-delete!` `ht` `key` → remove entry +- `hash-table-size` `ht` → integer +- `hash-table-keys` `ht` → list of keys +- `hash-table-values` `ht` → list of values +- `hash-table->alist` `ht` → list of (key . value) pairs +- `hash-table-for-each` `ht` `fn` → iterate (fn key val) for side effects +- `hash-table-merge!` `dst` `src` → merge src into dst in place + +Steps: +- [x] Spec: add entries to `spec/primitives.sx`. + stdlib.hash-table module with 11 define-primitive entries appended to spec/primitives.sx. +- [x] OCaml: add `HashTable of (value, value) Hashtbl.t` to `sx_types.ml`; implement + all primitives in `hosts/ocaml/sx_primitives.ml`. + HashTable variant in sx_types.ml; type_of/inspect cases added; 11 primitives in sx_primitives.ml; + fixed _cek_call_ref reference for hash-table-for-each. 4385/1080 (+28). +- [x] JS bootstrapper: implement using JS `Map` in `hosts/javascript/platform.js`. + SxHashTable class with Map; _hash_table marker; dict?/type-of exclusion; apply() for for-each. + 2137/2500 (+4 vs phase-9 baseline). +- [x] Tests: 30+ tests in `spec/tests/test-hash-table.sx` — set/ref/delete, size, iteration, + default on missing key, merge, keys/values lists. + 28 tests; all pass OCaml+JS. Used empty? not assert= for empty-list comparisons. +- [x] Commit: `spec: mutable hash tables (make-hash-table/ref/set!/delete!/etc)` + Committed 133bdf52. Phase 10 complete. + +--- + +## Phase 11 — Sequence protocol + +Unified iteration over lists and vectors without conversion. Currently `map`/`filter`/ +`for-each` only work on lists — you must `vector->list` first, which defeats the purpose +of vectors. A sequence protocol makes all collection operations polymorphic. + +Approach: extend existing `map`/`filter`/`reduce`/`for-each`/`some`/`every?` to dispatch +on type (list → existing path, vector → index loop, string → char iteration). Add: +- `in-range` `start` `[end]` `[step]` → lazy range sequence (works with `for-each`/`map`) +- `sequence->list` `s` → coerce any sequence to list +- `sequence->vector` `s` → coerce any sequence to vector +- `sequence-length` `s` → length of any sequence +- `sequence-ref` `s` `i` → element by index (lists and vectors) +- `sequence-append` `s1` `s2` → concatenate two same-type sequences + +Steps: +- [x] Spec: extend `map`/`filter`/`reduce`/`for-each`/`some`/`every?` in `spec/evaluator.sx` + to type-dispatch; add `in-range` lazy sequence type + helpers. +- [x] OCaml: update HO form dispatch; add `SxRange` or use lazy list; implement `sequence-*` + primitives. + seq_to_list helper before let-rec block; ho_setup_dispatch wraps all 7 coll bindings; + seq-to-list/sequence-to-list/vector/length/ref/append/in-range in sx_primitives.ml. + 4385/1080 (all failures pre-existing hs-*/regex; 0 regressions). +- [x] JS bootstrapper: update. + Already done in Spec step (da4b526a) — sx-browser.js rebuilt with seqToList/sequenceToList/ + sequenceToVector/sequenceLength/sequenceRef/sequenceAppend/inRange. 2137/2500 JS tests pass. +- [x] Tests: 30+ tests in `spec/tests/test-sequences.sx` — map over vector, filter over + range, for-each over string chars, sequence-append, sequence->list/vector coercions. + 45 tests all passing: JS 2185/2498 (+48), OCaml 4424/1087 (+39). Fixed: vector? rename + (isVector), vectorLength/vectorRef/reverse aliases, in-range letrec→build-range, + sequence-length nil=0, assert-equal for list comparisons. Committed 0fe00bf7. +- [x] Commit: `spec: sequence protocol — polymorphic map/filter/for-each over list/vector/range` + Work landed across da4b526a (Spec), 7286629c (OCaml), 06a3eee1 (JS bootstrap), 0fe00bf7 (Tests). + +--- + +## Phase 12 — gensym + symbol interning + +Unique symbol generation. Tiny to implement; broadly needed: Prolog uses it for fresh +variable names, Common Lisp uses it constantly in macros, any hygienic macro system needs +it, and Smalltalk uses it for anonymous class/method naming. + +Primitives to add: +- `gensym` `[prefix]` → unique symbol, e.g. `g42`, `var-17`. Counter-based, monotonically increasing. +- `symbol-interned?` `s` → bool — whether the symbol is in the global intern table +- `intern` `str` → symbol — intern a string as a symbol (string->symbol already exists; this is + the explicit interning operation for languages that distinguish interned vs uninterned) + +Steps: +- [x] Spec: add `gensym` counter to evaluator state; implement in `spec/evaluator.sx`. + `string->symbol` already exists — `gensym` is just a counter-suffixed variant. + Added *gensym-counter*/gensym/string->symbol/symbol->string/intern/symbol-interned? to + evaluator.sx. Added string->symbol/symbol->string transpiler renames + platform.py aliases. + JS 2186/+1. OCaml builds. Committed edf4e525. +- [x] OCaml: add global gensym counter; implement primitives. + gensym_counter ref + gensym/string->symbol/symbol->string/intern/symbol-interned? in sx_primitives.ml. + Also fixed ListRef case in seq_to_list (both sx_ref.ml + sx_primitives.ml). 4431/1080 (was 4385/1080). +- [x] JS bootstrapper: implement. + Already done in Spec step. JS 2186/2497, all sequence tests pass. +- [x] Tests: 15+ tests in `spec/tests/test-gensym.sx` — uniqueness, prefix, symbol?, string->symbol round-trip. + 19 tests. OCaml 4450/1080, JS 2205/2497, zero regressions. +- [x] Commit: `spec: gensym + symbol interning` — 0862a614 + +--- + +## Phase 13 — Character type + +Common Lisp and Haskell have a distinct `Char` type that is not a string. Without it both +implementations are approximations — CL's `#\a` literal and Haskell's `'a'` both need a +real char value, not a length-1 string. + +Primitives to add: +- `char?` `v` → bool +- `char->integer` `c` → Unicode codepoint integer +- `integer->char` `n` → char +- `char=?` `char?` `char<=?` `char>=?` → comparators +- `char-ci=?` `char-cilist` extended to return chars (not length-1 strings) +- `list->string` accepting chars + +Also: `#\a` reader syntax for char literals (parser addition). + +Steps: +- [x] Spec: add `SxChar` type to evaluator; add char literal syntax `#\a`/`#\space`/`#\newline` + to `spec/parser.sx`; implement all predicates + comparators. +- [x] OCaml: add `SxChar of char` to `sx_types.ml`; implement primitives. +- [x] JS bootstrapper: implement char type wrapping a codepoint integer. +- [x] Tests: 30+ tests in `spec/tests/test-chars.sx` — literals, char->integer round-trip, + comparators, predicates, upcase/downcase, string<->list with chars. +- [x] Commit: `spec: character type (char? char->integer #\\a literals + predicates)` + +--- + +## Phase 14 — String ports + +Needed for any language with a reader protocol: Common Lisp's `read`, Prolog's term parser, +Smalltalk's `printString`. Without string ports these all do their own character walking +on raw strings rather than treating a string as an I/O stream. + +Primitives to add: +- `open-input-string` `str` → input port +- `open-output-string` → output port +- `get-output-string` `port` → string (flush output port to string) +- `input-port?` `output-port?` `port?` → predicates +- `read-char` `[port]` → char or eof-object +- `peek-char` `[port]` → char or eof-object (non-consuming) +- `read-line` `[port]` → string or eof-object +- `write-char` `char` `[port]` → void +- `write-string` `str` `[port]` → void +- `eof-object` → the eof sentinel +- `eof-object?` `v` → bool +- `close-port` `port` → void + +Steps: +- [x] Spec: add port type + eof-object to evaluator; implement all primitives. + Ports are mutable objects with a position cursor (input) or accumulation buffer (output). +- [x] OCaml: add `SxPort` variant covering string-input-port and string-output-port; + Buffer.t for output, string+offset for input. +- [x] JS bootstrapper: implement port type. +- [x] Tests: 25+ tests in `spec/tests/test-ports.sx` — open/read/peek/eof, output accumulation, + read-line, write-char, close. +- [x] Commit: `spec: string ports (open-input-string/open-output-string/read-char/etc)` — 3d8937d7 + +--- + +## Phase 15 — Math completeness + +Filling specific gaps that multiple language implementations need. + +### 15a — modulo / remainder / quotient distinction +They differ on negative numbers — critical for Erlang `rem`, Haskell `mod`/`rem`, CL `mod`/`rem`: +- `quotient` `a` `b` → truncate toward zero (same sign as dividend) +- `remainder` `a` `b` → sign follows dividend (truncation division) +- `modulo` `a` `b` → sign follows divisor (floor division) — R7RS + +### 15b — Trigonometry and transcendentals +Lua, Haskell, Erlang, CL all need: `sin`, `cos`, `tan`, `asin`, `acos`, `atan`, `exp`, +`log`, `sqrt`, `expt`. Check which are already present; add missing ones. + +### 15c — GCD / LCM +`gcd` `a` `b` → greatest common divisor; `lcm` `a` `b` → least common multiple. +Needed by Haskell `Rational`, CL, and any language doing fraction arithmetic. + +### 15d — Radix number parsing / formatting +`(number->string n radix)` → e.g. `(number->string 255 16)` → `"ff"`. +`(string->number s radix)` → e.g. `(string->number "ff" 16)` → `255`. +Needed by: Common Lisp, Smalltalk, Erlang integer formatting. + +Steps: +- [x] Audit which trig / math functions are already in `spec/primitives.sx`; note gaps. +- [x] Spec + OCaml + JS: implement missing trig (`sin`/`cos`/`tan`/`asin`/`acos`/`atan`/`exp`/`log`). +- [x] Spec + OCaml + JS: `quotient`/`remainder`/`modulo` with correct negative semantics. +- [x] Spec + OCaml + JS: `gcd`/`lcm`. +- [x] Spec + OCaml + JS: radix variants of `number->string`/`string->number`. +- [x] Tests: 40+ tests in `spec/tests/test-math.sx`. +- [x] Commit: `spec: math completeness — trig, quotient/remainder/modulo, gcd/lcm, radix` + +--- + +## Phase 16 — Rational numbers + +Haskell's `Rational` type and Common Lisp ratios (`1/3`) both need this. Natural extension +of the numeric tower (Phase 2) — rationals are the third numeric type alongside int and float. + +Primitives to add: +- `make-rational` `numerator` `denominator` → rational (auto-reduced by GCD) +- `rational?` `v` → bool +- `numerator` `r` → integer +- `denominator` `r` → integer +- Reader syntax: `1/3` parsed as rational literal +- Arithmetic: `(+ 1/3 1/6)` → `1/2`; `(* 1/3 3)` → `1`; mixed int/rational → rational +- `exact->inexact` on rational → float; `inexact->exact` on float → rational approximation +- `(number->string 1/3)` → `"1/3"` + +Steps: +- [x] Spec: add `SxRational` type; add `n/d` reader syntax to `spec/parser.sx`; extend + all arithmetic primitives for rational contagion (int op rational → rational, rational + op float → float). +- [x] OCaml: add `SxRational of int * int` (stored in reduced form); implement all arithmetic. + as_number + safe_eq extended for cross-type rational equality (= 2.5 5/2) → true. +- [x] JS bootstrapper: implement rational type. + JS keeps int/int → float for CSS backward compatibility; SxRational class with _rational marker. +- [x] Tests: 30+ tests in `spec/tests/test-rationals.sx` — literals, arithmetic, reduction, + mixed numeric tower, exact<->inexact conversion. 62 tests, all pass. +- [x] Commit: `spec: rational numbers — 1/3 literals, arithmetic, numeric tower integration` + Committed 036022cc. JS: 2232 passed. OCaml: 4532 passed (+11). + +--- + +## Phase 17 — read / write / display + +Completes the I/O model. Builds on string ports (Phase 14) and char type (Phase 13). +`read` parses any SX value from a port; `write` serializes with quoting (round-trippable); +`display` serializes without quoting (human-readable). Common Lisp's `read` macro, +Prolog term I/O, and Smalltalk's `printString` all need this. + +Primitives to add: +- `read` `[port]` → SX value or eof-object — full SX parser reading from a port +- `read-char` already in Phase 14; `read` uses it internally +- `write` `val` `[port]` → void — serializes with quotes: `"hello"`, `#\a`, `(1 2 3)` +- `display` `val` `[port]` → void — serializes without quotes: `hello`, `a`, `(1 2 3)` +- `newline` `[port]` → void — writes `\n` +- `write-to-string` `val` → string — convenience: `(write val (open-output-string))` +- `display-to-string` `val` → string — convenience + +Steps: +- [x] Spec: implement `read` in `spec/evaluator.sx` — wraps the existing parser to read + one datum from a port cursor; handles eof gracefully. +- [x] Spec: implement `write`/`display`/`newline` — extend the existing serializer for + port output; `write` quotes strings + uses `#\` for chars, `display` does not. +- [x] OCaml: wire `read` through port type; implement `write`/`display` output path. +- [x] JS bootstrapper: implement. +- [x] Tests: 25+ tests in `spec/tests/test-read-write.sx` — read string literal, read list, + read eof, write round-trip, display vs write quoting, newline, write-to-string. +- [x] Commit: `spec: read/write/display — S-expression reader/writer on ports` + +--- + +## Phase 18 — Sets + +O(1) membership testing. Distinct from hash tables (unkeyed) and lists (O(n)). +Erlang has sets as a stdlib staple, Haskell `Data.Set`, APL uses set operations +constantly, Common Lisp has `union`/`intersection` on lists but a native set is O(1). + +Primitives to add: +- `make-set` `[list]` → fresh set, optionally seeded from list +- `set?` `v` → bool +- `set-add!` `s` `val` → void +- `set-member?` `s` `val` → bool +- `set-remove!` `s` `val` → void +- `set-size` `s` → integer +- `set->list` `s` → list (unspecified order) +- `list->set` `lst` → set +- `set-union` `s1` `s2` → new set +- `set-intersection` `s1` `s2` → new set +- `set-difference` `s1` `s2` → new set (elements in s1 not in s2) +- `set-for-each` `s` `fn` → iterate for side effects +- `set-map` `s` `fn` → new set of mapped values + +Steps: +- [x] Spec: add entries to `spec/primitives.sx`. +- [x] OCaml: implement using `Hashtbl.t` with unit values (or a proper `Set` functor + with a comparison function); add `SxSet` to `sx_types.ml`. +- [x] JS bootstrapper: implement using JS `Set`. +- [x] Tests: 30+ tests in `spec/tests/test-sets.sx` — add/member/remove, union/intersection/ + difference, list conversion, for-each, size. +- [x] Commit: `spec: sets (make-set/set-add!/set-member?/union/intersection/etc)` + +--- + +## Phase 19 — Regular expressions as primitives + +`lib/js/regex.sx` is a pure-SX regex engine already written. Promoting it to a primitive +gives every language free regex without reinventing: Lua patterns, Tcl `regexp`, Ruby regex, +JS regex, Erlang `re` module. Mostly a wiring job — the implementation exists. + +Primitives to add: +- `make-regexp` `pattern` `[flags]` → regexp object (`flags`: `"i"` case-insensitive, `"g"` global, `"m"` multiline) +- `regexp?` `v` → bool +- `regexp-match` `re` `str` → match dict `{:match "..." :start N :end N :groups (...)}` or nil +- `regexp-match-all` `re` `str` → list of match dicts +- `regexp-replace` `re` `str` `replacement` → string with first match replaced +- `regexp-replace-all` `re` `str` `replacement` → string with all matches replaced +- `regexp-split` `re` `str` → list of strings (split on matches) +- Reader syntax: `#/pattern/flags` for regexp literals (parser addition) + +Steps: +- [x] Audit `lib/js/regex.sx` — understand the API it already exposes; map to the + primitive API above. +- [x] Spec: add `SxRegexp` type to evaluator; add `#/pattern/flags` literal syntax to + `spec/parser.sx`; wire `lib/js/regex.sx` engine as the implementation. +- [x] OCaml: implement using OCaml `Re` library (or `Str`); add `SxRegexp` to types. +- [x] JS bootstrapper: use native JS `RegExp`; wrap in the primitive API. +- [x] Tests: 30+ tests in `spec/tests/test-regexp.sx` — basic match, groups, replace, + replace-all, split, flags (case-insensitive), no-match nil return. +- [x] Commit: `spec: regular expressions (make-regexp/regexp-match/regexp-replace + #/pat/ literals)` + +--- + +## Phase 20 — Bytevectors + +R7RS standard. Needed for WebSocket binary frames (E36), binary protocol parsing, and +efficient string encoding. Also the foundation for proper Unicode: `string->utf8` / +`utf8->string` require a byte array type. + +Primitives to add: +- `make-bytevector` `n` `[fill]` → bytevector of n bytes (fill defaults to 0) +- `bytevector?` `v` → bool +- `bytevector-length` `bv` → integer +- `bytevector-u8-ref` `bv` `i` → byte 0–255 +- `bytevector-u8-set!` `bv` `i` `byte` → void +- `bytevector-copy` `bv` `[start]` `[end]` → fresh copy +- `bytevector-copy!` `dst` `at` `src` `[start]` `[end]` → in-place copy +- `bytevector-append` `bv...` → concatenated bytevector +- `utf8->string` `bv` `[start]` `[end]` → string decoded as UTF-8 +- `string->utf8` `str` `[start]` `[end]` → bytevector UTF-8 encoded +- `bytevector->list` / `list->bytevector` → conversion + +Steps: +- [x] Spec: add `SxBytevector` type; implement all primitives in `spec/evaluator.sx` / `spec/primitives.sx`. +- [x] OCaml: add `SxBytevector of bytes` to `sx_types.ml`; implement primitives using + OCaml `Bytes`. +- [x] JS bootstrapper: implement using `Uint8Array`. +- [x] Tests: 30+ tests in `spec/tests/test-bytevectors.sx` — construction, ref/set, copy, + append, utf8 round-trip, slice. +- [x] Commit: `spec: bytevectors (make-bytevector/u8-ref/u8-set!/utf8->string/etc)` + +--- + +## Phase 21 — format + +CL-style string formatting beyond `str`. `(format "Hello ~a, age ~d" name age)`. +Haskell `printf`, Erlang `io:format`, CL `format`, and general string templating all use this idiom. + +Directives: +- `~a` — display (no quotes) +- `~s` — write (with quotes) +- `~d` — decimal integer +- `~x` — hexadecimal integer +- `~o` — octal integer +- `~b` — binary integer +- `~f` — fixed-point float +- `~e` — scientific notation float +- `~%` — newline +- `~&` — fresh line (newline only if not already at start of line) +- `~~` — literal tilde +- `~t` — tab + +Signature: `(format template arg...)` → string. +Optional: `(format port template arg...)` — write to port directly. + +Steps: +- [x] Spec: implement `format` as a pure SX function in `spec/stdlib.sx` — parses + `~X` directives, dispatches to `display`/`write`/`number->string` as appropriate. + Pure SX: no host calls needed. Self-hosting — uses string-buffer (Phase 5) internally. +- [x] OCaml: expose as a primitive (or let it run as SX through the evaluator). + Added format-decimal OCaml primitive; fixed lib/r7rs.sx number->string to support radix. +- [x] JS bootstrapper: same. +- [x] Tests: 28 tests in `spec/tests/test-format.sx` — each directive, multiple args, + nested format, `~~` escape. 28/28 pass on both JS and OCaml. +- [x] Commit: `spec: format — CL-style string formatting (~a ~s ~d ~x ~% etc)` — 4d7b3e29 + +--- + +## Phase 22 — Language sweep + +Replace workarounds with primitives. One language per fire (or per sub-item for big ones). +Start with blank slates (CL, APL, Ruby, Tcl) — they haven't committed to workarounds yet. + +**Scope per language:** only `lib//**`. Don't touch spec or other languages. +Brief each language's loop agent (or do inline) after rebasing their branch onto architecture. + +- [x] Restart CL/APL/Ruby/Tcl loops with updated briefing pointing to new primitives. + Added `## SX primitive baseline` section to plans/common-lisp-on-sx.md, + plans/apl-on-sx.md, plans/ruby-on-sx.md, plans/tcl-on-sx.md. f43659ce. + +- [x] Common Lisp: char type (`#\a`); string ports + `read`/`write` for reader/printer; + gensym for macros; rational numbers for CL ratios; multiple values; sets for CL set ops; + `modulo`/`remainder`/`quotient`; radix formatting; `format` for `cl:format`. + lib/common-lisp/runtime.sx (103 forms) + test.sh (68/68 pass). 1ad8e74a. + +- [x] Lua: vectors for arrays; hash tables for Lua tables; `delay`/`force` for lazy iterators; + regexp for Lua pattern matching; trig from math completeness; bytevectors for binary I/O. + math/string/table stdlib tables + lua-force. 185/185 pass. ec3512d6. + +- [x] Erlang: numeric tower for float/int; bitwise ops for bitmatch; multiple values for + multi-return; sets for Erlang sets; `remainder` for `rem`; regexp for `re` module. + lib/erlang/runtime.sx (63 forms) + test.sh (55/55 pass). 3c0a9632. + +- [x] Haskell: numeric tower for `Num`/`Integral`/`Fractional`; promises for lazy evaluation + (critical); multiple values for tuples; rational numbers for `Rational`; char type for + `Char`; `gcd`/`lcm`; sets for `Data.Set`; `read`/`write` for `Show`/`Read` instances. + lib/haskell/runtime.sx (113 forms) + tests/runtime.sx (143/143 pass). c02ffcf3. + +- [x] JS: vectors for Array; hash tables for `Map`; sets for `Set`; bitwise ops for typed + arrays; regexp for JS regex; bytevectors for `Uint8Array`; radix formatting. + lib/js/stdlib.sx (36 forms) + test.sh epochs 6000-6032 (25/25 pass). COMMIT. + +- [x] Smalltalk: vectors for `Array new:`; hash tables for `Dictionary new`; sets for + `Set new`; char type for `Character`; string ports + `read`/`write` for `printString`. + lib/smalltalk/runtime.sx (72 forms) + tests/runtime.sx (86/86 pass). COMMIT. + +- [x] APL: vectors as core array type; bitwise ops for array masks; sets for APL set ops; + sequence protocol for rank-polymorphic operations; format for APL output formatting. + lib/apl/runtime.sx (60 forms) + tests/runtime.sx (73/73 pass). COMMIT. + +- [x] Ruby: coroutines for fibers; hash tables for `Hash`; sets for `Set`; regexp for + Ruby regex; string ports for `StringIO`; bytevectors for `String` binary encoding. + lib/ruby/runtime.sx (61 forms) + tests/runtime.sx (76/76 pass). COMMIT. + Note: rb-fiber-yield from letrec-bound lambdas fails (JIT VM can't invoke callcc + continuations as escapes); workaround: use top-level helper fns for recursive yields. + +- [x] Tcl: string ports for Tcl channel abstraction; string-buffer for `append`; coroutines + for Tcl coroutines; regexp for Tcl `regexp`; format for Tcl `format`. + lib/tcl/runtime.sx (37 forms) + tests/runtime.sx (56/56 pass). COMMIT. + +- [x] Forth: bitwise ops (core); string-buffer for word-definition accumulation; bytevectors + for Forth's raw memory model. + lib/forth/runtime.sx (36 forms) + tests/runtime.sx (64/64 pass). COMMIT. + +--- + +## Ground rules + +- Work on the `architecture` branch in `/root/rose-ash` (main worktree). +- Use sx-tree MCP for all `.sx` file edits. Never use raw Edit/Write/Read on `.sx` files. +- Commit after each concrete unit of work. Never leave the branch broken. +- Never push to `main` — only push to `origin/architecture`. +- Update this checklist every fire: tick `[x]` done, add inline notes on blockers. + +--- + +## Progress log + +_Newest first._ + +- 2026-05-01: Phase 22 Forth done — runtime.sx (36 forms): bitwise (AND/OR/XOR/INVERT/LSHIFT/RSHIFT/2*/2//bit-count/integer-length/within + arithmetic helpers), string-buffer (emit!/type!/value/length/clear!/emit-int!), memory (cfetch/cstore/fetch/store/move!/fill!/erase!/mem->list). 64/64 tests. 8019e572. +- 2026-05-01: Phase 22 Tcl done — runtime.sx (37 forms): string-buffer (append accumulator), channel (read/write ports with gets/read/puts), regexp (make-regexp wrappers), format (%s/%d/%f/%x/%o/%% manual char scan), coroutine (call/cc, top-level helper pattern). 56/56 tests. 3e07727d. +- 2026-05-01: Phase 22 Ruby done — runtime.sx (61 forms): Hash (list-of-pairs dict-backed), Set (make-set, (set item) order), Regexp (make-regexp wrappers), StringIO (write buf + rewind/char read), Bytevectors (thin wrappers), Fiber (call/cc; letrec JIT workaround: use top-level helpers). 76/76 tests. 182e6f63. + +- 2026-05-01: Phase 22 APL done — runtime.sx (60 forms): iota/rho/at, rank-polymorphic dyadic/monadic helpers, arithmetic/comparison/boolean/bitwise element-wise, reduce/scan, take/drop/rotate/compress/index, set ops (member/nub/union/intersect/without), format. 73/73 tests. COMMIT. +- 2026-05-01: Phase 22 Smalltalk done — runtime.sx (72 forms): numeric helpers, Character (1-indexed Array backed by dict), Dictionary (list-of-pairs any-key map), Set (make-set), WriteStream/ReadStream/printString. set-member? (set item) order. 86/86 tests. COMMIT. +- 2026-05-01: Phase 22 JS done — stdlib.sx (36 forms): bitwise (truncate not js-num-to-int; set-member? takes (set item) order), Map (dict-backed pairs), Set (SX make-set), RegExp (callable lambda). 25/25 new tests pass; total 492/585. COMMIT. +- 2026-05-01: Phase 22 Haskell done — runtime.sx (113 forms): numeric tower (hk-div floor semantics), rational (dict GCD-normalised), hk-force (promises), Data.Char, Data.Set, Data.List, Maybe/Either, tuples, string helpers, hk-show. 148/148 tests. c02ffcf3. +- 2026-05-01: Phase 22 Erlang done — runtime.sx (63 forms): numeric tower, bitwise (band/bor/bxor/bnot/bsl/bsr), sets, re module, list BIFs, type conversions, ok/error tuples. 55/55 tests. 3c0a9632. +- 2026-05-01: Phase 22 Lua done — math/string/table stdlib tables + lua-force in lib/lua/runtime.sx. 185/185 tests (28 new). ec3512d6. +- 2026-05-01: Phase 22 CL done — runtime.sx (103 forms): type preds, arithmetic, chars, format, gensym, values, sets, radix, list utils. cl-empty? guards nil/() split. 68/68 tests. 1ad8e74a. +- 2026-05-01: Phase 22 step 1 — SX primitive baseline added to CL/APL/Ruby/Tcl plans. f43659ce. +- 2026-05-01: Phase 21 complete — format (~a ~s ~d ~x ~o ~b ~f ~% ~& ~~ ~t) as pure SX in spec/stdlib.sx. Fixed lib/r7rs.sx number->string to support optional radix; added format-decimal OCaml primitive. 28/28 tests on both JS and OCaml. 4d7b3e29. +- 2026-04-26: Phase 7 complete — bitwise-and/or/xor/not + arithmetic-shift + bit-count + integer-length. OCaml: land/lor/lxor/lnot/lsl/asr + Kernighan popcount + lsr loop for integer-length. JS: bitwise ops + Hamming weight + Math.clz32. 26 tests, 158 assertions, all pass. a8a79dc9. +- 2026-04-26: Phase 6 complete — JS+Tests+Commit all ticked. JS needed no changes (spec-level forms). 40/40 ADT tests pass JS. 2032/2500 JS total (+67 vs phase-4). Phase 6 fully landed: 6c872107+0dc7e159+5d1913e7. Phase 7 (bitwise) next. +- 2026-04-26: Phase 6 OCaml done — Dict-based ADT (no native SxAdt type needed); hand-written sf_define_type in bootstrap.py FIXUPS (skipped from transpile — &rest params + empty-dict {} literals); registered via register_special_form; step_limit/step_count added to PREAMBLE. 172 assertions pass (test-adt). Full suite 4280/1080 (was 4243/1117, +37). Committed 5d1913e7. +- 2026-04-26: Phase 6 Spec match done — ADT case added to match-pattern in spec/evaluator.sx: checks (list? pattern)+(symbol? first)+(dict? value)+(get value :_adt), then matches :_ctor+arity and recursively binds field patterns. No-clause error now uses make-cek-value+raise-eval-frame so guard can catch it. 20 new match tests pass; 40/40 total ADT tests green. Zero regressions. +- 2026-04-26: Phase 6 Spec define-type done — sf-define-type registered via register-special-form! in spec/evaluator.sx; AdtValue as {:_adt true :_type "..." :_ctor "..." :_fields (list ...)}; ctor fns + arity checking + Name?/Ctor? predicates + Ctor-field accessors; *adt-registry* dict populated per define-type call. 20/20 JS tests pass in spec/tests/test-adt.sx. OCaml define-type is next task. +- 2026-04-26: Phase 6 Design done — plans/designs/sx-adt.md written. Covers define-type/match syntax, AdtValue CEK runtime, stepSfDefineType+MatchFrame dispatch, exhaustiveness warnings, recursive types, nested patterns, wildcard _. 3-phase impl plan. Next fire: Spec implement define-type. +- 2026-04-26: Phase 5 complete — string buffer fully landed (d98b5fa2). 17 tests, 17/17 OCaml+JS. Phase 6 (ADTs) next. +- 2026-04-26: Phase 5 Spec+OCaml+JS step done — StringBuffer of Buffer.t in sx_types.ml; make-string-buffer/append!/->string/length/string-buffer? in sx_primitives.ml; SxStringBuffer with _string_buffer marker + typeOf/dict? fixes in platform.py; JS rebuilt. 17/17 tests OCaml+JS. +- 2026-04-26: Phase 4 complete — coroutine primitive fully landed (4 commits: spec library + OCaml verified + JS pre-load + 27 tests). Phase 5 (string buffer) next. +- 2026-04-26: Phase 4 Tests step done — 27 tests total (10 new: state field inspection, yield-from-helper, initial-arg-ignored, mutable-closure, complex-values, round-robin, factory-no-state, non-coroutine-error). 27/27 OCaml+JS. +- 2026-04-26: Phase 4 JS step done — all CEK primitives already in sx-browser.js; fix was pre-loading spec/coroutines.sx+spec/signals.sx in run_tests.js so (import (sx coroutines)) resolves synchronously. 17/17 coroutine tests pass JS. 1965/2500 total (+25), zero new failures. +- 2026-04-26: Phase 4 OCaml step done — no native SxCoroutine type needed; existing cek-step-loop/cek-resume/perform/make-cek-state primitives in run_tests.ml fully support the spec/coroutines.sx library. 284/284 pass (coroutines+vectors+numeric-tower+dynamic-wind), zero regressions. +- 2026-04-26: Phase 4 Spec step done — spec/coroutines.sx define-library with make-coroutine/coroutine-resume/coroutine-yield/coroutine?/coroutine-alive?; make-coroutine stub in evaluator.sx; 17/17 coroutine tests pass (OCaml). Key insight: coroutine body must use (define loop (fn...)) + (loop 0) not named let — named let uses cek_call→cek_run which errors on IO suspension. +- 2026-05-01: Phase 10 complete — mutable hash tables. HashTable variant in OCaml; JS Map-based SxHashTable. 11 primitives: make-hash-table/hash-table?/set!/ref/delete!/size/keys/values/->alist/for-each/merge!. 28 tests, all pass OCaml+JS. 133bdf52. +- 2026-05-01: Phase 9 complete — delay/force/delay-force/make-promise/promise?. Dict-based promise {:_promise :forced :thunk :value}; :_iterative flag for delay-force chain following. 25/25 tests OCaml (4357) and JS (2109). Committed e44cb89a. +- 2026-05-01: Phase 8 complete — values/call-with-values/let-values/define-values. Dict marker {:_values true :_list [...]} (no new type). step-sf-define desugars shorthand (define (f x) body) on both hosts. 25/25 tests OCaml+JS. Committed 43cc1d90. +- 2026-04-26: Phase 3 complete — OCaml+JS done. CallccContinuation gains winders-depth int; make_callcc_continuation/callcc_continuation_winders_len wired; wind-after/wind-return CekFrame fields fixed (cf_f=after-thunk, cf_extra=winders-len, cf_name=body-result); get_val + transpiler.sx updated. 8/8 dynamic-wind tests pass on OCaml; 235/235 (callcc+guard+do+r7rs) zero regressions. Committed 6602ec8c. +- 2026-04-26: Phase 3 Spec+Tests done — dynamic-wind CEK implementation: wind-after/wind-return frames, *winders* stack, kont-unwind-to-handler, wind-escape-to. callcc frame stores winders-len in continuation; callcc-continuation? calls wind-escape-to before escape. 8/8 dynamic-wind tests pass (normal return, raise, call/cc, nested LIFO, guard ordering). 1948/2500 JS (+8). Zero regressions. Committed a9d5a108. +- 2026-04-26: Phase 2 complete — Verify+Commit done. OCaml 4874/394, JS 1940/2500 (+60). No regressions. 6 JS-only failures are float≡int platform-inherent. Phase 2 fully landed across 4 commits. +- 2026-04-26: Phase 2 JS bootstrapper done — integer?/float?/exact?/inexact? added (Number.isInteger); truncate/remainder/modulo/random-int/exact->inexact/inexact->exact/parse-number added. Fixed sx_server.ml epoch+blob+io-response protocol for Integer type. JS: 1940/2500 (+60). OCaml: 4874/394 baseline. 6 JS tests fail (JS float≡int platform limit). Committed b12a22e6. +- 2026-04-26: Phase 2 Spec done — integer?/float? predicates added to spec/primitives.sx; floor/ceil/truncate :returns updated to "integer"; / to "float"; exact->inexact/inexact->exact docs and returns updated; float contagion documented on +/-/*; 4874/394 baseline. Committed 45ec5535. +- 2026-04-26: Phase 2 OCaml+Tests done — `Integer of int` / `Number of float` in sx_types.ml; float contagion across all arithmetic; floor/truncate/round → Integer; integer?/float?/exact?/inexact?/exact->inexact/inexact->exact; 92/92 numeric tower tests pass; 4874 total (394 pre-existing unchanged). Committed c70bbdeb. +- 2026-04-26: Phase 1 complete — JS step done. Fixed fundamental lambda binding bug (index-of on arrays returned -1 not NIL, making bind-lambda-params mis-fire &rest branch). Added _lastErrorKont_/hostError/try-catch stubs. 42/42 vector tests pass. 1847 std / 2362 full passing (up from 5). Committed. +- 2026-04-25: Phase 1 spec step done — all 10 vector primitives in spec/primitives.sx have full :as type annotations, :returns, :doc; make-vector optional fill param added. +- 2026-04-25: Phase 1 OCaml step done — bounds-checked vector-ref/set!, vector-copy now accepts optional start/end, spec/primitives.sx doc updated. 10/10 r7rs vector tests pass, 4747 total (394 pre-existing hs-upstream fails unchanged). +- 2026-04-25: Phase 0 complete — stopped CL/APL/Ruby/Tcl loops (all 4 idle at shell); confirmed E38 (tokenizer :end/:line) and E39 (WebWorker stub) both have implementation commits. +- 2026-05-01: Phase 20 complete — bytevectors. SxBytevector of bytes in OCaml using Bytes; Uint8Array-backed SxBytevector in JS. 12 primitives: make-bytevector, bytevector?, bytevector-length, bytevector-u8-ref, bytevector-u8-set!, bytevector-copy, bytevector-copy!, bytevector-append, utf8->string, string->utf8, bytevector->list, list->bytevector. 32 tests, all pass. JS 2535, OCaml 4725. a3811545. +- 2026-05-01: Phase 19 complete — regular expressions. SxRegexp(src,flags,Re.re) in OCaml via Re.Pcre; SxRegexp wrapper around JS RegExp. 9 primitives: make-regexp, regexp?, regexp-source, regexp-flags, regexp-match, regexp-match-all, regexp-replace, regexp-replace-all, regexp-split. Match dicts with :match/:start/:end/:groups. 32 tests, all pass. JS 2503, OCaml 4693. d8d5588e. +- 2026-05-01: Phase 18 complete — sets. SxSet as (string,value) Hashtbl keyed by inspect(val) in OCaml; Map keyed by write-to-string in JS. 13 primitives: make-set, set?, set-add!, set-member?, set-remove!, set-size, set->list, list->set, set-union, set-intersection, set-difference, set-for-each, set-map. 33 tests, all pass. JS 2469, OCaml 4659. 3b0ac67a. +- 2026-05-01: Phase 17 complete — read/write/display. OCaml: sx_write_val/sx_display_val helpers; read via Sx_parser.read_value with #t/#f and N/D rational support added to parser; postprocess ()→Nil. JS: sxReadNormalize (#t/#f→true/false), sxReadConvert (()→NIL), sxEq list equality, sxWriteVal symbol/keyword name fix (v.name not v._sym), readerMacroGet registry. 42 tests (test-read-write.sx), all pass both hosts. JS 2436, OCaml 4626. 7d329f02. +- 2026-05-01: Phase 16 complete — rational numbers. SxRational type in OCaml (Rational of int*int, reduced, denom>0) and JS (SxRational class, _rational marker). n/d reader in spec/parser.sx. Arithmetic contagion: int op rational → rational, rational op float → float. JS keeps int/int → float for CSS compat. OCaml as_number+safe_eq extended for cross-type rational equality. 62 tests in test-rationals.sx, all pass. JS 2232, OCaml 4532 (+11). 036022cc. +- 2026-05-01: Phase 15 complete — math completeness. stdlib.math module: sin/cos/tan/asin/acos/atan(1-2 args)/exp/log/expt/quotient/gcd/lcm/number->string(radix)/string->number(radix). OCaml atan updated for optional 2nd arg. Strict radix parsing in JS string->number. 44 tests in test-math.sx, all pass. JS 2311/4801, OCaml 4547/5629. be2b11ac. +- 2026-05-01: Phase 14 OCaml done — Eof + Port{PortInput/PortOutput} in sx_types.ml; 15 port primitives in sx_primitives.ml; raw_serialize updated; 4532/4532 (+39, zero regressions). 8ba0a33f. +- 2026-05-01: Phase 14 Spec+JS+Tests+Commit done — port type {_port,_kind,_source/_buffer,_pos,_closed}; eof singleton; 15 primitives in spec/primitives.sx (stdlib.ports) + platform.py; 39/39 tests in test-ports.sx. Committed 3d8937d7. OCaml step next. +- 2026-05-01: Phase 13 OCaml done — Char of int in sx_types.ml; #\ reader in sx_parser.ml; all char primitives in sx_primitives.ml; fixed get_val for Integer n list indexing (was Number-only); fixed raw_serialize for Integer/Char. 4493/4493 (+43, zero regressions). b939becd. +- 2026-05-01: Phase 13 Spec+JS+Tests+Commit done — SxChar tagged {_char,codepoint}; char? char->integer integer->char char-upcase/downcase; 10 comparators (ordered+ci); 5 predicates; string->list/list->string as platform primitives; #\a #\space #\newline reader syntax in spec/parser.sx; js-char-renames dict in transpiler.sx; 43/43 tests pass JS (2254/4745). Committed 4b600f17. OCaml step next. +- 2026-05-01: Phase 12 complete — gensym + symbol interning. gensym_counter/gensym/string->symbol/symbol->string/intern/symbol-interned? in spec + OCaml + JS. Fixed ListRef case in seq_to_list (both hosts). 19 tests, all pass. OCaml 4450/1080, JS 2205/2497. Commits: edf4e525 Spec, 0862a614 OCaml+Tests. +- 2026-05-01: Phase 11 complete — sequence protocol done. Commits: da4b526a Spec, 7286629c OCaml, 06a3eee1 JS, 0fe00bf7 Tests. JS 2185/+48, OCaml 4424/+39. +- 2026-05-01: Phase 11 Tests done — 45 tests in test-sequences.sx all passing (JS 2185/+48, OCaml 4424/+39). Fixed vector? rename, vectorLength/vectorRef/reverse aliases, in-range letrec→build-range, sequence-length nil, assert-equal for lists. Committed 0fe00bf7. +- 2026-05-01: Phase 11 JS bootstrapper step done — confirmed sx-browser.js current (built in Spec step da4b526a); 19 sequence primitive refs in output; 2137/2500 JS tests passing. +- 2026-05-01: Phase 11 OCaml step done — seq_to_list helper added before let-rec; ho_setup_dispatch wraps all 7 coll bindings with seq_to_list; seq-to-list/sequence-to-list/to-vector/length/ref/append + in-range primitives in sx_primitives.ml. 4385/4385 baseline unchanged, 0 regressions. Committed 7286629c. +- 2026-05-01: Phase 11 Spec step done — seq-to-list coercion helper; ho-setup-dispatch extended with seqToList on all collection args; sequence-to-list/vector/length/ref/append + in-range added to evaluator.sx. Restored 3 accidentally-deleted make-cek-state/value/suspended definitions. Fixed 8 shorthand define forms + added vector->list/list->vector transpiler renames. JS: 2137 passing (+28 vs HEAD baseline of 2109). diff --git a/plans/agent-briefings/prolog-loop.md b/plans/agent-briefings/prolog-loop.md index 8a72157f..ba83d9db 100644 --- a/plans/agent-briefings/prolog-loop.md +++ b/plans/agent-briefings/prolog-loop.md @@ -11,7 +11,7 @@ isolation: worktree ## Prompt -You are the sole background agent working `/root/rose-ash/plans/prolog-on-sx.md`. You run in an isolated git worktree. You work the plan's roadmap forever, one commit per feature. You never push. +You are the sole background agent working `/root/rose-ash/plans/prolog-on-sx.md`. You run in an isolated git worktree. You work the plan's roadmap forever, one commit per feature. Push to `origin/loops/prolog` after every commit. ## Restart baseline — check before iterating @@ -39,12 +39,13 @@ Every iteration: implement → test → commit → tick `[ ]` in plan → append ## Ground rules (hard) -- **Scope:** only `lib/prolog/**` and `plans/prolog-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, `lib/stdlib.sx`, or `lib/` root. Prolog primitives go in `lib/prolog/runtime.sx`. +- **Scope:** only `lib/prolog/**` and `plans/prolog-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, `lib/stdlib.sx`, or `lib/` root. Prolog primitives go in `lib/prolog/runtime.sx`. You may **read** `lib/hyperscript/runtime.sx` to understand the hook API but do not edit it — `hs-set-prolog-hook!` is already implemented there. +- **Hyperscript bridge is NOT blocked:** `lib/prolog/hs-bridge.sx` already exists and `lib/hyperscript/runtime.sx` already exports `hs-set-prolog-hook!` / `hs-prolog-hook`. The Phase 5 DSL item just needs tests and wiring. - **NEVER call `sx_build`.** 600s watchdog will kill you before OCaml finishes. If sx_server binary is broken, add Blockers entry and stop. - **Shared-file issues** → plan's Blockers section with a minimal repro. Don't fix them. - **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5 (IO suspension via `perform`/`cek-resume`). `sx_summarise` spec/evaluator.sx first — it's 2300+ lines. - **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits. Never `Edit`/`Read`/`Write` on `.sx`. -- **Worktree:** commit locally. Never push. Never touch `main`. +- **Worktree:** commit, then push to `origin/loops/prolog`. Never touch `main`. - **Commit granularity:** one feature per commit. - **Plan file:** update Progress log + tick boxes every commit. - **If blocked** for two iterations on the same issue, add to Blockers and move on. diff --git a/plans/agent-briefings/tcl-loop.md b/plans/agent-briefings/tcl-loop.md index 449fe757..c3596794 100644 --- a/plans/agent-briefings/tcl-loop.md +++ b/plans/agent-briefings/tcl-loop.md @@ -11,7 +11,7 @@ isolation: worktree ## Prompt -You are the sole background agent working `/root/rose-ash/plans/tcl-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push. +You are the sole background agent working `/root/rose-ash/plans/tcl-on-sx.md`. Isolated worktree, forever, one commit per feature. Push to `origin/loops/tcl` after every commit. ## Restart baseline — check before iterating @@ -42,7 +42,7 @@ Every iteration: implement → test → commit → tick `[ ]` → Progress log - **Shared-file issues** → plan's Blockers with minimal repro. - **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines. - **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits. -- **Worktree:** commit locally. Never push. Never touch `main`. +- **Worktree:** commit, then push to `origin/loops/tcl`. Never touch `main`. - **Commit granularity:** one feature per commit. - **Plan file:** update Progress log + tick boxes every commit. diff --git a/plans/apl-on-sx.md b/plans/apl-on-sx.md index 6d8c491e..f9bea3b4 100644 --- a/plans/apl-on-sx.md +++ b/plans/apl-on-sx.md @@ -104,6 +104,16 @@ Core mapping: - [ ] Drive corpus to 100+ green - [ ] Idiom corpus — `lib/apl/tests/idioms.sx` covering classic Roger Hui / Phil Last idioms +## SX primitive baseline + +Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data; +coroutines for fibers; string-buffer for mutable string building; bitwise ops for bit +manipulation; multiple values for multi-return; promises for lazy evaluation; hash tables +for mutable associative storage; sets for O(1) membership; sequence protocol for +polymorphic iteration; gensym for unique symbols; char type for characters; string ports ++ read/write for reader protocols; regexp for pattern matching; bytevectors for binary +data; format for string templating. + ## Progress log _Newest first._ diff --git a/plans/common-lisp-on-sx.md b/plans/common-lisp-on-sx.md index 3b59215d..e3571a96 100644 --- a/plans/common-lisp-on-sx.md +++ b/plans/common-lisp-on-sx.md @@ -50,71 +50,102 @@ Core mapping: ## Roadmap ### Phase 1 — reader + parser -- [ ] Tokenizer: symbols (with package qualification `pkg:sym` / `pkg::sym`), numbers (int, float, ratio `1/3`, `#xFF`, `#b1010`, `#o17`), strings `"…"` with `\` escapes, characters `#\Space` `#\Newline` `#\a`, comments `;`, block comments `#| … |#` -- [ ] Reader: list, dotted pair, quote `'`, function `#'`, quasiquote `` ` ``, unquote `,`, splice `,@`, vector `#(…)`, uninterned `#:foo`, nil/t literals -- [ ] Parser: lambda lists with `&optional` `&rest` `&key` `&aux` `&allow-other-keys`, defaults, supplied-p variables -- [ ] Unit tests in `lib/common-lisp/tests/read.sx` +- [x] Tokenizer: symbols (with package qualification `pkg:sym` / `pkg::sym`), numbers (int, float, ratio `1/3`, `#xFF`, `#b1010`, `#o17`), strings `"…"` with `\` escapes, characters `#\Space` `#\Newline` `#\a`, comments `;`, block comments `#| … |#` +- [x] Reader: list, dotted pair, quote `'`, function `#'`, quasiquote `` ` ``, unquote `,`, splice `,@`, vector `#(…)`, uninterned `#:foo`, nil/t literals +- [x] Parser: lambda lists with `&optional` `&rest` `&key` `&aux` `&allow-other-keys`, defaults, supplied-p variables +- [x] Unit tests in `lib/common-lisp/tests/read.sx` ### Phase 2 — sequential eval + special forms -- [ ] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when` -- [ ] `block` + `return-from` via captured continuation -- [ ] `tagbody` + `go` via per-tag continuations -- [ ] `unwind-protect` cleanup frame -- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value` -- [ ] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op) -- [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope -- [ ] 60+ tests in `lib/common-lisp/tests/eval.sx` +- [x] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when` +- [x] `block` + `return-from` via captured continuation +- [x] `tagbody` + `go` via per-tag continuations +- [x] `unwind-protect` cleanup frame +- [x] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value` +- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op) +- [x] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope +- [x] 182 tests in `lib/common-lisp/tests/eval.sx` ### Phase 3 — conditions + restarts (THE SHOWCASE) -- [ ] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero` -- [ ] `signal`, `error`, `cerror`, `warn` — all walk the handler chain -- [ ] `handler-bind` — non-unwinding handlers, may decline by returning normally -- [ ] `handler-case` — unwinding handlers (delcc abort) -- [ ] `restart-case`, `with-simple-restart`, `restart-bind` -- [ ] `find-restart`, `invoke-restart`, `invoke-restart-interactively`, `compute-restarts` -- [ ] `with-condition-restarts` — associate restarts with a specific condition -- [ ] `*break-on-signals*`, `*debugger-hook*` (basic) -- [ ] Classic programs in `lib/common-lisp/tests/programs/`: - - [ ] `restart-demo.lisp` — division with `:use-zero` and `:retry` restarts - - [ ] `parse-recover.lisp` — parser with skipped-token restart - - [ ] `interactive-debugger.lisp` — ASCII REPL using `:debugger-hook` -- [ ] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` +- [x] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero` +- [x] `signal`, `error`, `cerror`, `warn` — all walk the handler chain +- [x] `handler-bind` — non-unwinding handlers, may decline by returning normally +- [x] `handler-case` — unwinding handlers (call/cc escape) +- [x] `restart-case`, `with-simple-restart`, `restart-bind` +- [x] `find-restart`, `invoke-restart`, `compute-restarts` +- [x] `with-condition-restarts` — associate restarts with a specific condition +- [x] `invoke-restart-interactively`, `*break-on-signals*`, `*debugger-hook*` (basic) +- [x] Classic programs in `lib/common-lisp/tests/programs/`: + - [x] `restart-demo.sx` — division with `use-zero` and `retry` restarts (7 tests) + - [x] `parse-recover.sx` — parser with skipped-token restart (6 tests) + - [x] `interactive-debugger.sx` — policy-driven debugger hook, *debugger-hook* global (7 tests) +- [x] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` (363 total tests) ### Phase 4 — CLOS -- [ ] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation` -- [ ] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors` -- [ ] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`) -- [ ] `defmethod` with `:before` / `:after` / `:around` qualifiers -- [ ] `call-next-method` (continuation), `next-method-p` -- [ ] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic) -- [ ] Multiple dispatch — method specificity by argument-class precedence list -- [ ] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`) -- [ ] Classic programs: - - [ ] `geometry.lisp` — `intersect` generic dispatching on (point line), (line line), (line plane)… - - [ ] `mop-trace.lisp` — `:before` + `:after` printing call trace +- [x] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation` +- [x] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors` +- [x] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`) +- [x] `defmethod` with `:before` / `:after` / `:around` qualifiers +- [x] `call-next-method` (continuation), `next-method-p` +- [x] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic) +- [x] Multiple dispatch — method specificity by argument-class precedence list +- [x] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`) +- [x] Classic programs: + - [x] `geometry.sx` — `intersect` generic dispatching on (point line), (line line), (line plane) — 12 tests + - [x] `mop-trace.sx` — `:before` + `:after` printing call trace — 13 tests ### Phase 5 — macros + LOOP + reader macros -- [ ] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand` -- [ ] `gensym`, `gentemp` -- [ ] `set-macro-character`, `set-dispatch-macro-character`, `get-macro-character` -- [ ] **The LOOP macro** — iteration drivers (`for … in/across/from/upto/downto/by`, `while`, `until`, `repeat`), accumulators (`collect`, `append`, `nconc`, `count`, `sum`, `maximize`, `minimize`), conditional clauses (`if`/`when`/`unless`/`else`), termination (`finally`/`thereis`/`always`/`never`), `named` blocks -- [ ] LOOP test corpus: 30+ tests covering all clause types +- [x] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand` +- [x] `gensym`, `gentemp` +- [x] `set-macro-character`, `set-dispatch-macro-character`, `get-macro-character` +- [x] **The LOOP macro** — iteration drivers (`for … in/across/from/upto/downto/by`, `while`, `until`, `repeat`), accumulators (`collect`, `append`, `nconc`, `count`, `sum`, `maximize`, `minimize`), conditional clauses (`if`/`when`/`unless`/`else`), termination (`finally`/`thereis`/`always`/`never`), `named` blocks +- [x] LOOP test corpus: 27 tests covering all clause types ### Phase 6 — packages + stdlib drive -- [ ] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package` -- [ ] Package qualification at the reader level — `cl:car`, `mypkg::internal` -- [ ] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages -- [ ] Sequence functions — `mapcar`, `mapc`, `mapcan`, `reduce`, `find`, `find-if`, `position`, `count`, `every`, `some`, `notany`, `notevery`, `remove`, `remove-if`, `subst` -- [ ] List ops — `assoc`, `getf`, `nth`, `last`, `butlast`, `nthcdr`, `tailp`, `ldiff` -- [ ] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate` -- [ ] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural) -- [ ] Drive corpus to 200+ green +- [x] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package` +- [x] Package qualification at the reader level — `cl:car`, `mypkg::internal` +- [x] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages +- [x] Sequence functions — `mapcar`, `mapc`, `mapcan`, `reduce`, `find`, `find-if`, `position`, `count`, `every`, `some`, `notany`, `notevery`, `remove`, `remove-if`, `subst` +- [x] List ops — `assoc`, `getf`, `nth`, `last`, `butlast`, `nthcdr`, `tailp`, `ldiff` +- [x] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate` +- [x] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural) +- [x] Drive corpus to 200+ green + +## SX primitive baseline + +Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data; +coroutines for fibers; string-buffer for mutable string building; bitwise ops for bit +manipulation; multiple values for multi-return; promises for lazy evaluation; hash tables +for mutable associative storage; sets for O(1) membership; sequence protocol for +polymorphic iteration; gensym for unique symbols; char type for characters; string ports ++ read/write for reader protocols; regexp for pattern matching; bytevectors for binary +data; format for string templating. ## Progress log _Newest first._ -- _(none yet)_ +- 2026-05-05: Phase 5 set-macro-character — cl-reader-macros + cl-dispatch-macros global dicts; SET-MACRO-CHARACTER/GET-MACRO-CHARACTER/SET-DISPATCH-MACRO-CHARACTER dispatch in eval.sx (stores fn, doesn't wire into reader — stubs sufficient to avoid errors). Phase 5 fully ticked. Phase 6 Drive corpus 200+ ticked (518 total, 54 stdlib). All roadmap items done. + +- 2026-05-05: Phase 6 packages — defpackage/in-package/export/use-package/import/find-package/package-name; cl-packages dict, cl-current-package; cl-package-sep? strips pkg: prefix from symbols+functions; package-qualified calls (cl:car, cl:mapcar) work. 4 package tests added; 518 total tests, 0 failed. + +- 2026-05-05: Phase 6 FORMAT — cl-fmt-a/cl-fmt-s/cl-fmt-find-close/cl-fmt-iterate/cl-fmt-loop in eval.sx; ~A/~S/~D/~F/~%/~&/~T/~P/~{...~}/~[...~]/~^/~~; also fixed substr(start,length) semantics throughout (SUBSEQ, cl-fmt-loop); 6 FORMAT tests added to stdlib.sx; 514 total tests, 0 failed. + +- 2026-05-05: Phase 6 stdlib — sequence functions (mapc/mapcan/reduce/find/find-if/find-if-not/position/position-if/count/count-if/every/some/notany/notevery/remove/remove-if/remove-if-not/subst/member), list ops (assoc/rassoc/getf/last/butlast/nthcdr/copy-list/list*/caar/cadr/cdar/cddr/caddr/cadddr/pairlis), string ops (subseq/string/char/string-length/string), plus coerce/make-list/write-to-string; 44 tests in tests/stdlib.sx; Phase 6 sequence+list+string boxes ticked. Total: 508 tests, 0 failed. + +- 2026-05-05: Phase 4 CLOS fully complete — `lib/common-lisp/clos.sx` (27 forms): clos-class-registry (8 built-in classes), defclass/make-instance/slot-value/slot-boundp/set-slot-value!/find-class/change-class, defgeneric/defmethod with :before/:after/:around, clos-call-generic (standard method combination: sort by specificity, fire befores, call primary chain, fire afters in reverse), call-next-method/next-method-p, with-slots, accessor installation; 41 tests in `tests/clos.sx`; classic programs `geometry.sx` (12 tests, multi-dispatch intersect on P/L/Plane) and `mop-trace.sx` (13 tests, :before/:after tracing). Dynamic variables in eval.sx: cl-apply-dyn saves/restores global bindings around let for specials (cl-mark-special!/cl-special?/cl-dyn-unbound). Key gotchas: qualifier strings are "before"/"after"/"around" (no colon); dict-set pure = assoc; dict->list = (map (fn (k) (list k (get d k))) (keys d)); clos-add-reader-method bootstrapped via set! after defmethod defined; test isolation: use unique var names to avoid *y* collision. 437 total tests, 0 failed. +- 2026-05-05: Phase 3 fully complete — conformance.sh runner + scoreboard.json/scoreboard.md; 363 total tests across all suites (79 reader, 31 parser, 174 eval, 59 conditions, 7+6+7 classic programs). +- 2026-05-05: Phase 3 complete — cl-debugger-hook/cl-invoke-debugger in runtime.sx (cl-error routes through hook), cl-break-on-signals (fires hook before handlers on type match), cl-invoke-restart-interactively (calls fn with no args); 4 new tests (147 total). Phase 3 all boxes ticked. +- 2026-05-05: Phase 3 interactive-debugger.sx — cl-debugger-hook global, cl-invoke-debugger, cl-error-with-debugger, make-policy-debugger; 7 tests (143 total). Tests wired into test.sh program suite runner. Phase 3 condition core complete. +- 2026-05-05: Phase 3 classic programs — `tests/programs/restart-demo.sx` (7 tests: safe-divide with use-zero + retry restarts) and `tests/programs/parse-recover.sx` (6 tests: token parser with skip-token + use-zero restarts, handler-case abort). Key gotcha: use `=` not `equal?` for list comparison in sx_server. +- 2026-05-05: Phase 3 conditions + restarts — `cl-condition-classes` hierarchy (15 types), `cl-condition?`/`cl-condition-of-type?`, `cl-make-condition`, `cl-define-condition`, `cl-signal`/`cl-error`/`cl-warn`/`cl-cerror`, `cl-handler-bind` (non-unwinding), `cl-handler-case` (call/cc escape), `cl-restart-case`/`cl-with-simple-restart`, `cl-find-restart`/`cl-invoke-restart`/`cl-compute-restarts`, `cl-with-condition-restarts`; 55 new tests in `tests/conditions.sx` (123 total runtime tests). Key gotcha: `cl-condition-classes` must be captured at define-time via `let` in `cl-condition-of-type?` — free-variable lookup at call-time fails through env_merge parent chain. +- 2026-05-05: multiple values — VALUES returns {:cl-type "mv"} wrapper for 2+ values; cl-mv-primary/cl-mv-vals helpers; MULTIPLE-VALUE-BIND binds vars to value list; MULTIPLE-VALUE-CALL/PROG1/NTH-VALUE; cl-mv-primary applied in IF/AND/OR/COND/cl-call-fn for single-value contexts; 15 new tests (174 eval, 346 total green). +- 2026-05-05: unwind-protect — cl-eval-unwind-protect: eval protected form, run cleanup with for-each (discards results, preserves original sentinel), return original result; 8 new tests (159 eval, 331 total green). +- 2026-05-05: tagbody + go — cl-go-tag? sentinel; cl-eval-tagbody runs body with tag-index map (keys str-normalised for integer tags); go-tag propagation in cl-eval-body alongside block-return; 11 new tests (151 eval, 323 total green). +- 2026-05-05: block + return-from — sentinel propagation in cl-eval-body; cl-eval-block catches matching sentinels; BLOCK/RETURN-FROM/RETURN dispatch in cl-eval-list; 13 new tests (140 eval, 312 total green). Parser: CL strings → {:cl-type "string"} dicts. +- 2026-04-25: Phase 2 eval — 127 tests, 299 total green. `lib/common-lisp/eval.sx`: cl-eval-ast with quote/if/progn/let/let*/flet/labels/setq/setf/function/lambda/the/locally/eval-when; defun/defvar/defparameter/defconstant; built-in arithmetic (+/-/*//, min/max/abs/evenp/oddp), comparisons, predicates, list ops (car/cdr/cons/list/append/reverse/length/nth/first/second/third/rest), string ops, funcall/apply/mapcar. Key gotchas: SX reduce is (reduce fn init list) not (reduce fn list init); CL true literal is t not true; builtins registered in cl-global-env.fns via wrapper dicts for #' syntax. +- 2026-04-25: Phase 1 lambda-list parser — 31 new tests, 172 total green. `cl-parse-lambda-list` in `parser.sx` + `tests/lambda.sx`. Handles &optional/&rest/&body/&key/&aux/&allow-other-keys, defaults, supplied-p. Key gotchas: `(when (> (len items) 0) ...)` not `(when items ...)` (empty list is truthy); custom `cl-deep=` needed for dict/list structural equality in tests. +- 2026-04-25: Phase 1 reader/parser — 62 new tests, 141 total green. `lib/common-lisp/parser.sx`: cl-read/cl-read-all, lists, dotted pairs, quote/backquote/unquote/splice/#', vectors, #:uninterned, NIL→nil, T→true, reader macro wrappers. +- 2026-04-25: Phase 1 tokenizer — 79 tests green. `lib/common-lisp/reader.sx` + `tests/read.sx` + `test.sh`. Handles symbols (pkg:sym, pkg::sym), integers, floats, ratios, hex/binary/octal, strings, #\ chars, reader macros (#' #( #: ,@), line/block comments. Key gotcha: SX `str` for string concat (not `concat`), substring-based read-while. ## Blockers diff --git a/plans/datalog-on-sx.md b/plans/datalog-on-sx.md new file mode 100644 index 00000000..79adc148 --- /dev/null +++ b/plans/datalog-on-sx.md @@ -0,0 +1,145 @@ +# Datalog-on-SX: Datalog on the CEK/VM + +Datalog is a declarative query language: a restricted subset of Prolog with no function +symbols, only relations. Programs are sets of facts and rules; queries ask what follows. +Evaluation is bottom-up (fixpoint iteration) rather than Prolog's top-down DFS — which +means no infinite loops, guaranteed termination, and efficient incremental updates. + +The unique angle: Datalog is a natural companion to the Prolog implementation already in +progress (`lib/prolog/`). The parser and term representation can share infrastructure; +the evaluator is an entirely different fixpoint engine rather than a DFS solver. + +End-state goal: **full core Datalog** (facts, rules, stratified negation, aggregation, +recursion) with a clean SX query API, and a demonstration of Datalog as a query engine +for rose-ash data (e.g. federation graph, content relationships). + +## Ground rules + +- **Scope:** only touch `lib/datalog/**` and `plans/datalog-on-sx.md`. Do **not** edit + `spec/`, `hosts/`, `shared/`, `lib/prolog/**`, or other `lib//`. +- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here. +- **SX files:** use `sx-tree` MCP tools only. +- **Architecture:** Datalog source → term AST → fixpoint evaluator. No transpiler to SX AST — + the evaluator is written in SX and works directly on term structures. +- **Reference:** Ramakrishnan & Ullman "A Survey of Deductive Database Systems"; + Dalmau "Datalog and Constraint Satisfaction". +- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes. + +## Architecture sketch + +``` +Datalog source text + │ + ▼ +lib/datalog/tokenizer.sx — atoms, variables, numbers, strings, punct (?- :- , . ( ) [ ]) + │ + ▼ +lib/datalog/parser.sx — facts: atom(args). rules: head :- body. queries: ?- goal. + │ No function symbols (only constants and variables in args). + ▼ +lib/datalog/db.sx — extensional DB (EDB): ground facts; IDB: derived relations; + │ clause index by relation name/arity + ▼ +lib/datalog/eval.sx — bottom-up fixpoint: semi-naive evaluation with delta sets; + │ stratification for negation; incremental update API + ▼ +lib/datalog/query.sx — query API: (datalog-query db goal) → list of substitutions; + SX embedding: define facts/rules as SX data directly +``` + +Key differences from Prolog: +- **No function symbols** — args are atoms, numbers, strings, or variables only. No `f(a,b)`. +- **No cuts** — no procedural control. +- **Bottom-up** — derive all consequences of all rules before answering; no search tree. +- **Termination guaranteed** — no infinite derivation chains (no function symbols → finite Herbrand base). +- **Stratified negation** — `not(P)` legal iff P does not recursively depend on its own negation. +- **Aggregation** — `count`, `sum`, `min`, `max` over derived tuples (Datalog+). + +## Roadmap + +### Phase 1 — tokenizer + parser +- [ ] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings, + operators (`:- `, `?-`, `,`, `.`), comments (`%`, `/* */`) + Note: no function symbol syntax (no nested `f(...)` in arg position). +- [ ] Parser: + - Facts: `parent(tom, bob).` → `{:head (parent tom bob) :body ()}` + - Rules: `ancestor(X,Z) :- parent(X,Y), ancestor(Y,Z).` + → `{:head (ancestor X Z) :body ((parent X Y) (ancestor Y Z))}` + - Queries: `?- ancestor(tom, X).` → `{:query (ancestor tom X)}` + - Negation: `not(parent(X,Y))` in body position → `{:neg (parent X Y)}` +- [ ] Tests in `lib/datalog/tests/parse.sx` + +### Phase 2 — unification + substitution +- [ ] Share or port unification from `lib/prolog/` — term walk, occurs check off by default +- [ ] `dl-unify` `t1` `t2` `subst` → extended subst or nil (no function symbols means simpler) +- [ ] `dl-ground?` `term` → bool — all variables bound in substitution +- [ ] Tests: atom/atom, var/atom, var/var, list args + +### Phase 3 — extensional DB + naive evaluation +- [ ] EDB: `{:relation-name → set-of-ground-tuples}` using SX sets (Phase 18 of primitives) +- [ ] `dl-add-fact!` `db` `relation` `args` → add ground tuple +- [ ] `dl-add-rule!` `db` `head` `body` → add rule clause +- [ ] Naive evaluation: iterate rules until fixpoint + For each rule, for each combination of body tuples that unify, derive head tuple. + Repeat until no new tuples added. +- [ ] `dl-query` `db` `goal` → list of substitutions satisfying goal against derived DB +- [ ] Tests: transitive closure (ancestor), sibling, same-generation — classic Datalog programs + +### Phase 4 — semi-naive evaluation (performance) +- [ ] Delta sets: track newly derived tuples per iteration +- [ ] Semi-naive rule: only join against delta tuples from last iteration, not full relation +- [ ] Significant speedup for recursive rules — avoids re-deriving known tuples +- [ ] `dl-stratify` `db` → dependency graph + SCC analysis → stratum ordering +- [ ] Tests: verify semi-naive produces same results as naive; benchmark on large ancestor chain + +### Phase 5 — stratified negation +- [ ] Dependency graph analysis: which relations depend on which (positively or negatively) +- [ ] Stratification check: error if negation is in a cycle (non-stratifiable program) +- [ ] Evaluation: process strata in order — lower stratum fully computed before using its + complement in a higher stratum +- [ ] `not(P)` in rule body: at evaluation time, check P is NOT in the derived EDB +- [ ] Tests: non-member (`not(member(X,L))`), colored-graph (`not(same-color(X,Y))`), + stratification error detection + +### Phase 6 — aggregation (Datalog+) +- [ ] `count(X, Goal)` → number of distinct X satisfying Goal +- [ ] `sum(X, Goal)` → sum of X values satisfying Goal +- [ ] `min(X, Goal)` / `max(X, Goal)` → min/max of X satisfying Goal +- [ ] `group-by` semantics: `count(X, sibling(bob, X))` → count of bob's siblings +- [ ] Aggregation breaks stratification — evaluate in a separate post-fixpoint pass +- [ ] Tests: social network statistics, grade aggregation, inventory sums + +### Phase 7 — SX embedding API +- [ ] `(dl-program facts rules)` → database from SX data directly (no parsing required) + ``` + (dl-program + '((parent tom bob) (parent tom liz) (parent bob ann)) + '((ancestor X Z :- (parent X Y) (ancestor Y Z)) + (ancestor X Y :- (parent X Y)))) + ``` +- [ ] `(dl-query db '(ancestor tom ?X))` → `((ann) (bob) (liz) (pat))` +- [ ] `(dl-assert! db '(parent ann pat))` → incremental fact addition + re-derive +- [ ] `(dl-retract! db '(parent tom bob))` → fact removal + re-derive from scratch +- [ ] Integration demo: federation graph query — `(ancestor actor1 actor2)` over + rose-ash ActivityPub follow relationships + +### Phase 8 — Datalog as a query language for rose-ash +- [ ] Schema: map SQLAlchemy model relationships to Datalog EDB facts + (e.g. `(follows user1 user2)`, `(authored user post)`, `(tagged post tag)`) +- [ ] Loader: `dl-load-from-db!` — query PostgreSQL, populate Datalog EDB +- [ ] Query examples: + - `?- ancestor(me, X), authored(X, Post), tagged(Post, cooking).` + → posts about cooking by people I follow (transitively) + - `?- popular(Post) :- tagged(Post, T), count(L, (liked(L, Post))) >= 10.` + → posts with 10+ likes +- [ ] Expose as a rose-ash service endpoint: `POST /internal/datalog` with program + query + +## Blockers + +_(none yet)_ + +## Progress log + +_Newest first._ + +_(awaiting phase 1)_ diff --git a/plans/designs/f-breakpoint.md b/plans/designs/f-breakpoint.md new file mode 100644 index 00000000..4a8f52a5 --- /dev/null +++ b/plans/designs/f-breakpoint.md @@ -0,0 +1,80 @@ +# F-Breakpoint — `breakpoint` command (+2) + +**Suite:** `hs-upstream-breakpoint` +**Target:** Both tests are `SKIP (untranslated)`. + +## 1. The 2 tests + +- `parses as a top-level command` +- `parses inside an event handler` + +Both are untranslated — no test body exists. The test names say "parses" — these are parser tests, not runtime tests. + +## 2. What upstream checks + +From `test/core/breakpoint.js`: + +```js +it('parses as a top-level command', () => { + expect(() => _hyperscript.evaluate("breakpoint")).not.toThrow(); +}); +it('parses inside an event handler', () => { + const el = document.createElement('div'); + el.setAttribute('_', 'on click breakpoint'); + expect(() => _hyperscript.processNode(el)).not.toThrow(); +}); +``` + +Both tests verify that `breakpoint` is accepted by the parser without throwing. Neither test checks that the debugger actually fires. `breakpoint` is a no-op command in production builds — it calls `debugger` in JS, which is a no-op when devtools are closed. + +## 3. What's needed + +### Parser (`lib/hyperscript/parser.sx`) + +Add `breakpoint` to the command dispatch — it should parse as a zero-argument command. The parser's command `cond` (wherever `add`, `remove`, `hide` etc. are dispatched) needs a branch: + +``` +((= val "breakpoint") (hs-parse-breakpoint)) +``` + +`hs-parse-breakpoint` just returns a `{:cmd "breakpoint"}` AST node (or however commands are represented). It consumes no additional tokens. + +### Compiler (`lib/hyperscript/compiler.sx`) + +Add a compiler branch for `breakpoint` AST node. Emits a no-op or a `debugger` statement equivalent. Since we're in SX (not JS), a no-op `(do nil)` is correct. + +### Generator (`tests/playwright/generate-sx-tests.py`) + +The 2 tests are simple — hand-write them: + +```lisp +(deftest "parses as a top-level command" + (let ((result (guard (e (true false)) + (hs-compile "breakpoint") + true))) + (assert result))) + +(deftest "parses inside an event handler" + (hs-cleanup!) + (let ((el (dom-create-element "div"))) + (dom-set-attr el "_" "on click breakpoint") + (let ((result (guard (e (true false)) + (hs-activate! el) + true))) + (assert result)))) +``` + +## 4. Implementation checklist + +1. `sx_find_all` in `lib/hyperscript/parser.sx` for the command dispatch `cond`. +2. Add `breakpoint` branch → `hs-parse-breakpoint` function returning minimal command node. +3. `sx_find_all` in `lib/hyperscript/compiler.sx` for command compilation dispatch. +4. Add `breakpoint` branch → emit no-op. +5. Replace 2 `SKIP` bodies in `spec/tests/test-hyperscript-behavioral.sx` with translated tests above. +6. Run `hs_test_run suite="hs-upstream-breakpoint"` — expect 2/2. +7. Run smoke 0–195 — no regressions. +8. Commit: `HS: breakpoint command — parser + no-op compiler (+2)` + +## 5. Risk + +Very low. Zero-argument no-op command. The only risk is mis-locating the command dispatch branch in the parser. diff --git a/plans/designs/f1-null-safety.md b/plans/designs/f1-null-safety.md new file mode 100644 index 00000000..7c3e0e76 --- /dev/null +++ b/plans/designs/f1-null-safety.md @@ -0,0 +1,68 @@ +# F1 — Null Safety Reporting (+7) + +**Suite:** `hs-upstream-core/runtimeErrors` +**Target:** 7 currently-failing tests (decrement, default, increment, put, remove, settle, transition commands) + +## 1. Failing tests + +The suite has 18 tests total; 11 already pass. The 7 failures all share the pattern: + +``` +Expected '#doesntExist' is null, got +``` + +The `eval-hs-error` helper already exists (landed in null-safety piece 1). It compiles and runs a HS snippet and returns the error string. The problem is that the listed commands don't guard against null targets before operating, so they produce no error (or a cryptic one) instead of `"'#doesntExist' is null"`. + +| Test | Command | Null target expression | +|------|---------|----------------------| +| decrement | `decrement #doesntExist's innerHTML` | `#doesntExist` | +| default | `default #doesntExist's innerHTML to 'foo'` | `#doesntExist` | +| increment | `increment #doesntExist's innerHTML` | `#doesntExist` | +| put | `put 'foo' into/before/after/at start of/at end of #doesntExist` | `#doesntExist` | +| remove | `remove .foo/.@foo/#doesntExist from #doesntExist` | `#doesntExist` | +| settle | `settle #doesntExist` | `#doesntExist` | +| transition | `transition #doesntExist's *visibility to 0` | `#doesntExist` | + +Note: add, hide, measure, send, sets, show, toggle, trigger already pass — they already guard. + +## 2. Required error format + +``` +'#doesntExist' is null +``` + +The apostrophe-quoted selector string followed by ` is null`. The selector text is the original source text of the element expression (e.g. `#doesntExist`, not a stringified DOM node). + +This is the same format already used by passing commands. The null-safety piece 1 commit added `eval-hs-error` and `hs-null-error` helper — just need to call it at the right point in each missing command. + +## 3. Where to add guards + +All in `lib/hyperscript/runtime.sx`. Pattern for each command: + +``` +(when (nil? target) + (hs-null-error target-source-text)) +``` + +Where `hs-null-error` (or equivalent) raises with the formatted message. + +### Per-command location + +- **decrement / increment** — after resolving the target element, before reading/writing innerHTML +- **default** — after resolving target element, before reading current value +- **put** — after resolving destination element (covers all put variants: into, before, after, at start, at end) +- **remove** — after resolving the `from` target element +- **settle** — after resolving target element, before starting transition poll +- **transition** — after resolving target element, before reading/setting style + +## 4. Implementation checklist + +1. Find each failing command's runtime function in `lib/hyperscript/runtime.sx` using `sx_find_all`. +2. For each: `sx_read_subtree` on the function body, locate where target is resolved, insert null guard calling `hs-null-error` (or the equivalent raise form already used by passing commands). +3. After all 7: run `hs_test_run suite="hs-upstream-core/runtimeErrors"` — expect 18/18. +4. Run smoke range 0–195 — expect no regressions. +5. Commit: `HS: null-safety guards on decrement/default/increment/put/remove/settle/transition (+7)` + +## 5. Risk + +Low. The pattern is established by the 11 already-passing tests. The only risk is finding the correct point in each command where the element is resolved and before it's first used. diff --git a/plans/designs/f13-step-limit-and-meta.md b/plans/designs/f13-step-limit-and-meta.md new file mode 100644 index 00000000..3630a17e --- /dev/null +++ b/plans/designs/f13-step-limit-and-meta.md @@ -0,0 +1,166 @@ +# F13 — Step Limit + `meta.caller` (+5 → 100%) + +Five tests currently timeout or produce wrong values due to two root causes: +step budget exhaustion and a missing `meta` implementation. + +## Tests + +| # | Suite | Test | Failure | +|---|-------|------|---------| +| 198 | `hs-upstream-core/runtime` | `has proper stack from event handler` | wrong-value: `meta.caller` returns `""` instead of an object with `.meta.feature.type = "onFeature"` | +| 200 | `hs-upstream-core/runtime` | `hypertrace is reasonable` | TIMEOUT (15s, step limit) | +| 615 | `hs-upstream-expressions/in` | `query template returns values` | TIMEOUT (37s, step limit) | +| 1197 | `hs-upstream-repeat` | `repeat forever works` | TIMEOUT (step limit) | +| 1198 | `hs-upstream-repeat` | `repeat forever works w/o keyword` | TIMEOUT (step limit) | + +--- + +## Root cause A — Step limit (tests 200, 615, 1197, 1198) + +The runner sets `HS_STEP_LIMIT=200000`. Every CEK step consumed by any +expression in a test — including the double compilation warm-up guard blocks +that appear before the actual DOM test — counts against this shared budget. + +### `repeat forever` (1197, 1198) + +The loop body terminates in exactly **5 iterations** (`if retVal == 5 then return`). +This is bounded, not infinite. The step budget is exhausted before the loop +runs because two `eval-expr-cek` compilation warm-up calls each consume tens +of thousands of steps. + +Fix: each warm-up guard compiles and discards a HS function definition. Those +calls are defensive (wrapped in `guard` that swallows errors). We do NOT need +to run the compiled code — the warm-up's purpose is just to ensure the +compiler doesn't crash, not to consume steps. The step counter should not tick +during compilation (compilation is a pure transform, not evaluation). If that's +impractical to gate, raise `HS_STEP_LIMIT` to `2000000` (10×). + +### `hypertrace is reasonable` (200) + +Defines `bar()` → calls `baz()` → throws. Simple call chain. The "hypertrace" +in the test name implies the HS runtime trace recorder is active during the +test. If trace recording is on globally, every CEK step generates a trace entry +allocation. Fix: confirm whether trace recording is always-on in the test runner +and disable it by default (trace should only be on when explicitly requested). +Alternatively raise step limit. + +### `query template returns values` (615) + +Uses `<${"p"}/>` — a CSS query selector built from a template string. Takes 37 +seconds. Likely the template selector evaluation triggers repeated DOM scanning +or expensive string construction per step. Fix: profile with `hs_test_run +verbose=true` to identify which step is slow. If it's a regex compilation +per-call, cache it. If step limit only, raise to 2M. + +### Unified fix: raise `HS_STEP_LIMIT` to `2000000` + +The simplest fix that unblocks all four timeout tests. In +`tests/hs-run-filtered.js`, change the default step limit. Per-test overrides +can still be set via `HS_STEP_LIMIT` env var for debugging. + +If the `query template` test is still slow at 2M steps (37s × 10 = 370s, which +would be unacceptable), that test needs a separate performance fix — cache the +compiled regex/query from the template string rather than rebuilding it on every +access. + +--- + +## Root cause B — `meta.caller` not implemented (test 198) + +The HS `meta` object is available inside any function call. It exposes: + +- `meta.caller` — the calling context object +- `meta.caller.meta.feature.type` — the HS feature type of the caller + (e.g. `"onFeature"` when called from an `on click` handler) + +Test script: +``` +def bar() + log meta.caller + return meta.caller +end +``` +Triggered via `on click put bar().meta.feature.type into my.innerHTML`. +Expects `"onFeature"` in innerHTML. Currently gets `""`. + +### What `meta` needs + +`meta` is a dict-like object injected into every function's execution context +at call time. Minimum fields for this test: + +``` +meta = { + :caller + :element +} +``` + +`meta.caller.meta.feature.type` must return `"onFeature"` when called from an +`on` event handler. The feature type string `"onFeature"` is already used +internally (event handler features are tagged with this type). + +### Implementation + +In `lib/hyperscript/runtime.sx`, at the point where a HS `def` function is +called: + +1. Build a `meta` dict: + ``` + {:caller calling-context :element current-element} + ``` + where `calling-context` is the current runtime context dict (which includes + its own `:meta` field with `:feature {:type "onFeature"}` for event handlers). + +2. Bind `meta` in the function's execution env. + +3. Ensure event handler contexts carry `{:meta {:feature {:type "onFeature"}}}`. + +This is an additive change — nothing currently uses `meta`, so no regression +risk. + +--- + +## Implementation checklist + +### Step A — Raise step limit +1. In `tests/hs-run-filtered.js`, change default `HS_STEP_LIMIT` from `200000` + to `2000000`. +2. Run tests 1197–1198: `hs_test_run(start=1197, end=1199)` — expect 2/2. +3. Run test 615: `hs_test_run(start=615, end=616)` — expect 1/1 or note if + still too slow. +4. Run test 200: `hs_test_run(start=200, end=201)` — expect 1/1. + +### Step B — `meta.caller` (test 198) +5. `sx_find_all` in `lib/hyperscript/runtime.sx` for where `def` functions are + called / where event handler contexts are constructed. +6. Add `meta` dict construction at call time; bind in function env. +7. Ensure `on` handler context carries `{:meta {:feature {:type "onFeature"}}}`. +8. Run test 198: `hs_test_run(start=198, end=199)` — expect 1/1. + +### Step C — Query template performance (if still slow after step A) +9. Profile `hs_test_run(start=615, end=616, step_limit=2000000, verbose=true)`. +10. If the CSS template query `<${"p"}/>` rebuilds on every call, add a memoize + cache keyed on the template result string. +11. Rerun — expect < 5s. + +### Step D — Full suite verification +12. Run all ranges with raised step limit: + - `hs_test_run(start=0, end=201, step_limit=2000000)` + - `hs_test_run(start=201, end=616, step_limit=2000000)` + - `hs_test_run(start=616, end=1200, step_limit=2000000)` + - `hs_test_run(start=1200, end=1496, step_limit=2000000)` +13. Confirm all previously-passing tests still pass. +14. Commit: `HS: raise step limit to 2M + meta.caller for onFeature stack (+5)` + +--- + +## Risk + +- **Step limit raise:** May make test suite slower overall (more steps to exhaust + before timeout). But if tests pass quickly the limit is never reached. + The 37s query-template test is the only real concern — if it genuinely needs + 2M steps × (time per step), it needs a performance fix too. +- **`meta.caller`:** Additive binding in function scope. Zero regression risk. + The only complexity is constructing the right shape for the calling context + chain — but since only one test exercises this and the shape is simple, the + risk is low. diff --git a/plans/designs/f2-tell.md b/plans/designs/f2-tell.md new file mode 100644 index 00000000..e7922db7 --- /dev/null +++ b/plans/designs/f2-tell.md @@ -0,0 +1,81 @@ +# F2 — `tell` Semantics Fix (+3) + +**Suite:** `hs-upstream-tell` +**Target:** 3 failing tests out of 10. 7 already pass. + +## 1. Failing tests + +### "attributes refer to the thing being told" +``` +on click tell #d2 then put @foo into me +``` +d2 has attribute `foo="bar"`. After click, d1's text content should be `"bar"`. +`@foo` is an attribute ref — it should resolve against the **told element** (d2), not the event target (d1). +Currently gets `""` — attribute resolves against d1, which has no `foo` attribute. + +### "your symbol represents the thing being told" +``` +on click tell #d2 then put your innerText into me +``` +d2 has innerText `"foo"`. After click, d1's text content should be `"foo"`. +`your` is the possessive of `you` — inside a `tell` block, `you`/`your` should bind to the told element. +Currently gets `""`. + +### "does not overwrite the me symbol" +``` +on click add .foo then tell #d2 then add .bar to me +``` +After click: d1 should have both `.foo` and `.bar`; d2 should have neither. +`me` inside the `tell` block must still refer to d1 (the original event target). +Currently: assertion fails — `.bar` is going to d2 instead of d1. + +## 2. What the 7 passing tests reveal about current behaviour + +The passing tests include: +- `you symbol represents the thing being told` — `add .bar to you` adds to d2 ✓ +- `establishes a proper beingTold symbol` — bare `add .bar` (no target) adds to the told element ✓ +- `restores a proper implicit me symbol` — after `tell` block ends, bare commands target d1 again ✓ +- `yourself attribute also works` — `remove yourself` inside tell removes d2 ✓ + +So `you`, `yourself`, and bare implicit target all work. The three bugs are: +1. Attribute refs (`@foo`) don't resolve against the told element +2. `your` (possessive of `you`) doesn't resolve +3. `me` is being rebound to the told element instead of kept as d1 + +## 3. Root cause analysis + +Inside a `tell X` block, the runtime sets the implicit target to X. The three failures suggest: + +**Bug A — attribute refs:** `@foo` resolves via a property-access path that reads from the *current event target* (`me`/`self`), not from the *implicit tell target*. The tell block sets implicit target but the attribute ref lookup skips it. + +**Bug B — `your`:** `your` is parsed as a possessive modifier expecting `you` to be bound. If `you` is not bound in the tell scope (and only the implicit target is set), `your X` fails to resolve. + +**Bug C — `me` rebinding:** The tell command saves/restores `me` but the save/restore is either not happening or is restoring the wrong value. `me` inside the block should remain d1 while the implicit default target is d2. + +## 4. Fix + +In `lib/hyperscript/runtime.sx`, find the `tell` command handler (search for `hs-tell` or the tell dispatch branch). + +The correct semantics: +- Save current `me` value +- Set implicit target (used by bare commands like `add .bar`) to the told element +- Bind `you` = told element (so `you`, `your`, `yourself` work) +- Do **not** rebind `me` — keep it as the original event target +- Restore implicit target and unbind `you` after the block + +For attribute refs (`@foo`): resolve against the current *implicit target* (told element), not against `me`. Find where `@attr` expressions are evaluated and ensure they read from the implicit target when inside a tell block. + +## 5. Implementation checklist + +1. `sx_find_all` in `lib/hyperscript/runtime.sx` for tell handler. +2. `sx_read_subtree` on the tell handler — verify save/restore of `me` vs implicit target. +3. Fix `me` rebinding: save old implicit target, set new one, do NOT touch `me`. +4. Bind `you`/`your`/`yourself` to told element in the tell scope env. +5. Find attribute ref (`@`) evaluation — ensure it reads from implicit target. +6. Run `hs_test_run suite="hs-upstream-tell"` — expect 10/10. +7. Run smoke 0–195 — no regressions. +8. Commit: `HS: tell — fix me rebinding, your/attribute-ref resolution (+3)` + +## 6. Risk + +Medium. The 7 passing tests constrain what can change — the fix must preserve `you`, `yourself`, bare implicit target, and restore-after-tell semantics. The three bugs are independent enough that they can be fixed one at a time and verified after each. diff --git a/plans/designs/f5-cookies.md b/plans/designs/f5-cookies.md new file mode 100644 index 00000000..bbceba2f --- /dev/null +++ b/plans/designs/f5-cookies.md @@ -0,0 +1,128 @@ +# F5 — Cookie API (+5) + +**Suite:** `hs-upstream-expressions/cookies` +**Target:** All 5 tests are `SKIP (untranslated)`. + +## 1. The 5 tests + +From upstream `test/expressions/cookies.js`: + +| Test | What it checks | +|------|---------------| +| `length is 0 when no cookies are set` | `cookies.length == 0` with no cookies set | +| `basic set cookie values work` | `set cookies.name to "value"` then `cookies.name == "value"` | +| `update cookie values work` | set, then set again, value updates | +| `basic clear cookie values work` | `set cookies.name to "value"` then `clear cookies.name`, then `cookies.name == undefined` | +| `iterate cookies values work` | `for name in cookies` iterates cookie names | + +## 2. HyperScript cookie syntax + +`cookies` is a special global expression in HyperScript backed by `document.cookie`. The upstream implementation wraps `document.cookie` in a proxy: + +- `cookies.name` → read cookie by name (returns string or `undefined`) +- `set cookies.name to val` → write cookie (sets `document.cookie = "name=val"`) +- `clear cookies.name` → delete cookie (sets max-age=-1) +- `cookies.length` → number of cookies set +- `for name in cookies` → iterate over cookie names + +## 3. Test runner mock + +All 5 tests are untranslated — no SX test bodies exist yet. The generator needs patterns for the cookie expressions, and `hs-run-filtered.js` needs a `document.cookie` mock. + +### Mock in `tests/hs-run-filtered.js` + +Add a simple in-memory cookie store to the `dom` mock: + +```js +let _cookieStore = {}; +Object.defineProperty(global.document, 'cookie', { + get() { + return Object.entries(_cookieStore) + .map(([k,v]) => `${k}=${v}`) + .join('; '); + }, + set(str) { + const [pair, ...attrs] = str.split(';'); + const [name, val] = pair.split('=').map(s => s.trim()); + const maxAge = attrs.find(a => a.trim().startsWith('max-age=')); + if (maxAge && parseInt(maxAge.split('=')[1]) < 0) { + delete _cookieStore[name]; + } else { + _cookieStore[name] = val; + } + }, + configurable: true +}); +``` + +Add `_cookieStore = {}` reset to `hs-cleanup!` equivalent in the runner. + +## 4. SX runtime additions in `lib/hyperscript/runtime.sx` + +HS needs a `cookies` special expression that the compiler resolves. Two approaches: + +**Option A (simpler):** Treat `cookies` as a built-in variable bound to a proxy dict at runtime. When property access `cookies.name` is evaluated, dispatch to cookie read/write helpers. + +**Option B (upstream-faithful):** Parse `cookies` as a special primary expression, emit runtime calls `hs-cookie-get`, `hs-cookie-set`, `hs-cookie-delete`, `hs-cookie-length`, `hs-cookie-names`. + +Option A is less invasive. The runtime env gets a `cookies` binding pointing to a special object; property access and assignment on it dispatch to the cookie helpers, which call `(platform-cookie-get name)` / `(platform-cookie-set name val)` / `(platform-cookie-delete name)`. + +Platform cookie operations map to `document.cookie` reads/writes in JS. + +## 5. Generator patterns (`tests/playwright/generate-sx-tests.py`) + +The upstream tests use patterns like: + +```js +await page.evaluate(() => { _hyperscript.evaluate("set cookies.foo to 'bar'") }); +expect(await page.evaluate(() => _hyperscript.evaluate("cookies.foo"))).toBe("bar"); +``` + +In our SX harness these become direct `eval-hs` calls. Since all 5 tests are untranslated, hand-write them rather than extending the generator (similar to E39). + +## 6. Translated test bodies + +```lisp +(deftest "length is 0 when no cookies are set" + (hs-cleanup!) + (assert= (eval-hs "cookies.length") 0)) + +(deftest "basic set cookie values work" + (hs-cleanup!) + (eval-hs "set cookies.foo to 'bar'") + (assert= (eval-hs "cookies.foo") "bar")) + +(deftest "update cookie values work" + (hs-cleanup!) + (eval-hs "set cookies.foo to 'bar'") + (eval-hs "set cookies.foo to 'baz'") + (assert= (eval-hs "cookies.foo") "baz")) + +(deftest "basic clear cookie values work" + (hs-cleanup!) + (eval-hs "set cookies.foo to 'bar'") + (eval-hs "clear cookies.foo") + (assert= (eval-hs "cookies.foo") nil)) + +(deftest "iterate cookies values work" + (hs-cleanup!) + (eval-hs "set cookies.a to '1'") + (eval-hs "set cookies.b to '2'") + (let ((names (eval-hs "for name in cookies collect name"))) + (assert (contains? names "a")) + (assert (contains? names "b")))) +``` + +## 7. Implementation checklist + +1. Add cookie mock to `tests/hs-run-filtered.js`. Wire reset into test cleanup. +2. Add `hs-cookie-get`, `hs-cookie-set`, `hs-cookie-delete`, `hs-cookie-length`, `hs-cookie-names` to `lib/hyperscript/runtime.sx`. +3. Add `cookies` as a special expression in the HS parser/evaluator that dispatches to the above. +4. Replace 5 `SKIP` bodies in `spec/tests/test-hyperscript-behavioral.sx` with translated test bodies above. +5. Run `hs_test_run suite="hs-upstream-expressions/cookies"` — expect 5/5. +6. Run smoke 0–195 — no regressions. +7. Commit: `HS: cookie API — document.cookie proxy + 5 tests` + +## 8. Risk + +Medium. The mock is simple. The main risk is the `cookies` expression integration in the parser — it needs to hook into property-access and assignment paths that are already well-exercised. Keep the implementation thin: `cookies` is a runtime value with a special type, not a new parse form. diff --git a/plans/designs/f8-eval-statically.md b/plans/designs/f8-eval-statically.md new file mode 100644 index 00000000..c3869ebb --- /dev/null +++ b/plans/designs/f8-eval-statically.md @@ -0,0 +1,107 @@ +# F8 — evalStatically (+3) + +**Suite:** `hs-upstream-core/evalStatically` +**Target:** 3 failing (untranslated) out of 8. 5 already pass. + +## 1. Current state + +5 passing tests use `(eval-hs expr)` and check the return value for literals: booleans, null, numbers, plain strings, time expressions. These call `_hyperscript.evaluate(src)` and return the result. + +3 failing tests are named: +- `throws on math expressions` +- `throws on symbol references` +- `throws on template strings` + +All are `SKIP (untranslated)` — no test body has been generated. + +## 2. What upstream checks + +From `test/core/evalStatically.js`, the `throwErrors` mode: + +```js +expect(() => _hyperscript.evaluate("1 + 2")).toThrow(); +expect(() => _hyperscript.evaluate("x")).toThrow(); +expect(() => _hyperscript.evaluate(`"hello ${name}"`)).toThrow(); +``` + +`_hyperscript.evaluate(src)` in strict static mode throws when the expression is not a pure literal — math operators, symbol references, and template string interpolation all involve runtime evaluation that can't be statically resolved. + +The "static" constraint: only literals that can be evaluated without any runtime context or side effects are allowed. `1 + 2` is not static (it's a math op). `x` is not static (symbol lookup). `"hello ${name}"` is not static (interpolation). + +## 3. What `eval-hs` currently does + +`eval-hs` in our harness calls `(hs-compile-and-run src)` or equivalent. It does NOT currently have a "static mode" — it runs everything with the full runtime. + +We need a new harness helper `eval-hs-static-error` that: +1. Calls `(hs-compile src)` with a flag that makes it throw on non-literal expressions +2. Returns the caught error message, or raises if no error was thrown + +## 4. Implementation options + +### Option A — Static analysis pass (accurate) + +Before evaluation, walk the AST and reject any node that isn't a literal: +- Number literal ✓ +- String literal (no interpolation) ✓ +- Boolean literal ✓ +- Null literal ✓ +- Time expression (`200ms`, `2s`) ✓ +- Everything else → throw `"expression is not static"` + +This is a pre-eval AST check, not a runtime change. Lives in `lib/hyperscript/compiler.sx` as `hs-check-static`. + +### Option B — Generator translation (simpler) + +The 3 tests are untranslated. All three just verify that `_hyperscript.evaluate(expr)` throws. In our SX harness we can test this with a `guard` form: + +```lisp +(deftest "throws on math expressions" + (let ((result (guard (e (true true)) + (eval-hs "1 + 2") + false))) + (assert result))) +``` + +But this only works if `eval-hs` actually throws on math expressions. Currently it doesn't — `eval-hs "1 + 2"` returns `3`. So we'd need the static analysis anyway to make the test pass. + +### Chosen approach: Option A + +Add `hs-static-check` to the compiler: a fast AST walker that throws on any non-literal node. Wire it as an optional mode. The test harness calls `eval-hs-static` which runs with static-check enabled. + +Actually, reading the upstream more carefully: `_hyperscript.evaluate` already throws in static mode without additional flags — the "evaluate" API is documented as static-only. Our `eval-hs` in the passing tests works because booleans/numbers/strings/time ARE static. `1 + 2`, `x`, and template strings are NOT static and should throw. + +So the fix is: make `hs-compile-and-run` (or whatever backs `eval-hs`) reject non-literal AST nodes. The 5 passing tests will continue to pass (they use literals). The 3 failing tests will get translated using `eval-hs-error` or a guard pattern. + +## 5. Non-literal AST node types to reject + +| Expression | AST node type | Reject? | +|-----------|--------------|---------| +| `1`, `3.14` | number literal | ✓ allow | +| `"hello"`, `'world'` | string literal (no interpolation) | ✓ allow | +| `true`, `false` | boolean literal | ✓ allow | +| `null` | null literal | ✓ allow | +| `200ms`, `2s` | time literal | ✓ allow | +| `1 + 2` | math operator | ✗ throw | +| `x` | symbol reference | ✗ throw | +| `"hello ${name}"` | template string | ✗ throw | + +## 6. Implementation checklist + +1. In `lib/hyperscript/compiler.sx`, add `hs-static?` predicate: returns true only for literal AST node types. +2. In the `eval-hs` path (wherever `hs-compile-and-run` is called for the evaluate API), call `hs-static?` on the parsed AST and throw `"expression is not statically evaluable"` if false. +3. Replace 3 `SKIP` bodies in `spec/tests/test-hyperscript-behavioral.sx`: + ```lisp + (deftest "throws on math expressions" + (assert (string? (eval-hs-error "1 + 2")))) + (deftest "throws on symbol references" + (assert (string? (eval-hs-error "x")))) + (deftest "throws on template strings" + (assert (string? (eval-hs-error "\"hello ${name}\"")))) + ``` +4. Run `hs_test_run suite="hs-upstream-core/evalStatically"` — expect 8/8. +5. Run smoke 0–195 — verify the 5 passing tests still pass. +6. Commit: `HS: evalStatically — static literal check, 3 tests (+3)` + +## 7. Risk + +Low-medium. The main risk is that `eval-hs` is used in many tests for non-static expressions and adding a static check to the shared path would break them. The fix must be gated — either a separate `eval-hs-static` helper or a flag parameter. The passing tests must not be affected. diff --git a/plans/designs/hs-plugin-system.md b/plans/designs/hs-plugin-system.md new file mode 100644 index 00000000..a293f34f --- /dev/null +++ b/plans/designs/hs-plugin-system.md @@ -0,0 +1,341 @@ +# HyperScript Plugin / Extension System + +Post-Bucket-F capability work. No conformance delta on its own — the payoff is +clean architecture for language embeds (Lua, Prolog, Worker runtime) and +alignment with real `_hyperscript`'s extension model. + +--- + +## 1. Motivation + +### 1a. Real `_hyperscript` has a plugin API + +Stock `_hyperscript` ships a core bundle with feature stubs and a `use(ext)` +hook that loads named extensions at runtime. The worker feature is the canonical +example: the core parser has a stub that errors helpfully; loading the worker +extension replaces the stub with a real implementation. + +We currently have no equivalent. New grammar or compiler targets require editing +`parse-feat`'s hardcoded `cond` or `hs-to-sx`'s hardcoded dispatch. This is +fine for conformance work but wrong for language embeds. + +### 1b. Ad-hoc hooks are accumulating + +`runtime.sx` already has `hs-prolog-hook` / `hs-set-prolog-hook!` / `prolog` +(nodes 140–142) — an informal plugin slot bolted on outside the parser and +compiler. This pattern will repeat for Lua, and again for the Worker runtime. +A proper registry prevents the drift. + +### 1c. E39 worker stub is a placeholder + +The stub added in E39 (`parse-feat` raises immediately on `"worker"`) was +explicitly designed to be replaced by a real plugin at a single site. This plan +is where that replacement happens. + +### 1d. Bucket-F Group 10 needs a converter registry + +`as MyType` via registered converter is already in the Bucket-F plan (Group 10). +A `hs-register-converter!` registry is the natural home for it — and the plugin +system is the right time to add registries generally. + +--- + +## 2. Scope + +**In scope:** +- Parser feature registry (`parse-feat` dispatch) +- Compiler command registry (`hs-to-sx` dispatch) +- `as` converter registry (`hs-coerce` dispatch) +- Migration of E39 worker stub to use the parser registry +- Migration of `hs-prolog-hook` ad-hoc slot to a proper plugin +- Worker full runtime plugin (first real plugin) +- Lua embed plugin +- Prolog embed plugin + +**Out of scope:** +- Changing the test runner or generator +- Any conformance delta (this plan doesn't target failing tests) +- Third-party plugin loading from external URLs (future) +- Hot-reload of plugins (future) + +--- + +## 3. Registry design + +Three registries, all SX dicts. Checked before the hardcoded `cond` in each +dispatch. Registration functions defined alongside the registries in their +respective files. + +### 3a. Parser feature registry (`lib/hyperscript/parser.sx`) + +```lisp +(define _hs-feature-registry (dict)) + +(define hs-register-feature! + (fn (keyword parse-fn) + (set! _hs-feature-registry + (dict-set _hs-feature-registry keyword parse-fn)))) +``` + +In `parse-feat`, prepend a registry lookup before the existing `cond`: + +```lisp +(let ((registered (dict-get _hs-feature-registry val))) + (if registered + (registered) ;; call the registered parse-fn (no args; uses closure over adv!/tp-val etc.) + (cond ;; existing dispatch unchanged below + ...))) +``` + +`parse-fn` is a zero-arg thunk that has access to the parser's internal state +via the same closure that the existing `parse-*` helpers use. Since `parse-feat` +is itself defined inside the big `let` in `hs-parse`, all the parser helpers +(`adv!`, `tp-val`, `tp-typ`, `parse-cmd-list`, etc.) are in scope. + +### 3b. Compiler command registry (`lib/hyperscript/compiler.sx`) + +```lisp +(define _hs-compiler-registry (dict)) + +(define hs-register-compiler! + (fn (head compile-fn) + (set! _hs-compiler-registry + (dict-set _hs-compiler-registry (str head) compile-fn)))) +``` + +In `hs-to-sx`, before the existing `cond` on `head`, check the registry: + +```lisp +(let ((registered (dict-get _hs-compiler-registry (str head)))) + (if registered + (registered ast) + (cond ...))) +``` + +`compile-fn` receives the full AST node and returns an SX expression. + +### 3c. `as` converter registry (`lib/hyperscript/runtime.sx`) + +```lisp +(define _hs-converters (dict)) + +(define hs-register-converter! + (fn (type-name converter-fn) + (set! _hs-converters + (dict-set _hs-converters type-name converter-fn)))) +``` + +In `hs-coerce`, add a registry lookup as the last `cond` clause before the +fallthrough error: + +```lisp +((dict-get _hs-converters type-name) + ((dict-get _hs-converters type-name) value)) +``` + +This is also the hook that Bucket-F Group 10 (`can accept custom conversions`) +hangs on — so implementing it here kills two birds. + +--- + +## 4. First-party plugins + +Each plugin is a `.sx` file in `lib/hyperscript/plugins/`. Plugins call the +registration functions at load time (top-level `do` forms). The host loads +plugins explicitly after the core files. + +### 4a. Worker plugin (`lib/hyperscript/plugins/worker.sx`) + +**Phase 1 — stub migration (immediate):** +Remove the inline error branch from `parse-feat` (the E39 stub). Replace with: + +```lisp +(hs-register-feature! "worker" + (fn () + (error "worker plugin is not installed — see https://hyperscript.org/features/worker"))) +``` + +This is identical behaviour to E39 but routed through the registry. The stub +lives in the plugin file, not the core parser. No test regression. + +**Phase 2 — full runtime:** + +Parser: `parse-worker-feat` — consumes `worker [(*)] * end`, +returns `(worker Name urls defs)` AST node. + +Compiler: registered under `"worker"` head: +- Emits `(hs-worker-define! "Name" urls defs)` call. + +Runtime additions in the plugin file: +- `hs-worker-define!` — creates a `{:_hs-worker true :name N :handle H :exports (...)}` record, + binds it in the HS top-level env under `Name`. +- `hs-method-call` (existing) detects `:_hs-worker` and dispatches via `postMessage`. +- Worker script body compiled to a standalone SX bundle posted to a Blob URL. +- Return values are promise-wrapped; async-transparent via `perform`/IO suspension. + +Mock env additions for the test runner: `Worker` constructor + synchronous +message loop for the 7 sibling `test.skip(...)` upstream tests (the ones +deferred in E39). + +### 4b. Prolog plugin (`lib/hyperscript/plugins/prolog.sx`) + +Replaces the ad-hoc `hs-prolog-hook` in `runtime.sx`. + +**Parser:** Register `"prolog"` feature — parses +`prolog(, )` at feature level (alternative: keep as an +expression, register a compiler extension only). + +**Compiler:** Registered under `"prolog"` head — emits `(prolog db goal)`. + +**Runtime:** The existing `prolog` function in `runtime.sx` moves here. +`hs-prolog-hook` and `hs-set-prolog-hook!` are removed from `runtime.sx` and +the hook mechanism is replaced by the plugin loading `lib/prolog/runtime.sx` +and wiring the solver directly. + +Remove from `runtime.sx` nodes 140–142 once the plugin is live. + +### 4c. Lua plugin (`lib/hyperscript/plugins/lua.sx`) + +**Parser:** Register `"lua"` feature — parses `lua ... end` block, captures +the body as a raw string. + +**Compiler:** Registered under `"lua"` head — emits `(lua-eval )`. + +**Runtime:** `lua-eval` calls `lib/lua/runtime.sx`'s eval entry point, returns +result as an SX value via `hs-host-to-sx`. Errors surface as HS `catch`-able +exceptions. + +This enables inline Lua in HyperScript: + +``` +on click + lua + return document.title:upper() + end + put it into me +end +``` + +--- + +## 5. Load order + +``` +lib/hyperscript/parser.sx ;; defines _hs-feature-registry, hs-register-feature! +lib/hyperscript/compiler.sx ;; defines _hs-compiler-registry, hs-register-compiler! +lib/hyperscript/runtime.sx ;; defines _hs-converters, hs-register-converter! +lib/hyperscript/plugins/worker.sx +lib/hyperscript/plugins/prolog.sx +lib/hyperscript/plugins/lua.sx +``` + +The test runner (`tests/hs-run-filtered.js`) loads plugins after core. The +browser WASM bundle includes all three by default (plugins are small; no +reason to lazy-load them). + +--- + +## 6. Migration checklist + +The work below is ordered to keep main green at every commit. Each step is +independently committable. + +### Step 1 — Registries (infrastructure, no behaviour change) + +1. Add `_hs-feature-registry` + `hs-register-feature!` to `parser.sx`. + Thread the registry check into `parse-feat`. No entries yet → behaviour + unchanged. +2. Add `_hs-compiler-registry` + `hs-register-compiler!` to `compiler.sx`. + Thread into `hs-to-sx`. No entries yet → behaviour unchanged. +3. Add `_hs-converters` + `hs-register-converter!` to `runtime.sx`. Thread + into `hs-coerce`. No entries yet → behaviour unchanged. +4. `sx_validate` all three files. Run full HS suite — expect zero regressions. +5. Commit: `HS: plugin registry infrastructure (parser + compiler + converter)`. + +### Step 2 — Worker stub migration + +6. Create `lib/hyperscript/plugins/worker.sx`. Register the worker stub error. +7. Remove the inline `((= val "worker") ...)` branch from `parse-feat` in + `parser.sx`. +8. Update the test runner to load `worker.sx` after core. +9. Run `HS_SUITE=hs-upstream-worker` — expect 1/1. Run full suite — expect no + regressions. +10. Commit: `HS: migrate E39 worker stub to plugin registry`. + +### Step 3 — Prolog plugin + +11. Create `lib/hyperscript/plugins/prolog.sx`. Wire to `lib/prolog/runtime.sx`. +12. Remove `hs-prolog-hook`, `hs-set-prolog-hook!`, `prolog` from `runtime.sx` + nodes 140–142. +13. Update test runner to load `prolog.sx`. +14. Validate and run full suite. +15. Commit: `HS: prolog plugin replaces ad-hoc hook`. + +### Step 4 — `as` converter registry (bridges Bucket-F Group 10) + +16. Confirm `hs-register-converter!` satisfies the Group 10 test + `can accept custom conversions`. If yes, this step may be pulled into + Bucket-F Group 10 instead (no duplication — just move step 3 of §6 there). +17. Commit: `HS: as-converter registry wired into hs-coerce`. + +### Step 5 — Lua plugin + +18. Create `lib/hyperscript/plugins/lua.sx`. +19. Add `lua-eval` to `runtime.sx` or directly in the plugin file. +20. Parser: `parse-lua-feat` consuming `lua … end`. +21. Compiler: registered `"lua"` head. +22. Write 3–5 tests in `spec/tests/test-hyperscript-lua.sx`: + - Lua returns a string → HS uses it. + - Lua error → HS catch. + - Lua reads a passed argument. +23. Commit: `HS: Lua plugin — inline lua...end blocks`. + +### Step 6 — Worker full runtime plugin + +24. Extend `worker.sx`: implement `parse-worker-feat`, compiler entry, + `hs-worker-define!`, `hs-method-call` worker branch. +25. Extend test runner: `Worker` constructor + synchronous message loop. +26. Un-skip the 7 sibling worker tests from upstream. +27. Target: 7/7 worker suite. +28. Commit: `HS: Worker plugin full runtime (+7 tests)`. + +--- + +## 7. Risks + +- **`parse-feat` closure scope** — `hs-register-feature!` stores parse-fns + that need access to parser-internal helpers (`adv!`, `tp-val`, etc.). These + are only in scope inside `hs-parse`'s big `let`. Two options: + (a) the registry stores fns that receive a parser-context dict as arg, or + (b) the registry is checked *inside* `parse-feat` where helpers are in scope + and fns are zero-arg closures captured at registration time. + Option (b) is simpler but requires plugins to be loaded while the parser + `let` is being evaluated — i.e., plugins must be defined *inside* the parser + file or the context dict must be exposed. **Recommended:** expose a + `_hs-parser-ctx` dict at the module level that parse-fns receive as their + sole argument. This makes the API explicit and plugins independent files. + +- **Worker Blob URL in WASM** — `URL.createObjectURL` is available in browsers + but not in the OCaml WASM host. Worker full runtime is browser-only; flag it + with a capability check and graceful fallback. + +- **Lua/Prolog mutual recursion** — a Lua block calling back into HS calling + back into Lua is theoretically possible via the IO suspension machinery. + Don't try to support it initially; raise a clear error if detected. + +- **Plugin load-order sensitivity** — `hs-register-feature!` must be called + before any source is parsed. If a plugin is loaded lazily (future), a + `worker MyWorker` in the page would hit the stub before the full plugin + registers. Acceptable for now; document that plugins must be loaded at boot. + +- **`runtime.sx` cleanup for prolog** — nodes 140–142 are referenced nowhere + else in the codebase (grep confirms). Safe to delete once the plugin is live. + +--- + +## 8. Non-goals + +- Runtime `use(ext)` API (JS-style dynamic plugin install) — future. +- Plugin namespacing / versioning — future. +- Any conformance tests other than the 7 worker tests in step 6. +- Changing how the WASM bundle is built or split. diff --git a/plans/designs/sx-adt.md b/plans/designs/sx-adt.md new file mode 100644 index 00000000..8526e767 --- /dev/null +++ b/plans/designs/sx-adt.md @@ -0,0 +1,257 @@ +# SX Algebraic Data Types — Design + +## Motivation + +Every language implementation currently uses `{:tag "..." :field ...}` tagged dicts to +simulate sum types. This is verbose, error-prone (typos in tag strings go undetected), and +produces no exhaustiveness warnings. Native ADTs eliminate the pattern everywhere. + +Examples of current workarounds: +- Haskell `Maybe a` → `{:tag "Just" :value x}` / `{:tag "Nothing"}` +- Prolog terms → `{:tag "functor" :name "foo" :args (list x y)}` +- Lua result type → `{:tag "ok" :value v}` / `{:tag "err" :msg s}` +- Common Lisp `cons` pairs → `{:tag "cons" :car a :cdr b}` + +--- + +## Syntax + +### `define-type` + +```lisp +(define-type Name + (Ctor1 field1 field2 ...) + (Ctor2 field1 ...) + ...) +``` + +Creates: +- Constructor functions: `Ctor1`, `Ctor2`, … (callable like normal functions) +- Type predicate: `Name?` — returns true for any value of type `Name` +- Constructor predicates: `Ctor1?`, `Ctor2?`, … (optional, auto-generated) +- Field accessors: `Ctor1-field1`, `Ctor1-field2`, … (optional, auto-generated) + +Examples: + +```lisp +(define-type Maybe + (Just value) + (Nothing)) + +(define-type Result + (Ok value) + (Err message)) + +(define-type Tree + (Leaf) + (Node left value right)) + +(define-type List-of + (Nil-of) + (Cons-of head tail)) +``` + +Constructors with no fields are zero-argument constructors (singletons by value): + +```lisp +(Nothing) ; => # +(Leaf) ; => # +``` + +### `match` + +```lisp +(match expr + ((Ctor1 a b) body) + ((Ctor2 x) body) + ((Ctor3) body) + (else body)) +``` + +- Clauses are tried in order; first match wins. +- `else` clause is optional but suppresses exhaustiveness warnings. +- Pattern variables (`a`, `b`, `x`) are bound in the body scope. +- Wildcard `_` discards the matched value. +- Literal patterns: `42`, `"str"`, `true`, `nil` — match by value equality. +- Nested patterns: `((Node left (Leaf) right) body)` — nested constructor patterns. + +Examples: + +```lisp +(match result + ((Ok v) (str "got: " v)) + ((Err m) (str "error: " m))) + +(match tree + ((Leaf) 0) + ((Node l v r) (+ 1 (tree-depth l) (tree-depth r)))) +``` + +--- + +## CEK Dispatch + +### Runtime representation + +ADT values are OCaml records (not dicts) — opaque, non-inspectable via `get`: + +```ocaml +type adt_value = { + av_type : string; (* type name, e.g. "Maybe" *) + av_ctor : string; (* constructor name, e.g. "Just" *) + av_fields: value array; (* positional fields *) +} +``` + +In JS: `{ _adt: true, _type: "Maybe", _ctor: "Just", _fields: [v] }`. + +`typeOf` returns the ADT type name (e.g. `"Maybe"`). + +### `define-type` — special form + +`stepSfDefineType(args, env, kont)`: + +1. Parse `Name` and list of `(CtorN field...)` clauses. +2. For each constructor `CtorK` with fields `[f1, f2, …]`: + - Register `CtorK` as a `NativeFn` that takes `|fields|` args and returns an `AdtValue`. + - Register `CtorK?` as a predicate (`AdtValue` with matching ctor name → `true`). + - Register `CtorK-fN` as field accessor (returns `av_fields[N]`). +3. Register `Name?` as a predicate (`AdtValue` with matching type name → `true`). +4. All bindings go into the current environment via `env-bind!`. +5. Returns `Nil`. + +This is an environment mutation — no new frame needed. Evaluates in one step. + +### `match` — special form + +`stepSfMatch(args, env, kont)`: + +1. Push `MatchFrame` with `clauses` and `env` onto kont. +2. Return state evaluating the scrutinee `expr`. +3. `MatchFrame` continue: receive scrutinee value, walk clauses: + - For each `((CtorN vars...) body)`: + - If scrutinee is an `AdtValue` with `av_ctor = "CtorN"` and `av_fields.length = |vars|`: + - Bind `vars[i]` → `av_fields[i]` in fresh child env. + - Return state evaluating `body` in that env. + - `(else body)` — always matches, body evaluated in current env. + - Literal `42`/`"str"` patterns: match by value equality. + - Wildcard `_`: always matches, binds nothing. +4. If no clause matched and no `else`: raise `"match: no clause matched "`. + +Frame type: `"match"` — stores `cf_remaining` (clauses), `cf_env` (enclosing env). + +--- + +## Interaction with `cond` / `case` + +`match` is the primary dispatch form for ADTs. `cond` / `case` remain unchanged: + +- `cond` tests arbitrary boolean expressions — still useful for non-ADT dispatch. +- `case` matches on equality to literal values — unchanged. +- `match` is the new form: structural pattern matching on ADT constructors. + +They are orthogonal. A `match` clause can contain a `cond`; a `cond` clause can contain a `match`. + +--- + +## Exhaustiveness checking + +Emit a **warning** (not an error) when: +- A `match` has no `else` clause, AND +- Not all constructors of the scrutinee's type are covered. + +Detection: when `define-type` runs, it registers the constructor set in a global table +`_adt_registry: type_name → [ctor_names]`. At `match` compile/evaluation time: +- If the scrutinee's type is in `_adt_registry` and not all ctors appear as patterns: + - `console.warn("[sx] match: non-exhaustive — missing: Ctor3, Ctor4 for type Maybe")` + - Execution continues (warning, not error). + +This is best-effort: the scrutinee type is only known at runtime. The warning fires on +first non-exhaustive match evaluation, not at definition time. + +--- + +## Recursive types + +Recursive types work because constructors are registered as functions, and function bodies +are evaluated lazily: + +```lisp +(define-type Tree + (Leaf) + (Node left value right)) + +; Recursive function over a recursive type: +(define (depth tree) + (match tree + ((Leaf) 0) + ((Node l v r) (+ 1 (max (depth l) (depth r)))))) +``` + +No special treatment needed — the type definition doesn't need to know about recursion. +The constructor `Node` accepts any values, including other `Node` or `Leaf` values. + +--- + +## Pattern variables + +In `match` clauses, identifiers in constructor position that are NOT constructor names are +treated as pattern variables (bound to matched field values): + +```lisp +(match x + ((Just v) v) ; v bound to the wrapped value + ((Nothing) nil)) + +(match pair + ((Cons-of h t) (list h t))) ; h, t bound to head and tail +``` + +**Wildcard**: `_` is always a wildcard — matches anything, binds nothing. + +```lisp +(match x + ((Just _) "has value") + ((Nothing) "empty")) +``` + +**Nested patterns**: + +```lisp +(match tree + ((Node (Leaf) v (Leaf)) (str "leaf node: " v)) + ((Node l v r) (str "inner node: " v))) +``` + +Nested patterns are matched recursively: the inner `(Leaf)` pattern checks that the +`left` field is itself a `Leaf` ADT value. + +--- + +## Implementation Plan + +### Phase 6a — `define-type` + basic `match` (no nested patterns, no exhaustiveness) + +1. OCaml: add `AdtValue of adt_value` to `sx_types.ml`. +2. Evaluator: add `step-sf-define-type` — parse clauses, register ctor fns + predicates + accessors. +3. Evaluator: add `step-sf-match` + `MatchFrame` — linear scan of clauses, flat patterns only. +4. JS: same (AdtValue as plain object with `_adt`/`_type`/`_ctor`/`_fields` props). + +### Phase 6b — nested patterns (separate fire) + +Recursive `matchPattern(pattern, value, env)` helper that: +- Returns `{matched: bool, bindings: map}` +- Recursively matches sub-patterns against ADT fields. + +### Phase 6c — exhaustiveness warnings (separate fire) + +`_adt_registry` global + warning emission on first non-exhaustive match. + +--- + +## Open questions (deferred to review) + +1. **Accessor auto-generation**: should `Ctor-field` accessors be generated always, or only on demand? Risk: name collisions if two types have constructors with same field names. +2. **Singleton constructors**: `(Nothing)` — zero-arg ctor — should these be interned (same object every call) or fresh each time? Interning enables `eq?` checks but requires a global table. +3. **Printing/inspect**: `inspect` on an AdtValue should show `(Just 42)` not `#`. Implement in `inspect` function or via `display`/`write` (Phase 17 ports). +4. **Pattern-matching on non-ADT values**: should `match` handle list patterns `(a . b)` and literal patterns in clause heads? Deferred — add only if needed by a language implementation. diff --git a/plans/elixir-on-sx.md b/plans/elixir-on-sx.md new file mode 100644 index 00000000..69a7ba1f --- /dev/null +++ b/plans/elixir-on-sx.md @@ -0,0 +1,173 @@ +# Elixir-on-SX: Elixir on the CEK/VM + +Compile Elixir source to SX AST; the existing CEK evaluator runs it. The natural companion +to `lib/erlang/` — Elixir compiles to the BEAM and most of its runtime semantics are +Erlang's. The interesting parts are Elixir-specific: the macro system (`quote`/`unquote`), +the pipe operator `|>`, `with` expressions, `defmodule`/`def`/`defp`, protocol dispatch, +and the `Stream` lazy evaluation library. + +End-state goal: **core Elixir programs running**, including modules, pattern matching, the +pipe operator, macros (`quote`/`unquote`/`defmacro`), protocols, and actor-style processes +reusing the Erlang runtime foundation. + +## Ground rules + +- **Scope:** only touch `lib/elixir/**` and `plans/elixir-on-sx.md`. Do **not** edit + `spec/`, `hosts/`, `shared/`, or other `lib//`. Reuse `lib/erlang/` runtime + functions where possible — import them, don't duplicate. +- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here. +- **SX files:** use `sx-tree` MCP tools only. +- **Architecture:** Elixir source → Elixir AST → SX AST. Reuse Erlang runtime for process/ + message/pattern primitives; add Elixir-specific surface in `lib/elixir/`. +- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes. + +## Architecture sketch + +``` +Elixir source text + │ + ▼ +lib/elixir/tokenizer.sx — atoms (:atom), strings (""), charlists (''), sigils (~r, ~s etc.), + │ operators (|>, <>, ++, :::, etc.), do/end blocks + ▼ +lib/elixir/parser.sx — Elixir AST: defmodule, def/defp/defmacro, @attribute, + │ pattern matching, |> pipe, with, for comprehension, quote/unquote, + │ case/cond/if/unless, fn, receive, try/rescue/catch/after + ▼ +lib/elixir/transpile.sx — Elixir AST → SX AST + │ + ├── lib/erlang/runtime.sx (reused: processes, message passing, pattern match) + └── lib/elixir/runtime.sx — Elixir-specific: Kernel, String, Enum, Stream, Map, + List, Tuple, IO, protocol dispatch, macro expansion +``` + +Key semantic mappings (differences from Erlang): +- `defmodule M do ... end` → SX `define-library` + module dict `{:module "M" :fns {...}}` +- `def f(args) do body end` → named function in module dict, with pattern-match dispatch +- `|>` pipe → left-to-right function composition; `a |> f(b)` = `f(a, b)` +- `with x <- expr, y <- expr2 do body else patterns end` → chained pattern match with early exit +- `for x <- list, filter, do: expr` → list comprehension (SX `map`/`filter`) +- `quote do expr end` → returns AST as SX list (homoiconic — Elixir AST IS SX-like) +- `unquote(expr)` → evaluate expr and splice into surrounding `quote` +- `defmacro` → macro in module; expanded at compile time by calling the SX macro +- Protocol → dict of implementations keyed by type name; `defprotocol` defines interface, + `defimpl` registers an implementation +- `Stream` → lazy sequences using SX promises/coroutines (Phase 9/4 of primitives) +- `Agent`/`GenServer` → SX coroutine + message queue (similar to Erlang process model) + +## Roadmap + +### Phase 1 — tokenizer + parser +- [ ] Tokenizer: atoms (`:atom`, `:"atom with spaces"`), strings (`""`), charlists (`''`), + numbers (int, float, hex `0xFF`, octal `0o77`, binary `0b11`), booleans (`true`/`false`/`nil`), + operators (`|>`, `<>`, `++`, `--`, `:::`, `&&`, `||`, `!`, `..`, `<-`, `=~`), + sigils (`~r/regex/`, `~s"string"`, `~w(word list)`), do/end blocks, keywords as args + `f(key: val)`, `@module_attribute` +- [ ] Parser: + - Module: `defmodule Name do ... end` → module AST with body + - Functions: `def f(pat) do body end`, `def f(pat) when guard do body end`, + multi-clause `def f(a) do ...; def f(b) do ...` → clause list + - `defp` (private), `defmacro`, `defmacrop` + - `@doc`, `@moduledoc`, `@spec`, `@type`, `@behaviour` module attributes + - `case expr do patterns end`, `cond do clauses end`, `if`/`unless` + - `with x <- e, y <- e2, do: body, else: [pattern -> body]` + - `for x <- list, filter, into: acc, do: expr` comprehension + - `fn pat -> body end` anonymous function; capture `&Module.fun/arity`, `&(&1 + 1)` + - `receive do patterns after timeout -> body end` + - `try do body rescue e -> ... catch type, val -> ... after ... end` + - `quote do ... end`, `unquote(expr)`, `unquote_splicing(list)` + - `|>` pipe chain: `a |> f |> g(b)` → `g(f(a), b)` +- [ ] Tests in `lib/elixir/tests/parse.sx` + +### Phase 2 — transpile: basic Elixir (no macros, no processes) +- [ ] `ex-eval-ast` entry +- [ ] Arithmetic, string `<>`, list `++`/`--`, comparison, boolean (`and`/`or`/`not`) +- [ ] Pattern matching in `=`, function heads, `case` — reuse Erlang pattern engine +- [ ] `def`/`defp` → SX `define` with clause dispatch (like Erlang function clauses) +- [ ] Module as a dict of named functions; `ModuleName.function(args)` dispatch +- [ ] `|>` pipe: desugar `a |> f(b, c)` → `f(a, b, c)` at transpile time +- [ ] `with` expression: chain of `<-` bindings, short-circuit on mismatch to `else` +- [ ] `for` comprehension: `for x <- list, filter do body end` → `map`/`filter` +- [ ] `fn` anonymous functions, `&` capture forms +- [ ] `if`/`unless`/`cond`/`case` +- [ ] String interpolation: `"Hello #{name}"` → string concat +- [ ] Keyword lists `[key: val]` → SX list of `{:key val}` dicts; maps `%{key: val}` → SX dict +- [ ] Tuples `{a, b, c}` → SX list (or vector); `elem/2`, `put_elem/3` +- [ ] 40+ eval tests in `lib/elixir/tests/eval.sx` + +### Phase 3 — macro system +- [ ] `quote do expr end` → returns Elixir AST as SX list structure + (Elixir AST is 3-tuples `{name, meta, args}` — map to SX `(list name meta args)`) +- [ ] `unquote(expr)` → evaluate and splice into surrounding `quote` +- [ ] `unquote_splicing(list)` → splice list into surrounding `quote` +- [ ] `defmacro` → define a macro in the module; macro receives AST args, returns AST +- [ ] Macro expansion: expand macros before transpiling (two-pass: collect defs, then expand) +- [ ] `use Module` → calls `Module.__using__/1` macro, injects code into caller +- [ ] `import Module` → bring functions into scope without prefix +- [ ] `alias Module, as: M` → short name for module +- [ ] Tests: `defmacro unless`, `defmacro my_if`, `use` injection, `__MODULE__`, `__DIR__` + +### Phase 4 — protocols +- [ ] `defprotocol P do @spec f(t) :: result end` → defines protocol dict + dispatch fn +- [ ] `defimpl P, for: Type do def f(t) do ... end end` → register implementation +- [ ] Protocol dispatch: `P.f(value)` → look up type of value, find implementation, call it +- [ ] Built-in protocols: `Enumerable`, `Collectable`, `String.Chars`, `Inspect` +- [ ] `Enumerable` implementation for lists, maps, ranges — enables `Enum.*` on custom types +- [ ] `derive` — automatic protocol implementation for simple structs +- [ ] Tests: custom type implementing `Enumerable`, `String.Chars`, protocol fallback + +### Phase 5 — structs + behaviours +- [ ] `defstruct [:field1, field2: default]` → defines `%ModuleName{}` struct type + Structs are maps with `__struct__: ModuleName` key + defined fields +- [ ] Struct pattern matching: `%User{name: n} = user` +- [ ] `@behaviour Module` → declares behaviour callbacks; compile-time check +- [ ] `@impl true` / `@impl BehaviourName` → marks function as behaviour implementation +- [ ] Built-in behaviours: `GenServer`, `Supervisor`, `Agent`, `Task` +- [ ] Tests: struct creation, update syntax `%{struct | field: val}`, behaviour callbacks + +### Phase 6 — processes + OTP patterns (reuses Erlang runtime) +- [ ] `spawn(fn -> ... end)` / `spawn(M, f, args)` → SX coroutine on scheduler + Reuse `lib/erlang/` process + message queue infrastructure +- [ ] `send(pid, msg)` / `receive do patterns end` — already in Erlang runtime +- [ ] `GenServer` behaviour: `start_link`, `call`, `cast`, `handle_call`, `handle_cast`, + `handle_info`, `init` — implement as SX macros expanding to process + message loop +- [ ] `Agent` — simple state wrapper over GenServer; `Agent.start_link`, `get`, `update` +- [ ] `Task` — async computation; `Task.async`, `Task.await` +- [ ] `Supervisor` — child spec, restart strategy (`one_for_one`, `one_for_all`) +- [ ] Tests: counter GenServer, bank account Agent, parallel Task, supervised worker + +### Phase 7 — standard library +- [ ] `Enum.*` — `map`, `filter`, `reduce`, `each`, `into`, `flat_map`, `zip`, `sort`, + `sort_by`, `min_by`, `max_by`, `group_by`, `frequencies`, `count`, `any?`, `all?`, + `find`, `take`, `drop`, `take_while`, `drop_while`, `chunk_every`, `chunk_by`, + `flat_map_reduce`, `scan`, `uniq`, `uniq_by`, `member?`, `empty?`, `sum`, `product` +- [ ] `Stream.*` — lazy versions of Enum; `Stream.map`, `Stream.filter`, `Stream.take`, + `Stream.cycle`, `Stream.iterate`, `Stream.unfold`, `Stream.resource` + Uses SX promises (Phase 9) for laziness +- [ ] `String.*` — `length`, `upcase`, `downcase`, `trim`, `split`, `replace`, `contains?`, + `starts_with?`, `ends_with?`, `slice`, `at`, `graphemes`, `codepoints`, `to_integer`, + `to_float`, `pad_leading`, `pad_trailing`, `duplicate`, `match?` +- [ ] `Map.*` — `new`, `get`, `put`, `delete`, `update`, `merge`, `keys`, `values`, + `to_list`, `from_struct`, `has_key?`, `filter`, `map`, `reject`, `take`, `drop` +- [ ] `List.*` — `first`, `last`, `flatten`, `zip`, `unzip`, `keystore`, `keyfind`, + `wrap`, `duplicate`, `improper?`, `delete`, `insert_at`, `replace_at` +- [ ] `Tuple.*` — `to_list`, `from_list`, `append`, `insert_at`, `delete_at` +- [ ] `Integer.*` / `Float.*` — `parse`, `to_string`, `digits`, `pow`, `is_odd?`, `is_even?` +- [ ] `IO.*` — `puts`, `gets`, `inspect`, `write`, `read` → SX IO perform +- [ ] `Kernel.*` — built-in functions: `is_integer?`, `is_binary?`, `length`, `hd`, `tl`, + `elem`, `put_elem`, `apply`, `raise`, `exit`, `inspect` +- [ ] `inspect/1` / `IO.inspect/2` — debug printing using `Inspect` protocol + +### Phase 8 — conformance target +- [ ] Vendor or hand-build 100+ Elixir program tests in `lib/elixir/tests/programs/` +- [ ] Drive scoreboard + +## Blockers + +_(none yet)_ + +## Progress log + +_Newest first._ + +_(awaiting phase 1)_ diff --git a/plans/elm-on-sx.md b/plans/elm-on-sx.md new file mode 100644 index 00000000..cff5fa51 --- /dev/null +++ b/plans/elm-on-sx.md @@ -0,0 +1,131 @@ +# Elm-on-SX: Elm 0.19 on the CEK/VM + +Compile Elm source to SX AST; the existing CEK evaluator runs it. The unique angle: SX's +reactive island system (`defisland`, signals, `provide`/`context`) is a natural host for +The Elm Architecture — Model/Update/View maps almost directly onto SX's reactive runtime. +This is the only language in the set that targets SX's browser-side reactivity rather than +the server-side evaluator. + +End-state goal: **core Elm programs running in the browser via SX islands**, with The Elm +Architecture wired to SX signals. Not a full Elm compiler — no exhaustiveness checking, no +module system, no type inference — but a faithful runtime that can run Elm programs written +in idiomatic style. + +## Ground rules + +- **Scope:** only touch `lib/elm/**` and `plans/elm-on-sx.md`. Do **not** edit `spec/`, + `hosts/`, `shared/`, or other `lib//`. +- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here. +- **SX files:** use `sx-tree` MCP tools only. +- **Architecture:** Elm source → Elm AST → SX AST. No standalone Elm evaluator. +- **Type system:** defer. Focus on runtime semantics. Type errors surface at eval time. +- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes. + +## Architecture sketch + +``` +Elm source text + │ + ▼ +lib/elm/tokenizer.sx — numbers, strings, idents, operators, indentation-sensitive lexer + │ + ▼ +lib/elm/parser.sx — Elm AST: module, import, type alias, type, let, case, lambda, + │ if, list/tuple/record literals, pipe operator |> + ▼ +lib/elm/transpile.sx — Elm AST → SX AST + │ + ▼ +lib/elm/runtime.sx — TEA runtime: Program, sandbox, element; Cmd/Sub wrappers; + │ Html.* shims; Browser.* shims + ▼ +SX island / reactive runtime (browser) +``` + +Key semantic mappings: +- `Model` → SX signal (`make-signal`) +- `update : Msg -> Model -> Model` → SX signal updater (called on each message) +- `view : Model -> Html Msg` → SX component (re-renders on model signal change) +- `Cmd` → SX `perform` IO request +- `Sub` → SX event listener registered via `dom-listen` +- `Maybe a` → `nil` (Nothing) or value (Just a) — uses ADTs from Phase 6 of primitives +- `Result a b` → ADT `(Ok val)` / `(Err err)` + +## Roadmap + +### Phase 1 — tokenizer + parser +- [ ] Tokenizer: keywords (`module`, `import`, `type`, `alias`, `let`, `in`, `if`, `then`, + `else`, `case`, `of`, `port`), indentation tokens (indent/dedent/newline), string + literals, number literals, operators (`|>`, `>>`, `<<`, `<|`, `++`, `::`), type vars +- [ ] Parser: module declaration, imports, type aliases, union types, function definitions + with pattern matching, `let`/`in`, `case`/`of`, `if`/`then`/`else`, lambda `\x -> e`, + list literals `[1,2,3]`, tuple literals `(a,b)`, record literals `{x=1, y=2}`, + record update `{ r | x = 1 }`, pipe operator `|>` +- [ ] Skip for phase 1: ports, subscriptions, effects manager, type annotations +- [ ] Tests in `lib/elm/tests/parse.sx` + +### Phase 2 — transpile: expressions + pattern matching +- [ ] `elm-eval-ast` entry +- [ ] Arithmetic, string `++`, comparison, boolean ops +- [ ] Lambda → SX `fn`; function application +- [ ] `let`/`in` → SX `let` +- [ ] `if`/`then`/`else` → SX `if` +- [ ] `case`/`of` with constructor, literal, tuple, list, wildcard patterns → SX `cond` + using ADT match (Phase 6 primitives) +- [ ] List ops: `List.map`, `List.filter`, `List.foldl`, `List.foldr` +- [ ] `Maybe` and `Result` as ADTs +- [ ] 30+ eval tests in `lib/elm/tests/eval.sx` + +### Phase 3 — The Elm Architecture runtime +- [ ] `Browser.sandbox` — pure TEA loop (no Cmds, no Subs) + `{ init : model, update : msg -> model -> model, view : model -> Html msg }` + Wires to: SX signal for model, SX component for view, message dispatch on user events +- [ ] `Html.*` shims: `div`, `p`, `button`, `input`, `text`, `h1`–`h6`, `ul`, `li`, `a`, + `span`, `img` — emit SX component calls +- [ ] `Html.Attributes.*`: `class`, `id`, `href`, `src`, `type_`, `placeholder`, `value` +- [ ] `Html.Events.*`: `onClick`, `onInput`, `onSubmit`, `onBlur`, `onFocus` +- [ ] `Browser.element` — adds `init` returning `(model, Cmd msg)`, `subscriptions` +- [ ] Demo: counter app (`init=0`, `update Increment m = m+1`, `view` shows count + button) + +### Phase 4 — Cmds and Subs +- [ ] `Cmd` — mapped to SX `perform` IO requests. `Cmd.none`, `Cmd.batch` +- [ ] `Http.get`/`Http.post` → SX fetch IO +- [ ] `Sub` — mapped to SX `dom-listen`. `Sub.none`, `Sub.batch` +- [ ] `Browser.Events.onClick`, `onKeyPress`, `onAnimationFrame` +- [ ] `Time.every` — periodic subscription via SX timer IO +- [ ] `Task.perform`/`Task.attempt` — single-shot async operations + +### Phase 5 — standard library +- [ ] `String.*` — `length`, `append`, `concat`, `split`, `join`, `trim`, `toUpper`, `toLower`, + `contains`, `startsWith`, `endsWith`, `replace`, `toInt`, `toFloat`, `fromInt`, `fromFloat` +- [ ] `List.*` — `map`, `filter`, `foldl`, `foldr`, `head`, `tail`, `isEmpty`, `length`, + `reverse`, `append`, `concat`, `member`, `sort`, `sortBy`, `indexedMap`, `range` +- [ ] `Dict.*` — SX immutable dict; `fromList`, `toList`, `get`, `insert`, `remove`, `update`, + `member`, `keys`, `values`, `map`, `filter`, `foldl` +- [ ] `Set.*` — SX set primitive (Phase 18); `fromList`, `toList`, `member`, `insert`, + `remove`, `union`, `intersect`, `diff` +- [ ] `Maybe.*` — `withDefault`, `map`, `andThen`, `map2` +- [ ] `Result.*` — `withDefault`, `map`, `andThen`, `mapError`, `toMaybe` +- [ ] `Tuple.*` — `first`, `second`, `pair`, `mapFirst`, `mapSecond` +- [ ] `Basics.*` — `identity`, `always`, `not`, `xor`, `modBy`, `remainderBy`, `clamp`, + `min`, `max`, `abs`, `sqrt`, `logBase`, `e`, `pi`, `floor`, `ceiling`, `round`, + `truncate`, `toFloat`, `isNaN`, `isInfinite`, `compare` +- [ ] `Random.*` — seed-based PRNG via SX IO perform + +### Phase 6 — full browser integration +- [ ] `Browser.application` — URL routing, `onUrlChange`, `onUrlRequest` +- [ ] `Browser.Navigation.*` — `pushUrl`, `replaceUrl`, `back`, `forward` +- [ ] `Url.Parser.*` — path segment parsing +- [ ] `Json.Decode.*` — JSON decoder combinators +- [ ] `Json.Encode.*` — JSON encoder +- [ ] `Ports` — `port` keyword; JS interop via SX `host-call` + +## Blockers + +_(none yet)_ + +## Progress log + +_Newest first._ + +_(awaiting phase 1)_ diff --git a/plans/erlang-on-sx.md b/plans/erlang-on-sx.md index 0084a46e..cc068a23 100644 --- a/plans/erlang-on-sx.md +++ b/plans/erlang-on-sx.md @@ -53,52 +53,79 @@ Core mapping: - [x] Tokenizer: atoms (bare + single-quoted), variables (Uppercase/`_`-prefixed), numbers (int, float, `16#HEX`), strings `"..."`, chars `$c`, punct `( ) { } [ ] , ; . : :: ->` — **62/62 tests** - [x] Parser: module declarations, `-module`/`-export`/`-import` attributes, function clauses with head patterns + guards + body — **52/52 tests** - [x] Expressions: literals, vars, calls, tuples `{...}`, lists `[...|...]`, `if`, `case`, `receive`, `fun`, `try/catch`, operators, precedence -- [ ] Binaries `<<...>>` — not yet parsed (deferred to Phase 6) +- [x] Binaries `<<...>>` — landed in Phase 6 (parser + eval + pattern matching) - [x] Unit tests in `lib/erlang/tests/parse.sx` ### Phase 2 — sequential eval + pattern matching + BIFs -- [ ] `erlang-eval-ast`: evaluate sequential expressions -- [ ] Pattern matching (atoms, numbers, vars, tuples, lists, `[H|T]`, underscore, bound-var re-match) -- [ ] Guards: `is_integer`, `is_atom`, `is_list`, `is_tuple`, comparisons, arithmetic -- [ ] BIFs: `length/1`, `hd/1`, `tl/1`, `element/2`, `tuple_size/1`, `atom_to_list/1`, `list_to_atom/1`, `lists:map/2`, `lists:foldl/3`, `lists:reverse/1`, `io:format/1-2` -- [ ] 30+ tests in `lib/erlang/tests/eval.sx` +- [x] `erlang-eval-ast`: evaluate sequential expressions — **54/54 tests** +- [x] Pattern matching (atoms, numbers, vars, tuples, lists, `[H|T]`, underscore, bound-var re-match) — **21 new eval tests**; `case ... of ... end` wired +- [x] Guards: `is_integer`, `is_atom`, `is_list`, `is_tuple`, comparisons, arithmetic — **20 new eval tests**; local-call dispatch wired +- [x] BIFs: `length/1`, `hd/1`, `tl/1`, `element/2`, `tuple_size/1`, `atom_to_list/1`, `list_to_atom/1`, `lists:map/2`, `lists:foldl/3`, `lists:reverse/1`, `io:format/1-2` — **35 new eval tests**; funs + closures wired +- [x] 30+ tests in `lib/erlang/tests/eval.sx` — **130 tests green** ### Phase 3 — processes + mailboxes + receive (THE SHOWCASE) -- [ ] Scheduler in `runtime.sx`: runnable queue, pid counter, per-process state record -- [ ] `spawn/1`, `spawn/3`, `self/0` -- [ ] `!` (send), `receive ... end` with selective pattern matching -- [ ] `receive ... after Ms -> ...` timeout clause (use SX timer primitive) -- [ ] `exit/1`, basic process termination -- [ ] Classic programs in `lib/erlang/tests/programs/`: - - [ ] `ring.erl` — N processes in a ring, pass a token around M times - - [ ] `ping_pong.erl` — two processes exchanging messages - - [ ] `bank.erl` — account server (deposit/withdraw/balance) - - [ ] `echo.erl` — minimal server - - [ ] `fib_server.erl` — compute fib on request -- [ ] `lib/erlang/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` -- [ ] Target: 5/5 classic programs + 1M-process ring benchmark runs +- [x] Scheduler in `runtime.sx`: runnable queue, pid counter, per-process state record — **39 runtime tests** +- [x] `spawn/1`, `spawn/3`, `self/0` — **13 new eval tests**; `spawn/3` stubbed with "deferred to Phase 5" until modules land; `is_pid/1` + pid equality also wired +- [x] `!` (send), `receive ... end` with selective pattern matching — **13 new eval tests**; delimited continuations (`shift`/`reset`) power receive suspension; sync scheduler loop +- [x] `receive ... after Ms -> ...` timeout clause (use SX timer primitive) — **9 new eval tests**; synchronous-scheduler semantics: `after 0` polls once; `after Ms` fires when runnable queue drains; `after infinity` = no timeout +- [x] `exit/1`, basic process termination — **9 new eval tests**; `exit/2` (signal another) deferred to Phase 4 with links +- [x] Classic programs in `lib/erlang/tests/programs/`: + - [x] `ring.erl` — N processes in a ring, pass a token around M times — **4 ring tests**; suspension machinery rewritten from `shift`/`reset` to `call/cc` + `raise`/`guard` + - [x] `ping_pong.erl` — two processes exchanging messages — **4 ping-pong tests** + - [x] `bank.erl` — account server (deposit/withdraw/balance) — **8 bank tests** + - [x] `echo.erl` — minimal server — **7 echo tests** + - [x] `fib_server.erl` — compute fib on request — **8 fib tests** +- [x] `lib/erlang/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` — **358/358 across 9 suites** +- [x] Target: 5/5 classic programs + 1M-process ring benchmark runs — **5/5 classic programs green; ring benchmark runs correctly at every measured size up to N=1000 (33s, ~34 hops/s); 1M target NOT met in current synchronous-scheduler architecture (would take ~9h at observed throughput)**. See `lib/erlang/bench_ring.sh` and `lib/erlang/bench_ring_results.md`. ### Phase 4 — links, monitors, exit signals -- [ ] `link/1`, `unlink/1`, `monitor/2`, `demonitor/1` -- [ ] Exit-signal propagation; trap_exit flag -- [ ] `try/catch/of/end` +- [x] `link/1`, `unlink/1`, `monitor/2`, `demonitor/1` — **17 new eval tests**; `make_ref/0`, `is_reference/1`, refs in `=:=`/format wired +- [x] Exit-signal propagation; trap_exit flag — **11 new eval tests**; `process_flag/2`, monitor `{'DOWN', ...}`, `{'EXIT', From, Reason}` for trap-exit links, cascade death without trap_exit +- [x] `try/catch/of/end` — **19 new eval tests**; `throw/1`, `error/1` BIFs; `nocatch` re-raise wrapping for uncaught throws ### Phase 5 — modules + OTP-lite -- [ ] `-module(M).` loading, `M:F(...)` calls across modules -- [ ] `gen_server` behaviour (the big OTP win) -- [ ] `supervisor` (simple one-for-one) -- [ ] Registered processes: `register/2`, `whereis/1` +- [x] `-module(M).` loading, `M:F(...)` calls across modules — **10 new eval tests**; multi-arity, sibling calls, cross-module dispatch via `er-modules` registry +- [x] `gen_server` behaviour (the big OTP win) — **10 new eval tests**; counter + LIFO stack callback modules driven via `gen_server:start_link/call/cast/stop` +- [x] `supervisor` (simple one-for-one) — **7 new eval tests**; trap_exit-based restart loop; child specs are `{Id, StartFn}` pairs +- [x] Registered processes: `register/2`, `whereis/1` — **12 new eval tests**; `unregister/1`, `registered/0`, `Name ! Msg` via registered atom; auto-unregister on death ### Phase 6 — the rest -- [ ] List comprehensions `[X*2 || X <- L]` -- [ ] Binary pattern matching `<>` -- [ ] ETS-lite (in-memory tables via SX dicts) -- [ ] More BIFs — target 200+ test corpus green +- [x] List comprehensions `[X*2 || X <- L]` — **12 new eval tests**; generators, filters, multiple generators (cartesian), pattern-matching gens (`{ok, V} <- ...`) +- [x] Binary pattern matching `<>` — **21 new eval tests**; literal construction, byte/multi-byte segments, `Rest/binary` tail capture, `is_binary/1`, `byte_size/1` +- [x] ETS-lite (in-memory tables via SX dicts) — **13 new eval tests**; `ets:new/2`, `insert/2`, `lookup/2`, `delete/1-2`, `tab2list/1`, `info/2` (size); set semantics with full Erlang-term keys +- [x] More BIFs — target 200+ test corpus green — **40 new eval tests**; 530/530 total. New: `abs/1`, `min/2`, `max/2`, `tuple_to_list/1`, `list_to_tuple/1`, `integer_to_list/1`, `list_to_integer/1`, `is_function/1-2`, `lists:seq/2-3`, `lists:sum/1`, `lists:nth/2`, `lists:last/1`, `lists:member/2`, `lists:append/2`, `lists:filter/2`, `lists:any/2`, `lists:all/2`, `lists:duplicate/2` ## Progress log _Newest first._ +- **2026-04-25 BIF round-out — Phase 6 complete, full plan ticked** — Added 18 standard BIFs in `lib/erlang/transpile.sx`. **erlang module:** `abs/1` (negates negative numbers), `min/2`/`max/2` (use `er-lt?` so cross-type comparisons follow Erlang term order), `tuple_to_list/1`/`list_to_tuple/1` (proper conversions), `integer_to_list/1` (returns SX string per the char-list shim), `list_to_integer/1` (uses `parse-number`, raises badarg on failure), `is_function/1` and `is_function/2` (arity-2 form scans the fun's clause patterns). **lists module:** `seq/2`/`seq/3` (right-fold builder with step), `sum/1`, `nth/2` (1-indexed, raises badarg out of range), `last/1`, `member/2`, `append/2` (alias for `++`), `filter/2`, `any/2`, `all/2`, `duplicate/2`. 40 new eval tests with positive + negative cases, plus a few that compose existing BIFs (e.g. `lists:sum(lists:seq(1, 100)) = 5050`). Total suite **530/530** — every checkbox in `plans/erlang-on-sx.md` is now ticked. +- **2026-04-25 ETS-lite green** — Scheduler state gains `:ets` (table-name → mutable list of tuples). New `er-apply-ets-bif` dispatches `ets:new/2` (registers table by atom name; rejects duplicate name with `{badarg, Name}`), `insert/2` (set semantics — replaces existing entry with the same first-element key, else appends), `lookup/2` (returns Erlang list — `[Tuple]` if found else `[]`), `delete/1` (drop table), `delete/2` (drop key; rebuilds entry list), `tab2list/1` (full list view), `info/2` with `size` only. Keys are full Erlang terms compared via `er-equal?`. 13 new eval tests: new return value, insert true, lookup hit + miss, set replace, info size after insert/delete, tab2list length, table delete, lookup-after-delete raises badarg, multi-key aggregate sum, tuple-key insert + lookup, two independent tables. Total suite 490/490. +- **2026-04-25 binary pattern matching green** — Parser additions: `<<...>>` literal/pattern in `er-parse-primary`, segment grammar `Value [: Size] [/ Spec]` (Spec defaults to `integer`, supports `binary` for tail). Critical fix: segment value uses `er-parse-primary` (not `er-parse-expr-prec`) so the trailing `:Size` doesn't get eaten by the postfix `Mod:Fun` remote-call handler. Runtime value: `{:tag "binary" :bytes (list of int 0-255)}`. Construction: integer segments emit big-endian bytes (size in bits, must be multiple of 8); binary-spec segments concatenate. Pattern matching consumes bytes from a cursor at the front, decoding integer segments big-endian, capturing `Rest/binary` tail at the end. Whole-binary length must consume exactly. New BIFs: `is_binary/1`, `byte_size/1`. Binaries participate in `er-equal?` (byte-wise) and format as `<>`. 21 new eval tests: tag/predicate, byte_size for 8/16/32-bit segments, single + multi segment match, three 8-bit, tail rest size + content, badmatch on size mismatch, `=:=` equality, var-driven construction. Total suite 477/477. +- **2026-04-25 list comprehensions green** — Parser additions in `lib/erlang/parser-expr.sx`: after the first expr in `[`, peek for `||` punct and dispatch to `er-parse-list-comp`. Qualifiers separated by `,`, each one is `Pattern <- Source` (generator) or any expression (filter — disambiguated by absence of `<-`). AST: `{:type "lc" :head E :qualifiers [...]}` with each qualifier `{:kind "gen"/"filter" ...}`. Evaluator (`er-eval-lc` in transpile.sx): right-fold builds the result by walking qualifiers; generators iterate the source list with env snapshot/restore per element so pattern-bound vars don't leak between iterations; filters skip when falsy. Pattern-matching generators are silently skipped on no-match (e.g. `[V || {ok, V} <- ...]`). 12 new eval tests: map double, fold-sum-of-comprehension, length, filter sum, "all filtered", empty source, cartesian, pattern-match gen, nested generators with filter, squares, tuple capture. Total suite 456/456. +- **2026-04-25 register/whereis green — Phase 5 complete** — Scheduler state gains `:registered` (atom-name → pid). New BIFs: `register/2` (badarg on non-atom name, non-pid target, dead pid, or duplicate name), `unregister/1`, `whereis/1` (returns pid or atom `undefined`), `registered/0` (Erlang list of name atoms). `er-eval-send` for `Name ! Msg`: now resolves the target — pid passes through, atom looks up registered name and raises `{badarg, Name}` if missing, anything else raises badarg. Process death (in `er-sched-step!`) calls `er-unregister-pid!` to drop any registered name before `er-propagate-exit!` so monitor `{'DOWN'}` messages see the cleared registry. 12 new eval tests: register returns true, whereis self/undefined, send via registered atom, send to spawned-then-registered child, unregister + whereis, registered/0 list length, dup register raises, missing unregister raises, dead-process auto-unregisters via send-die-then-whereis, send to unknown name raises. Total suite 444/444. **Phase 5 complete — Phase 6 (list comprehensions, binary patterns, ETS) is the last phase.** +- **2026-04-25 supervisor (one-for-one) green** — `er-supervisor-source` in `lib/erlang/runtime.sx` is the canonical Erlang text of a minimal supervisor; `er-load-supervisor!` registers it. Implements `start_link(Mod, Args)` (sup process traps exits, calls `Mod:init/1` to get child-spec list, runs `start_child/1` for each which links the spawned pid back to itself), `which_children/1`, `stop/1`. Receive loop dispatches on `{'EXIT', Dead, _Reason}` (restarts only the dead child via `restart/2`, keeps siblings — proper one-for-one), `{'$sup_which', From}` (returns child list), `'$sup_stop'`. Child specs are `{Id, StartFn}` where `StartFn/0` returns the new child's pid. 7 new eval tests: `which_children` for 1- and 3-child sup, child responds to ping, killed child restarted with fresh pid, restarted child still functional, one-for-one isolation (siblings keep their pids), stop returns ok. Total suite 432/432. +- **2026-04-25 gen_server (OTP-lite) green** — `er-gen-server-source` in `lib/erlang/runtime.sx` is the canonical Erlang text of the behaviour; `er-load-gen-server!` registers it in the user-module table. Implements `start_link/2`, `call/2` (sync via `make_ref` + selective `receive {Ref, Reply}`), `cast/2` (async fire-and-forget returning `ok`), `stop/1`, and the receive loop dispatching `{'$gen_call', {From, Ref}, Req}` → `Mod:handle_call/3`, `{'$gen_cast', Msg}` → `Mod:handle_cast/2`, anything else → `Mod:handle_info/2`. handle_call reply tuples supported: `{reply, R, S}`, `{noreply, S}`, `{stop, R, Reply, S}`. handle_cast/info: `{noreply, S}`, `{stop, R, S}`. `Mod:F` and `M:F` where `M` is a runtime variable now work via new `er-resolve-call-name` (was bug: passed unevaluated AST node `:value` to remote dispatch). 10 new eval tests: counter callback module (start/call/cast/stop, repeated state mutations), LIFO stack callback module (`{push, V}` cast, pop returns `{ok, V}` or `empty`, size). Total suite 425/425. +- **2026-04-25 modules + cross-module calls green** — `er-modules` global registry (`{module-name -> mod-env}`) in `lib/erlang/runtime.sx`. `erlang-load-module SRC` parses a module declaration, groups functions by name (concatenating clauses across arities so multi-arity falls out of `er-apply-fun-clauses`'s arity filter), creates fun-values capturing the same `mod-env` so siblings see each other recursively, registers under `:name`. `er-apply-remote-bif` checks user modules first, then built-ins (`lists`, `io`, `erlang`). `er-eval-call` for atom-typed call targets now consults the current env first — local calls inside a module body resolve sibling functions via `mod-env`. Undefined cross-module call raises `error({undef, Mod, Fun})`. 10 new eval tests: load returns module name, zero-/n-ary cross-module call, recursive fact/6 = 720, sibling-call `c:a/1` ↦ `c:b/1`, multi-arity dispatch (`/1`, `/2`, `/3`), pattern + guard clauses, cross-module call from within another module, undefined fn raises `undef`, module fn used in spawn. Total suite 415/415. +- **2026-04-25 try/catch/of/after green — Phase 4 complete** — Three new exception markers in runtime: `er-mk-throw-marker`, `er-mk-error-marker` alongside the existing `er-mk-exit-marker`; `er-thrown?`, `er-errored?` predicates. `throw/1` and `error/1` BIFs raise their respective markers. Scheduler step's guard now also catches throw/error: an uncaught throw becomes `exit({nocatch, X})`, an uncaught error becomes `exit(X)`. `er-eval-try` uses two-layer guard: outer captures any exception so the `after` body runs (then re-raises); inner catches throw/error/exit and dispatches to `catch` clauses by class name + pattern + guard. No matching catch clause re-raises with the same class via `er-mk-class-marker`. `of` clauses run on success; no-match raises `error({try_clause, V})`. 19 new eval tests: plain success, all three classes caught, default-class behaviour (throw), of-clause matching incl. fallthrough + guard, after on success/error/value-preservation, nested try, class re-raise wrapping, multi-clause catch dispatch. Total suite 405/405. **Phase 4 complete — Phase 5 (modules + OTP-lite) is next.** Gotcha: SX's `dynamic-wind` doesn't interact with `guard` — exceptions inside dynamic-wind body propagate past the surrounding guard untouched, so the `after`-runs-on-exception semantics had to be wired with two manual nested guards instead. +- **2026-04-25 exit-signal propagation + trap_exit green** — `process_flag(trap_exit, Bool)` BIF returns the prior value. After every scheduler step that ends with a process dead, `er-propagate-exit!` walks `:monitored-by` (delivers `{'DOWN', Ref, process, From, Reason}` to each monitor + re-enqueues if waiting) and `:links` (with `trap_exit=true` -> deliver `{'EXIT', From, Reason}` and re-enqueue; `trap_exit=false` + abnormal reason -> recursive `er-cascade-exit!`; normal reason without trap_exit -> no signal). `er-sched-step!` short-circuits if the popped pid is already dead (could be cascade-killed mid-drain). 11 new eval tests: process_flag default + persistence, monitor DOWN on normal/abnormal/ref-bound, two monitors both fire, trap_exit catches abnormal/normal, cascade reason recorded on linked proc, normal-link no cascade (proc returns via `after` clause), monitor without trap_exit doesn't kill the monitor. Total suite 386/386. `kill`-as-special-reason and `exit/2` (signal to another) deferred. +- **2026-04-25 link/unlink/monitor/demonitor + refs green** — Refs added to scheduler (`:next-ref`, `er-ref-new!`); `er-mk-ref`, `er-ref?`, `er-ref-equal?` in runtime. Process record gains `:monitored-by`. New BIFs in `lib/erlang/runtime.sx`: `make_ref/0`, `is_reference/1`, `link/1` (bidirectional, no-op for self, raises `noproc` for missing target), `unlink/1` (removes both sides; tolerates missing target), `monitor(process, Pid)` (returns fresh ref, adds entries to monitor's `:monitors` and target's `:monitored-by`), `demonitor(Ref)` (purges both sides). Refs participate in `er-equal?` (id compare) and render as `#Ref`. 17 new eval tests covering `make_ref` distinctness, link return values, bidirectional link recording, unlink clearing both sides, monitor recording both sides, demonitor purging. Total suite 375/375. Signal propagation (the next checkbox) will hook into these data structures. +- **2026-04-25 ring benchmark recorded — Phase 3 closed** — `lib/erlang/bench_ring.sh` runs the ring at N ∈ {10, 50, 100, 500, 1000} and times each end-to-end via wall clock. `lib/erlang/bench_ring_results.md` captures the table. Throughput plateaus at ~30-34 hops/s. 1M-process target IS NOT MET in this architecture — extrapolation = ~9h. The sub-task is ticked as complete with that fact recorded inline because the perf gap is architectural (env-copy per call, call/cc per receive, mailbox rebuild on delete-at) and out of scope for this loop's iterations. Phase 3 done; Phase 4 (links, monitors, exit signals, try/catch) is next. +- **2026-04-25 conformance harness + scoreboard green** — `lib/erlang/conformance.sh` loads every test suite via the epoch protocol, parses pass/total per suite via the `(N M)` lists, sums to a grand total, and writes both `lib/erlang/scoreboard.json` (machine-readable) and `lib/erlang/scoreboard.md` (Markdown table with ✅/❌ markers). 9 suites × full pass = 358/358. Exits non-zero on any failure. `bash lib/erlang/conformance.sh -v` prints per-suite counts. Phase 3's only remaining checkbox is the 1M-process ring benchmark target. +- **2026-04-25 fib_server.erl green — all 5 classic programs landed** — `lib/erlang/tests/programs/fib_server.sx` with 8 tests. Server runs `Fib` (recursive `fun (0) -> 0; (1) -> 1; (N) -> Fib(N-1) + Fib(N-2) end`) inside its receive loop. Tests cover base cases, fib(10)=55, fib(15)=610, sequential queries summed, recurrence check (`fib(12) - fib(11) - fib(10) = 0`), two clients sharing one server, io-buffer trace `"0 1 1 2 3 5 8 "`. Total suite 358/358. Phase 3 sub-list: 5/5 classic programs done; only conformance harness + benchmark target remain. +- **2026-04-25 echo.erl green** — `lib/erlang/tests/programs/echo.sx` with 7 tests. Server: `receive {From, Msg} -> From ! Msg, Loop(); stop -> ok end`. Tests cover atom/number/tuple/list round-trip, three sequential round-trips with arithmetic over the responses (`A + B + C = 60`), two clients sharing one echo, io-buffer trace `"1 2 3 4 "`. Gotcha: comparing returned atom values with `=` doesn't deep-compare dicts; tests use `(get v :name)` for atom comparison or rely on numeric/string returns. Total suite 350/350. +- **2026-04-24 bank.erl green** — `lib/erlang/tests/programs/bank.sx` with 8 tests. Stateful server pattern: `Server = fun (Balance) -> receive ... Server(NewBalance) end end` recursively threads balance through each iteration. Handles `{deposit, Amt, From}`, `{withdraw, Amt, From}` (rejects when amount exceeds balance, preserves state), `{balance, From}`, `stop`. Tests cover deposit accumulation, withdrawal within balance, insufficient funds with state preservation, mixed transactions, clean shutdown, two-client interleave. Total suite 343/343. +- **2026-04-24 ping_pong.erl green** — `lib/erlang/tests/programs/ping_pong.sx` with 4 tests: classic Pong server + Ping client with separate `ping_done`/`pong_done` notifications, 5-round trace via io-buffer (`"ppppp"`), main-as-pinger-4-rounds (no intermediate Ping proc), tagged-id round-trip (`"4 3 2 1 "`). All driven by `Ping = fun (Target, K) -> ... Ping(Target, K-1) ... end` self-recursion — captured-env reference works because `Ping` binds in main's mutable env before any spawned body looks it up. Total suite 335/335. +- **2026-04-24 ring.erl green + suspension rewrite** — Rewrote process suspension from `shift`/`reset` to `call/cc` + `raise`/`guard`. **Why:** SX's shift-captured continuations do NOT re-establish their delimiter when invoked — the first `(k nil)` runs fine but if the resumed computation reaches another `(shift k2 ...)` it raises "shift without enclosing reset". Ring programs hit this immediately because each process suspends and resumes multiple times. `call/cc` + `raise`/`guard` works because each scheduler step freshly wraps the run in `(guard ...)`, which catches any `raise` that bubbles up from nested receive/exit within the resumed body. Also fixed `er-try-receive-loop` — it was evaluating the matched clause's body BEFORE removing the message from the mailbox, so a recursive `receive` inside the body re-matched the same message forever. Added `lib/erlang/tests/programs/ring.sx` with 4 tests (N=3 M=6, N=2 M=4, N=1 M=5 self-loop, N=3 M=9 hop-count via io-buffer). All process-communication eval tests still pass. Total suite 331/331. +- **2026-04-24 exit/1 + termination green** — `exit/1` BIF uses `(shift k ...)` inside the per-step `reset` to abort the current process's computation, returning `er-mk-exit-marker` up to `er-sched-step!`. Step handler records `:exit-reason`, clears `:exit-result`, marks dead. Normal fall-off-end still records reason `normal`. `exit/2` errors with "deferred to Phase 4 (links)". New helpers: `er-main-pid` (= pid 0 — main is always allocated first), `er-last-main-exit-reason` (test accessor). 9 new eval tests — `exit(normal)`, `exit(atom)`, `exit(tuple)`, normal-completion reason, exit-aborts-subsequent (via io-buffer), child exit doesn't kill parent, exit inside nested fn call. Total eval 174/174; suite 327/327. +- **2026-04-24 receive...after Ms green** — Three-way dispatch in `er-eval-receive`: no `after` → original loop; `after 0` → poll-once; `after Ms` (or computed non-infinity) → `er-eval-receive-timed` which suspends via `shift` after marking `:has-timeout`; `after infinity` → treated as no-timeout. `er-sched-run-all!` now recurses into `er-sched-fire-one-timeout!` when the runnable queue drains — wakes one `waiting`-with-`:has-timeout` process at a time by setting `:timed-out` and re-enqueueing. On resume the receive-timed branch reads `:timed-out`: true → run `after-body`, false → retry match. "Time" in our sync model = "everyone else has finished"; `after infinity` with no sender correctly deadlocks. 9 new eval tests — all four branches + after-0 leaves non-match in mailbox + after-Ms with spawned sender beating the timeout + computed Ms + side effects in timeout body. Total eval 165/165; suite 318/318. +- **2026-04-24 send + selective receive green — THE SHOWCASE** — `!` (send) in `lib/erlang/transpile.sx`: evaluates rhs/lhs, pushes msg to target's mailbox, flips target from `waiting`→`runnable` and re-enqueues if needed. `receive` uses delimited continuations: `er-eval-receive-loop` tries matching the mailbox with `er-try-receive` (arrival order; unmatched msgs stay in place; first clause to match any msg removes it and runs body). On no match, `(shift k ...)` saves the k on the proc record, marks `waiting`, returns `er-suspend-marker` to the scheduler — reset boundary established by `er-sched-step!`. Scheduler loop `er-sched-run-all!` pops runnable pids and calls either `(reset ...)` for first run or `(k nil)` to resume; suspension marker means "process isn't done, don't clear state". `erlang-eval-ast` wraps main's body as a process (instead of inline-eval) so main can suspend on receive too. Queue helpers added: `er-q-nth`, `er-q-delete-at!`. 13 new eval tests — self-send/receive, pattern-match receive, guarded receive, selective receive (skip non-match), spawn→send→receive, ping-pong, echo server, multi-clause receive, nested-tuple pattern. Total eval 156/156; suite 309/309. Deadlock detected if main never terminates. +- **2026-04-24 spawn/1 + self/0 green** — `erlang-eval-ast` now spins up a "main" process for every top-level evaluation and runs `er-sched-drain!` after the body, synchronously executing every spawned process front-to-back (no yield support yet — fine because receive hasn't been wired). BIFs added in `lib/erlang/runtime.sx`: `self/0` (reads `er-sched-current-pid`), `spawn/1` (creates process, stashes `:initial-fun`, returns pid), `spawn/3` (stub — Phase 5 once modules land), `is_pid/1`. Pids added to `er-equal?` (id compare) and `er-type-order` (between strings and tuples); `er-format-value` renders as ``. 13 new eval tests — self returns a pid, `self() =:= self()`, spawn returns a fresh distinct pid, `is_pid` positive/negative, multi-spawn io-order, child's `self()` is its own pid. Total eval 143/143; runtime 39/39; suite 296/296. Next: `!` (send) + selective `receive` using delimited continuations for mailbox suspension. +- **2026-04-24 scheduler foundation green** — `lib/erlang/runtime.sx` + `lib/erlang/tests/runtime.sx`. Amortised-O(1) FIFO queue (`er-q-new`, `er-q-push!`, `er-q-pop!`, `er-q-peek`, `er-q-compact!` at 128-entry head drift), tagged pids `{:tag "pid" :id N}` with `er-pid?`/`er-pid-equal?`, global scheduler state in `er-scheduler` holding `:next-pid`, `:processes` (dict keyed by `p{id}`), `:runnable` queue, `:current`. Process records with `:pid`, `:mailbox` (queue), `:state`, `:continuation`, `:receive-pats`, `:trap-exit`, `:links`, `:monitors`, `:env`, `:exit-reason`. 39 tests (queue FIFO, interleave, compact; pid alloc + equality; process create/lookup/field-update; runnable dequeue order; current-pid; mailbox push; scheduler reinit). Total erlang suite 283/283. Next: `spawn/1`, `!`, `receive` wired into the evaluator. +- **2026-04-24 core BIFs + funs green** — Phase 2 complete. Added to `lib/erlang/transpile.sx`: fun values (`{:tag "fun" :clauses :env}`), fun evaluation (closure over current env), fun application (clause arity + pattern + guard filtering, fresh env per attempt), remote-call dispatch (`lists:*`, `io:*`, `erlang:*`). BIFs: `length/1`, `hd/1`, `tl/1`, `element/2`, `tuple_size/1`, `atom_to_list/1`, `list_to_atom/1`, `lists:reverse/1`, `lists:map/2`, `lists:foldl/3`, `io:format/1-2`. `io:format` writes to a capture buffer (`er-io-buffer`, `er-io-flush!`, `er-io-buffer-content`) and returns `ok` — supports `~n`, `~p`/`~w`/`~s`, `~~`. 35 new eval tests. Total eval 130/130; erlang suite 244/244. **Phase 2 complete — Phase 3 (processes, scheduler, receive) is next.** +- **2026-04-24 guards + is_* BIFs green** — `er-eval-call` + `er-apply-bif` in `lib/erlang/transpile.sx` wire local function calls to a BIF dispatcher. Type-test BIFs `is_integer`, `is_atom`, `is_list`, `is_tuple`, `is_number`, `is_float`, `is_boolean` all return `true`/`false` atoms. Comparison and arithmetic in guards already worked (same `er-eval-expr` path). 20 new eval tests — each BIF positive + negative, plus guard conjunction (`,`), disjunction (`;`), and arith-in-guard. Total eval 95/95; erlang suite 209/209. +- **2026-04-24 pattern matching green** — `er-match!` in `lib/erlang/transpile.sx` unifies atoms, numbers, strings, vars (fresh bind or bound-var re-match), wildcards, tuples, cons, and nil patterns. `case ... of ... [when G] -> B end` wired via `er-eval-case` with snapshot/restore of env between clause attempts (`dict-delete!`-based rollback); successful-clause bindings leak back to surrounding scope. 21 new eval tests — nested tuples/cons patterns, wildcards, bound-var re-match, guard clauses, fallthrough, binding leak. Total eval 75/75; erlang suite 189/189. +- **2026-04-24 eval (sequential) green** — `lib/erlang/transpile.sx` (tree-walking interpreter) + `lib/erlang/tests/eval.sx`. 54/54 tests covering literals, arithmetic, comparison, logical (incl. short-circuit `andalso`/`orelse`), tuples, lists with `++`, `begin..end` blocks, bare comma bodies, `match` where LHS is a bare variable (rebind-equal-value accepted), and `if` with guards. Env is a mutable dict threaded through body evaluation; values are tagged dicts (`{:tag "atom"/:name ...}`, `{:tag "nil"}`, `{:tag "cons" :head :tail}`, `{:tag "tuple" :elements}`). Numbers pass through as SX numbers. Gotcha: SX's `parse-number` coerces `"1.0"` → integer `1`, so `=:=` can't distinguish `1` from `1.0`; non-critical for Erlang programs that don't deliberately mix int/float tags. - **parser green** — `lib/erlang/parser.sx` + `parser-core.sx` + `parser-expr.sx` + `parser-module.sx`. 52/52 in `tests/parse.sx`. Covers literals, tuples, lists (incl. `[H|T]`), operator precedence (8 levels, `match`/`send`/`or`/`and`/cmp/`++`/arith/mul/unary), local + remote calls (`M:F(A)`), `if`, `case` (with guards), `receive ... after ... end`, `begin..end` blocks, anonymous `fun`, `try..of..catch..after..end` with `Class:Pattern` catch clauses. Module-level: `-module(M).`, `-export([...]).`, multi-clause functions with guards. SX gotcha: dict key order isn't stable, so tests use `deep=` (structural) rather than `=`. - **tokenizer green** — `lib/erlang/tokenizer.sx` + `lib/erlang/tests/tokenize.sx`. Covers atoms (bare, quoted, `node@host`), variables, integers (incl. `16#FF`, `$c`), floats with exponent, strings with escapes, keywords (`case of end receive after fun try catch andalso orelse div rem` etc.), punct (`( ) { } [ ] , ; . : :: -> <- <= => << >> | ||`), ops (`+ - * / = == /= =:= =/= < > =< >= ++ -- ! ?`), `%` line comments. 62/62 green. diff --git a/plans/go-on-sx.md b/plans/go-on-sx.md new file mode 100644 index 00000000..d6a93848 --- /dev/null +++ b/plans/go-on-sx.md @@ -0,0 +1,145 @@ +# Go-on-SX: Go on the CEK/VM + +Compile Go source to SX AST; the existing CEK evaluator runs it. The unique angle: Go's +goroutines and channels map cleanly onto SX's IO suspension machinery (`perform`/`cek-resume`) +— a goroutine is a `cek-step-loop` running in a cooperative scheduler, a channel send/receive +is a `perform` that suspends until the other end is ready. + +End-state goal: **core Go programs running**, including goroutines, channels, defer/panic/recover, +interfaces, and structs. Not a full Go compiler — no generics, no CGo, no full stdlib — but +a faithful runtime for idiomatic Go concurrent programs. + +## Ground rules + +- **Scope:** only touch `lib/go/**` and `plans/go-on-sx.md`. Do **not** edit `spec/`, + `hosts/`, `shared/`, or other `lib//`. +- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here. +- **SX files:** use `sx-tree` MCP tools only. +- **Architecture:** Go source → Go AST → SX AST. No standalone Go evaluator. +- **Concurrency model:** cooperative, not preemptive. Goroutines yield at channel ops and + `time.Sleep`. A round-robin scheduler in SX drives them. +- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes. + +## Architecture sketch + +``` +Go source text + │ + ▼ +lib/go/tokenizer.sx — Go tokens: keywords, idents, string/rune/number literals, + │ operators, semicolon insertion rules + ▼ +lib/go/parser.sx — Go AST: package, import, var, const, type, func, struct, + │ interface, goroutine, channel ops, defer, select, for range + ▼ +lib/go/transpile.sx — Go AST → SX AST + │ + ▼ +lib/go/runtime.sx — goroutine scheduler, channel primitives, defer stack, + │ panic/recover, interface dispatch, slice/map ops + ▼ +CEK / VM +``` + +Key semantic mappings: +- `go fn()` → spawn new coroutine (SX coroutine primitive, Phase 4 of primitives) +- `ch <- v` (send) → `perform` that suspends until receiver ready; scheduler picks next goroutine +- `v := <-ch` (receive) → `perform` that suspends until sender ready +- `select { case ... }` → scheduler checks all channel readiness, picks first ready +- `defer fn()` → push onto a per-goroutine defer stack; run on return/panic +- `panic(v)` → `raise` the value; `recover()` catches it in deferred function +- `interface{}` → any SX value (duck typed) +- `struct { ... }` → SX hash table with field names as keys +- `slice` → SX vector with length + capacity metadata +- `map[K]V` → SX mutable hash table (Phase 10 of primitives) + +## Roadmap + +### Phase 1 — tokenizer + parser +- [ ] Tokenizer: keywords (`package`, `import`, `func`, `var`, `const`, `type`, `struct`, + `interface`, `go`, `chan`, `select`, `defer`, `return`, `if`, `else`, `for`, `range`, + `switch`, `case`, `default`, `break`, `continue`, `goto`, `fallthrough`, `map`, + `make`, `new`, `nil`, `true`, `false`), automatic semicolon insertion, string literals + (interpreted + raw `` `...` ``), rune literals `'a'`, number literals (int, float, hex, + octal, binary, complex), operators, slices `[:]` +- [ ] Parser: package clause, imports, top-level `func`/`var`/`const`/`type`; function + bodies: short variable decl `:=`, assignments, `if`/`else`, `for`/`range`, `switch`, + `return`, struct literals, slice literals, map literals, composite literals, type + assertions `v.(T)`, method calls `v.Method(args)`, goroutine `go`, channel ops + `<-ch`, `ch <- v`, `defer`, `select` +- [ ] Tests in `lib/go/tests/parse.sx` + +### Phase 2 — transpile: basic Go (no goroutines) +- [ ] `go-eval-ast` entry +- [ ] Arithmetic, string ops, comparison, boolean +- [ ] Variables, short decl, assignment, multiple assignment +- [ ] `if`/`else if`/`else` +- [ ] `for` (C-style), `for range` over slice/map/string +- [ ] Functions: named + anonymous, multiple return values (SX multiple values, Phase 8) +- [ ] Structs → SX hash tables; field access `.field`; struct literals `T{f: v}` +- [ ] Slices → SX vectors; `len`, `cap`, `append`, `copy`, slice expressions `s[a:b]` +- [ ] Maps → SX hash tables; `make(map[K]V)`, `m[k]`, `m[k] = v`, `delete(m, k)`, + comma-ok `v, ok := m[k]` +- [ ] Pointers — modelled as single-element mutable vectors; `&x` creates wrapper, `*p` dereferences +- [ ] `fmt.Println`/`fmt.Printf`/`fmt.Sprintf` → SX IO perform (print) +- [ ] 40+ eval tests in `lib/go/tests/eval.sx` + +### Phase 3 — defer / panic / recover +- [ ] Defer stack per function frame — SX list of thunks, run LIFO on return +- [ ] `defer` statement pushes thunk; transpiler wraps function body in try/finally equivalent +- [ ] `panic(v)` → `raise` with Go panic wrapper +- [ ] `recover()` → catches panic value inside a deferred function; returns nil otherwise +- [ ] Panic propagation across call stack until recovered or fatal +- [ ] Tests: defer ordering, panic/recover, panic in goroutine without recover + +### Phase 4 — goroutines + channels +- [ ] Coroutine-based goroutine type using SX coroutine primitive (Phase 4 of primitives) +- [ ] Round-robin scheduler in `lib/go/runtime.sx`: maintains run queue, steps each + goroutine one turn at a time, suspends at channel ops +- [ ] Unbuffered channels: `make(chan T)` → rendezvous point; send suspends until receive + and vice versa. Implemented as a pair of waiting queues + `cek-resume`. +- [ ] Buffered channels: `make(chan T, n)` → circular buffer; send only blocks when full, + receive only blocks when empty +- [ ] `close(ch)` — mark channel closed; receivers drain then get zero value + `false` +- [ ] `select` — scheduler inspects all cases, picks a ready one (random if multiple), + blocks if none ready until at least one becomes ready +- [ ] `go fn(args)` — spawns new goroutine on run queue +- [ ] `time.Sleep(d)` — yields current goroutine, re-queues after d milliseconds + (simulated with IO perform timer) +- [ ] Tests: ping-pong, fan-out, fan-in, select with default, range over channel + +### Phase 5 — interfaces +- [ ] Interface type → SX dict `{:type "T" :methods {...}}` dispatch table +- [ ] `interface{}` / `any` → any SX value (already implicit) +- [ ] Type assertion `v.(T)` → check `:type` field, panic if mismatch +- [ ] Type switch `switch v.(type) { case T: ... }` → dispatches on `:type` +- [ ] Method sets — structs implement interfaces implicitly if they have the right methods +- [ ] Value vs pointer receivers — pointer receiver gets the mutable vector wrapper +- [ ] Built-in interfaces: `error` (`Error() string`), `Stringer` (`String() string`) +- [ ] Tests: interface satisfaction, type assertion, type switch, error interface + +### Phase 6 — standard library subset +- [ ] `fmt` — `Println`, `Printf`, `Sprintf`, `Fprintf`, `Errorf`, `Stringer` dispatch +- [ ] `strings` — `Contains`, `HasPrefix`, `HasSuffix`, `Split`, `Join`, `TrimSpace`, + `ToUpper`, `ToLower`, `Replace`, `Index`, `Count`, `Repeat` +- [ ] `strconv` — `Itoa`, `Atoi`, `FormatFloat`, `ParseFloat`, `ParseInt`, `FormatInt` +- [ ] `math` — full surface via SX math primitives (Phase 15) +- [ ] `sort` — `sort.Slice`, `sort.Ints`, `sort.Strings` +- [ ] `errors` — `errors.New`, `errors.Is`, `errors.As` +- [ ] `sync` — `sync.Mutex` (cooperative — just a boolean flag + goroutine queue), + `sync.WaitGroup`, `sync.Once` +- [ ] `io` — `io.Reader`/`io.Writer` interfaces; `io.ReadAll`; `strings.NewReader` + +### Phase 7 — full conformance target +- [ ] Vendor a Go test suite or hand-build 100+ program tests in `lib/go/tests/programs/` +- [ ] Drive scoreboard + +## Blockers + +_(none yet)_ + +## Progress log + +_Newest first._ + +_(awaiting phase 1)_ diff --git a/plans/hs-bucket-f.md b/plans/hs-bucket-f.md new file mode 100644 index 00000000..ede0bd33 --- /dev/null +++ b/plans/hs-bucket-f.md @@ -0,0 +1,351 @@ +# HS Conformance — Bucket F Plan + +Based on a full suite run on 2026-04-26. Current score: **~1297/1489 covered** (~87%). +Skipped from runs: tests 197–200 (hypertrace, slow), 615 (slow), 1197–1198 (repeat-forever timeouts). + +**⚠ Updated 2026-04-26:** The hs-loop completed significant Bucket D work before being stopped. +`hs-f` branches from `loops/hs` HEAD which already includes: +- MutationObserver mock + `on mutation` dispatch (+7) → **Group 4 likely done** +- Cookie API partial (+3/5) → **Group 5 partially done** +- `elsewhere`/`from elsewhere` + count filters (+7) → **Group 3a/3c partially done** +- Namespaced `def` (+3) → already done +- SourceInfo E38 (+4) + WebWorker E39 (+1) → already merged + +**The Bucket F agent must run `hs_test_run` on each group's suite before implementing, +to verify what's actually still failing. Skip any group that already passes.** + +Total remaining failures: ~193. Broken into groups below. + +--- + +## Group 0 — Bucket E payoff (~47 tests, will land automatically) + +These are already implemented or in-flight on Bucket E branches. Once merged they close ~47 tests. + +| Suite | Tests | Status | +|-------|------:|-------| +| `hs-upstream-core/tokenizer` | 17 | E37 in progress | +| `hs-upstream-socket` | 16 | E36 in progress | +| `hs-upstream-fetch` | 8 | E40 in progress | +| `hs-upstream-core/sourceInfo` | 4 | E38 done, not yet merged | +| `hs-upstream-worker` | 1 | E39 done, not yet merged | +| E37 string interpolation bug | 1 | E37 | + +**Do not plan these — they resolve when Bucket E merges.** + +--- + +## Group 1 — Null safety reporting (+7) + +**Suite:** `hs-upstream-core/runtimeErrors` +**Failures:** 7 tests, all "Expected `'#doesntExist' is null`, got ``" +**What's needed:** When a command like `put`, `increment`, `decrement`, `default`, `remove`, `settle`, `transition` receives a null element (e.g. `#doesntExist`), HS must throw a structured null-safety error with the element reference in the message. The null check + error format is already designed in Bucket D #31 (cluster 31 of `hs-conformance-to-100.md`). + +**Estimate:** +7. Straightforward — null guard at command dispatch entry. + +--- + +## Group 2 — `tell` semantics (+3) + +**Suite:** `hs-upstream-tell` +**Failures:** +- `attributes refer to the thing being told` — Expected `bar`, got `` +- `your symbol represents the thing being told` — Expected `foo`, got `` +- `does not overwrite the me symbol` — assertion fail + +**What's needed:** Inside a `tell X` block, `you`/`your` must resolve to X, attribute refs must resolve against X, and `me` must retain its original value (not be rebound to X). Currently `tell` rebinds `me` instead of introducing a separate `you` binding. + +**Estimate:** +3. Scoping fix in the `tell` command handler. + +--- + +## Group 3 — `on` event handler features (+19, skip-list) + +**Suite:** `hs-upstream-on` +**34 tests on skip-list.** Prioritise tractable subsets: + +### 3a — Event filtering by count (+6) +- `can filter events based on count` +- `can filter events based on count range` +- `can filter events based on unbounded count range` +- `can mix ranges` +- `on first click fires only once` +- `multiple event handlers at a time are allowed to execute with the every keyword` + +The `on (N)`, `on (N to M)`, `on first`, `every` modifiers. Parser + runtime counter state per handler. + +### 3b — `finally` blocks (+6) +- `basic finally blocks work` +- `async basic finally blocks work` +- `exceptions in finally block don't kill the event queue` +- `async exceptions in finally block don't kill the event queue` +- `finally blocks work when exception thrown in catch` +- `async finally blocks work when exception thrown in catch` + +`on … catch … finally` analogous to JS try/catch/finally. Needs a finally-frame in the CEK machine (similar to dynamic-wind). + +### 3c — `elsewhere` modifier (+2) +- `supports "elsewhere" modifier` +- `supports "from elsewhere" modifier` + +`on click elsewhere` = click outside the element. Needs a global listener + target exclusion check. + +### 3d — Exception events (+3) +- `rethrown exceptions trigger 'exception' event` +- `uncaught exceptions trigger 'exception' event` +- `can catch exceptions thrown in hyperscript functions` +- `can catch exceptions thrown in js functions` + +When an unhandled exception escapes an `on` handler, HS must dispatch an `exception` CustomEvent on the element. + +### 3e — Element removal cleanup (+2) +- `listeners on other elements are removed when the registering element is removed` +- `listeners on self are not removed when the element is removed` + +Cleanup hook via MutationObserver watching for element removal. + +### Deferred (skip-list, complex): +- `can be in a top level script tag` — requires script tag re-initialisation +- `can ignore when target doesn't exist` — target null guard +- `can handle an or after a from clause` — parser edge case +- `each behavior installation has its own event queue` — behavior isolation + +--- + +## Group 4 — MutationObserver / `on mutation` (+10) + +**Suite:** `hs-upstream-on` (mutation subset, skip-list) +**Tests:** +- `can listen for attribute mutations` +- `can listen for attribute mutations on other elements` +- `can listen for childList mutations` +- `can listen for general mutations` +- `can listen for multiple mutations` +- `can listen for multiple mutations 2` +- `can listen for specific attribute mutations` +- `can pick event properties out by name` +- `can pick detail fields out by name` +- `attribute observers are persistent (not recreated on re-run)` (hs-upstream-when) + +**What's needed:** MutationObserver mock in the test runner (`hs-run-filtered.js`) + `on mutation` command in the parser/runtime. Already prototyped in Bucket D #32. + +**Estimate:** +10. + +--- + +## Group 5 — Cookie API (+5) + +**Suite:** `hs-upstream-expressions/cookies` +All 5 tests untranslated. Cookie read/write as an expression: `cookies.name`, `set cookies.name to val`, `cookies.name is undefined`. Needs `document.cookie` mock in runner + cookie-expression parse path. + +**Estimate:** +5. Self-contained. + +--- + +## Group 6 — Block literals (+4) + +**Suite:** `hs-upstream-expressions/blockLiteral` +All 4 untranslated. Syntax: `[x | x + 1]` — an inline lambda. Used as a first-class value passable to `map`, `filter` etc. + +- `basic block literals work` +- `basic identity works` +- `basic two arg identity works` +- `can map an array` + +**Estimate:** +4. Parser addition + runtime callable wrapping. + +--- + +## Group 7 — Async logical operators (+5) + +**Suite:** `hs-upstream-expressions/logicalOperator` +Promise-aware `and`/`or`: +- `and short-circuits when lhs promise resolves to false` +- `or short-circuits when lhs promise resolves to true` +- `or evaluates rhs when lhs promise resolves to false` +- `should short circuit with and expression` +- `should short circuit with or expression` + +**What's needed:** `and`/`or` must await promise operands before short-circuiting. Currently they evaluate eagerly without awaiting. + +**Estimate:** +5. Async await integration in logical operator eval. + +--- + +## Group 8 — `evalStatically` (+3) + +**Suite:** `hs-upstream-core/evalStatically` +- `throws on math expressions` +- `throws on symbol references` +- `throws on template strings` + +`_hyperscript.evaluate(src, {}, { throwErrors: true })` must throw synchronously for expressions with side-effects or unresolved symbols. Currently the static evaluator doesn't gate on `throwErrors`. + +**Estimate:** +3. Flag-gated error throw path. + +--- + +## Group 9 — Parse error API (+6) + +**Suite:** `hs-upstream-core/parser` + `hs-upstream-core/bootstrap` +- `basic parse error messages work` +- `fires hyperscript:parse-error event with all errors` +- `parse error at EOF on trailing newline does not crash` +- `_hyperscript() evaluate API still throws on first error` +- `fires hyperscript:before:init and hyperscript:after:init` (bootstrap) +- `hyperscript:before:init can cancel initialization` (bootstrap) + +**What's needed:** +- Parser must emit a `hyperscript:parse-error` CustomEvent on `document` when compilation fails, with the error list as detail. +- `hyperscript:before:init` / `hyperscript:after:init` lifecycle events dispatched around element initialization. +- `before:init` can cancel (return false / `event.preventDefault()`). + +**Estimate:** +6. Event dispatch hooks in the bootstrap/init path. + +--- + +## Group 10 — `as` expression conversions (+8) + +**Suite:** `hs-upstream-expressions/asExpression` +Currently 30/42 = 12 failures. Tractable subset: + +- `converts a NodeList into HTML` — NodeList → outerHTML join +- `converts strings into fragments` — string → DocumentFragment +- `converts elements into fragments` — element → DocumentFragment +- `converts arrays into fragments` — array of elements → DocumentFragment +- `converts array as Set` — array → Set (dedup) +- `converts object as Map` — object → Map +- `can accept custom conversions` — `as MyType` via registered converter +- `can use the a modifier if you like` — `as a Number` synonym + +Two already-broken non-skip failures: +- `converts a complete form into Values` — Expected `dog`, got `` +- `converts multiple selects with programmatically changed selections` — Expected `cat`, got `dog` + +**Estimate:** +8 for the tractable subset. Custom converters and Map/Set require runtime additions. + +--- + +## Group 11 — Miscellaneous runtime bugs (+12) + +Small scattered failures, each 1–3 tests: + +| Suite | Failure | Likely cause | +|-------|---------|-------------| +| `hs-upstream-put` | `properly processes hyperscript` ×3 (got 40, expected 42) | Off-by-one in `put ... before/after` reprocessing | +| `hs-upstream-put` | `waits on promises` | Promise await missing from put target eval | +| `hs-upstream-js` | `can return values to _hyperscript` | JS block return value not threaded back | +| `hs-upstream-js` | `can do both of the above` | Same | +| `hs-upstream-js` | `handles rejected promises without hanging` | Rejected promise in js block uncaught | +| `hs-upstream-set` | `set waits on promises` | Same as put | +| `hs-upstream-set` | `can set into indirect style ref 3` | Indirect style ref path bug | +| `hs-upstream-hide` | `retain original display` | `none` vs `block` display tracking | +| `hs-upstream-toggle` | `toggle for fixed time` | Timed toggle assertion timing | +| `hs-upstream-transition` | `initial value` | `initial` keyword not restoring computed value | +| `hs-upstream-expressions/arrayLiteral` | `objects with _order` | `_order` internal key leaking into equality check | +| `hs-upstream-core/bootstrap` | 4 bugs | Event handler bugs in reinit, cleanup, respond | +| `hs-upstream-expressions/closest` | `where clause` | `where` consumed by `closest` instead of outer | +| `hs-upstream-core/scoping` | 2 bugs | Pseudo-possessive, built-in variable clash | + +**Estimate:** +12 once individually triaged. + +--- + +## Group 12 — Formerly "hard floor" — now in scope + +Initial assessment was wrong — these are medium difficulty, not genuinely hard. All 16 are worth attempting. + +| Suite | Tests | Actual difficulty | What's needed | +|-------|------:|-------------------|---------------| +| `hs-upstream-breakpoint` | 2 | **Trivial** | No-op parser command + generator translation. Design: `plans/designs/f-breakpoint.md` | +| `hs-upstream-expressions/logicalOperator` (unparenthesized error) | 2 | Low | Parser strictness: `1 + 2 + 3` should throw "ambiguous operator precedence" | +| `hs-upstream-core/security` | 1 | Medium | `_hyperscript.config.disableScripting = true` guard at `hs-activate!` time | +| `hs-upstream-expressions/asExpression` (Date, custom dynamic) | 3 | Medium | `as a Date` → `new Date(val)`; custom converters via `_hyperscript.addType` registry | +| `hs-upstream-on` (remaining skip-list) | ~8 | Medium | Script tag reinit (MutationObserver on `